actions menu cleanup

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index f259c3cf1786b927d35b6b70c070df2e93d5c5a2..f102556402a1dc725e2a518390fe29300b778afb 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,4 +1,3 @@
-\r
 FFI:\r
 \r
 - add a socket timeout\r

diff --git a/library/files.factor b/library/files.factor
index 6ef3f554bbf098fa3a5d07a81c7ec85cca675b02..4380bfc53d37240135f2a26659e86b2da1834363 100644 (file)
--- a/library/files.factor
+++ b/library/files.factor
@@ -30,10 +30,19 @@ USE: combinators
 USE: lists
 USE: logic
 USE: namespaces
+USE: presentation
 USE: stack
 USE: stdio
 USE: strings
 
+: file-actions ( -- list )
+    [
+        [ "Push"             | ""           ]
+        [ "Run file"         | "run-file"   ]
+        [ "List directory"   | "directory." ]
+        [ "Change directory" | "cd"         ]
+    ] ;
+
 : set-mime-types ( assoc -- )
     "mime-types" global set* ;
 
@@ -56,7 +65,10 @@ USE: strings
     directory? dir-icon file-icon ? write-icon ;
 
 : file-link. ( dir name -- )
-    tuck "/" swap cat3 "file-link" swons unit write-attr ;
+    tuck "/" swap cat3 dup "file-link" swons swap
+    file-actions <actions> "actions" swons
+    t "underline" swons
+    3list write-attr ;
 
 : file. ( dir name -- )
     #! If "doc-root" set, create links relative to it.

diff --git a/library/inferior.factor b/library/inferior.factor
index 0549d98381bf24db83f340d50b80cf7856aa0908..b2d5dd95773e6fccdceee3adc57a525bb402bab7 100644 (file)
--- a/library/inferior.factor
+++ b/library/inferior.factor
@@ -39,7 +39,7 @@ USE: stack
 USE: stdio
 USE: streams
 USE: strings
-USE: styles
+USE: presentation
 
 ! The purpose of this library is to allow CFactor to be embedded
 ! inside the Java Factor listener in jEdit.

diff --git a/library/inspector.factor b/library/inspector.factor
index 9a09220baf275b577f74d28b2511d671e157fcbb..f9510cc2a94af17f55c072bf5e6f05deefa670d5 100644 (file)
--- a/library/inspector.factor
+++ b/library/inspector.factor
@@ -35,7 +35,7 @@ USE: namespaces
 USE: stack
 USE: stdio
 USE: strings
-USE: styles
+USE: presentation
 USE: words
 USE: prettyprint
 USE: unparser
@@ -48,42 +48,45 @@ USE: vectors
     #! Print a list of defined variables.
     vars [ print ] each ;
 
+: object-actions ( -- alist )
+    [
+        [ "Describe" | "describe-path"  ]
+        [ "Push"     | "lookup"         ]
+    ] ;
+
 : link-style ( path -- style )
     relative>absolute-object-path
-    "object-link" default-style acons ;
+    dup "object-link" swons swap
+    object-actions <actions> "actions" swons
+    t "underline" swons
+    3list
+    default-style append ;
 
 : var. ( [ name | value ] -- )
     uncons unparse swap link-style write-attr ;
 
 : var-name. ( max name -- )
-    tuck pad-string write dup link-style write-attr ;
+    tuck unparse pad-string write dup link-style
+    swap unparse swap write-attr ;
 
 : value. ( max name value -- )
     >r var-name. ": " write r> . ;
 
-: alist-keys>str ( alist -- alist )
-    [ unswons unparse swons ] map ;
-
 : name-padding ( alist -- col )
-    [ car ] map max-str-length ;
+    [ car unparse ] map max-str-length ;
 
 : describe-assoc ( alist -- )
     dup name-padding swap
     [ dupd uncons value. ] each drop ;
 
 : alist-sort ( list -- list )
-    [ swap car swap car str-lexi> ] sort ;
-
-: describe-assoc* ( alist -- )
-    #! Used to describe alists made from hashtables and
-    #! namespaces.
-    alist-keys>str alist-sort describe-assoc ;
+    [ swap car unparse swap car unparse str-lexi> ] sort ;
 
 : describe-namespace ( namespace -- )
-    [ vars-values ] bind describe-assoc* ;
+    [ vars-values ] bind alist-sort describe-assoc ;
 
 : describe-hashtable ( hashtables -- )
-    hash>alist describe-assoc* ;
+    hash>alist alist-sort describe-assoc ;
 
 : describe ( obj -- )
     [

diff --git a/library/interpreter.factor b/library/interpreter.factor
index e0fe1c97ed76dcb01ffeb036dcff3f5e7219fcae..f86e39bc5f935694e115ddc55a7bced432c807d6 100644 (file)
--- a/library/interpreter.factor
+++ b/library/interpreter.factor
@@ -38,7 +38,7 @@ USE: parser
 USE: stack
 USE: stdio
 USE: strings
-USE: styles
+USE: presentation
 USE: words
 USE: unparser
 USE: vectors
@@ -51,7 +51,7 @@ USE: vectors
     "Type ``exit'' to exit, ``help'' for help." print ;
 
 : print-prompt ( -- )
-    "ok" "prompt" get-style write-attr
+    "ok" "prompt" style write-attr
     ! Print the space without a style, to workaround a bug in
     ! the GUI listener where the style from the prompt carries
     ! over to the input

diff --git a/library/jedit/console.factor b/library/jedit/console.factor
index 4cd58fa46e41ddc41284a48e2e95fbe7f7ac7074..870b0560f42e550f690fd10038235bbea5600688 100644 (file)
--- a/library/jedit/console.factor
+++ b/library/jedit/console.factor
@@ -35,7 +35,7 @@ USE: lists
 USE: namespaces
 USE: stack
 USE: stdio
-USE: styles
+USE: presentation
 USE: streams
 USE: strings
 USE: unparser
@@ -86,48 +86,17 @@ USE: unparser
         "console.Console"
     ] "console.Console$EvalAction" jnew ;
 
-: <action-menu-item> ( path pair -- action )
-    uncons swapd " " swap cat3 <eval-action> ;
-
 : >action-array ( list -- array )
     [ "javax.swing.Action" ] coerce ;
 
-: <actions-menu> ( path actions -- array )
-    [ dupd <action-menu-item> ] map nip >action-array ;
-
-: object-actions ( -- list )
-    [
-        [ "Describe" | "describe-path"  ]
-        [ "Push"     | "lookup"         ]
-        [ "Execute"  | "lookup execute" ]
-        [ "jEdit"    | "lookup jedit"   ]
-        [ "Usages"   | "lookup usages." ]
-    ] ;
-
-: <object-actions-menu> ( path -- alist )
-    unparse object-actions <actions-menu> ;
-
-: file-actions ( -- list )
-    [
-        [ "Push"             | ""           ]
-        [ "Run file"         | "run-file"   ]
-        [ "List directory"   | "directory." ]
-        [ "Change directory" | "cd"         ]
-    ] ;
-
-: <file-actions-menu> ( path -- alist )
-    unparse file-actions <actions-menu> ;
+: <actions-menu> ( actions -- array )
+    [ uncons <eval-action> ] map >action-array ;
 
 : underline-attribute ( attribute-set -- )
     t "Underline" swing-attribute+ ;
 
-: object-link-attribute ( attribute-set target -- )
-    over underline-attribute
-    <object-actions-menu> actions-key attribute+ ;
-
-: file-link-attribute ( attribute-set target -- )
-    over underline-attribute
-    <file-actions-menu> actions-key attribute+ ;
+: actions-attribute ( attribute-set actions -- )
+    <actions-menu> actions-key attribute+ ;
 
 : icon-attribute ( string style value -- )
     dupd <icon> set-icon-style
@@ -137,8 +106,7 @@ USE: unparser
     #! We need the string, since outputting an icon changes the
     #! string to " ".
     <attribute-set> swap [
-        [ "object-link" dupd object-link-attribute ]
-        [ "file-link"   dupd file-link-attribute ]
+        [ "actions"     dupd actions-attribute ]
         [ "bold"        drop dup t "Bold" swing-attribute+ ]
         [ "italics"     drop dup t "Italic" swing-attribute+ ]
         [ "underline"   drop dup t "Underline" swing-attribute+ ]

diff --git a/library/platform/jvm/boot-sumo.factor b/library/platform/jvm/boot-sumo.factor
index 2a8833da226d5de914d98688f0d117d9a218d7fc..69a74923b29d3a26445c829aeb71c68e906e4d0e 100644 (file)
--- a/library/platform/jvm/boot-sumo.factor
+++ b/library/platform/jvm/boot-sumo.factor
@@ -72,7 +72,7 @@ USE: parser
 "/library/extend-stream.factor"             run-resource ! streams
 "/library/platform/jvm/unparser.factor"     run-resource ! unparser
 "/library/platform/jvm/parser.factor"       run-resource ! parser
-"/library/styles.factor"                    run-resource ! styles
+"/library/presentation.factor"              run-resource ! presentation
 "/library/platform/jvm/threads.factor"      run-resource ! threads
 "/library/logging.factor"                   run-resource ! logging
 

diff --git a/library/platform/jvm/init.factor b/library/platform/jvm/init.factor
index 18c9d73694baf0a1e931c20d764ee51a947c619f..dccd0699e917772b64e1f6c829f9c3166a19d36e 100644 (file)
--- a/library/platform/jvm/init.factor
+++ b/library/platform/jvm/init.factor
@@ -38,7 +38,7 @@ USE: stack
 USE: stdio
 USE: streams
 USE: strings
-USE: styles
+USE: presentation
 USE: words
 
 : stdin ( -- stdin )

diff --git a/library/platform/native/init-stage2.factor b/library/platform/native/init-stage2.factor
index 6b6c3880aeecba4ebf6707f5b9e684c6351b01fe..9f835591e1d26f6aa1609eb8153a97bf8026b3ca 100644 (file)
--- a/library/platform/native/init-stage2.factor
+++ b/library/platform/native/init-stage2.factor
@@ -38,7 +38,7 @@ USE: parser
 USE: random
 USE: stack
 USE: streams
-USE: styles
+USE: presentation
 USE: words
 
 : cli-args ( -- args ) 10 getenv ;

diff --git a/library/presentation.factor b/library/presentation.factor
new file mode 100644 (file)
index 0000000..9b174a1
--- /dev/null
+++ b/library/presentation.factor
@@ -0,0 +1,67 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: presentation
+USE: combinators
+USE: kernel
+USE: lists
+USE: namespaces
+USE: stack
+USE: strings
+USE: unparser
+
+: <actions> ( path alist -- alist )
+    #! For each element of the alist, change the value to
+    #! path " " value
+    >r unparse r>
+    [ uncons >r over " " r> cat3 cons ] map nip ;
+
+! A style is an alist whose key/value pairs hold
+! significance to the 'fwrite-attr' word when applied to a
+! stream that supports attributed string output.
+
+: (style) ( name -- style ) "styles" get get* ;
+: default-style ( -- style ) "default" (style) ;
+: style ( name -- style )
+    (style) [ default-style ] unless* ;
+: set-style ( style name -- ) "styles" get set* ;
+
+<namespace> "styles" set
+
+[
+    [ "font" | "Monospaced" ]
+] "default" set-style
+
+[
+    [ "bold" | t ]
+] default-style append "prompt" set-style
+
+[
+    [ "ansi-fg" | "0" ]
+    [ "ansi-bg" | "2" ]
+    [ "fg" | [ 255 0 0 ] ]
+] default-style append "comments" set-style

diff --git a/library/prettyprint.factor b/library/prettyprint.factor
index f08643e6695c2562dcd2f36e65f89d7d86082b76..f916bce40996b91a515eb971f91d7faf3d1a9a99 100644 (file)
--- a/library/prettyprint.factor
+++ b/library/prettyprint.factor
@@ -38,7 +38,7 @@ USE: prettyprint
 USE: stack
 USE: stdio
 USE: strings
-USE: styles
+USE: presentation
 USE: unparser
 USE: vectors
 USE: words
@@ -141,7 +141,7 @@ DEFER: prettyprint*
     dup ends-with-newline? dup [ nip ] [ drop ] ifte ;
 
 : prettyprint-comment ( comment -- )
-    trim-newline "comments" get-style write-attr ;
+    trim-newline "comments" style write-attr ;
 
 : word-link ( word -- link )
     <%
@@ -151,12 +151,26 @@ DEFER: prettyprint*
     word-name %
     %> ;
 
+: word-actions ( -- list )
+    [
+        [ "Describe" | "describe-path"  ]
+        [ "Push"     | "lookup"         ]
+        [ "Execute"  | "lookup execute" ]
+        [ "jEdit"    | "lookup jedit"   ]
+        [ "Usages"   | "lookup usages." ]
+    ] ;
+
 : word-attrs ( word -- attrs )
     dup defined? [
-        dup >r word-link "object-link" r> word-style acons
+        dup >r
+        word-link dup >r "object-link" swons r>
+        word-actions <actions> "actions" swons
+        t "underline" swons
+        3list
+        r>
     ] [
-        word-style
-    ] ifte ;
+        [ ] swap
+    ] ifte word-style append ;
 
 : prettyprint-word ( word -- )
     dup word-name swap word-attrs write-attr ;

diff --git a/library/styles.factor b/library/styles.factor
deleted file mode 100644 (file)
index 539c5c4..0000000
--- a/library/styles.factor
+++ /dev/null
@@ -1,59 +0,0 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-! 
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-! 
-! 1. Redistributions of source code must retain the above copyright notice,
-!    this list of conditions and the following disclaimer.
-! 
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-!    this list of conditions and the following disclaimer in the documentation
-!    and/or other materials provided with the distribution.
-! 
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: styles
-USE: combinators
-USE: kernel
-USE: lists
-USE: namespaces
-USE: stack
-
-! A style is an alist whose key/value pairs hold
-! significance to the 'fwrite-attr' word when applied to a
-! stream that supports attributed string output.
-
-: (get-style) ( name -- style ) "styles" get get* ;
-: default-style ( -- style ) "default" (get-style) ;
-: get-style ( name -- style )
-    (get-style) [ default-style ] unless* ;
-: set-style ( style name -- ) "styles" get set* ;
-
-<namespace> "styles" set
-
-[
-    [ "font" | "Monospaced" ]
-] "default" set-style
-
-[
-    [ "bold" | t ]
-] default-style append "prompt" set-style
-
-[
-    [ "ansi-fg" | "0" ]
-    [ "ansi-bg" | "2" ]
-    [ "fg" | [ 255 0 0 ] ]
-] default-style append "comments" set-style

diff --git a/library/test/styles.factor b/library/test/styles.factor
index de1c4d56e82d644f29ca4e9769f1262a13aa02a5..ff47fde10c2700ec96095236681d61a667613489 100644 (file)
--- a/library/test/styles.factor
+++ b/library/test/styles.factor
@@ -1,18 +1,18 @@
 IN: scratchpad
 USE: lists
 USE: kernel
-USE: styles
+USE: presentation
 USE: test
 
 [ t ] [ default-style assoc? ] unit-test
 [ t ] [
-    f "fooquux" set-style "fooquux" get-style default-style =
+    f "fooquux" set-style "fooquux" style default-style =
 ] unit-test
 [ "Sans-Serif" ] [
     [
         [ "font" | "Sans-Serif" ]
     ] "fooquux" set-style
-    "font" "fooquux" get-style assoc
+    "font" "fooquux" style assoc
 ] unit-test
 
 f "fooquux" set-style

diff --git a/library/vocabulary-style.factor b/library/vocabulary-style.factor
index 1ab7dc392bc3626c9d1e41bc9f389871ecc30781..e974a05c9c5f48e098308edfb0ff83f15b609b21 100644 (file)
--- a/library/vocabulary-style.factor
+++ b/library/vocabulary-style.factor
@@ -31,15 +31,15 @@ USE: lists
 USE: kernel
 USE: namespaces
 USE: stack
-USE: styles
+USE: presentation
 
 : vocab-style ( vocab -- style )
     #! Each vocab has a style object specifying how words are
     #! to be printed.
-    "vocabularies" get-style get* ;
+    "vocabularies" style get* ;
 
 : set-vocab-style ( style vocab -- )
-    >r default-style append r> "vocabularies" get-style set* ;
+    >r default-style append r> "vocabularies" style set* ;
 
 : word-style ( word -- style )
     word-vocabulary [ vocab-style ] [ default-style ] ifte* ;