presentation fixes, prettyprinter cleanup

library/collections/namespaces.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: namespaces
 USING: hashtables kernel kernel-internals lists math sequences
-strings vectors ;
+strings vectors words ;
 
 ! Variables in Factor:
 !
@@ -117,7 +117,7 @@ SYMBOL: building
 : literal, ( word -- )
     #! Append some code that pushes the word on the stack. Used
     #! when building quotations.
-    unit , \ car , ;
+    literalize % ;
 
 : unique, ( obj -- )
     #! Add the object to the sequence being built with make-seq

library/syntax/parse-syntax.factor

@@ -73,11 +73,7 @@ BUILTIN: f 9 not ;
 : \
     #! Parsed as a piece of code that pushes a word on the stack
     #! \ foo ==> [ foo ] car
-    scan-word dup word? [
-        unit swons  \ car swons
-    ] [
-        swons
-    ] ifte ; parsing
+    scan-word literalize [ swons ] each ; parsing
 
 ! Vocabularies
 : PRIMITIVE:

library/syntax/prettyprint.factor

@@ -12,25 +12,14 @@ SYMBOL: recursion-check
 
 GENERIC: prettyprint* ( indent obj -- indent )
 
-M: object prettyprint* ( indent obj -- indent )
+: unparse. ( obj -- )
     dup unparse swap presented swons unit write-attr ;
 
-: word-attrs ( word -- style )
-    #! Return the style values for the HTML word browser
-    [
-        presented over cons ,
-        dup word-vocabulary [ 
-            "word" over word-name cons ,
-            "vocab" swap word-vocabulary cons ,
-        ] [
-            drop
-        ] ifte
-    ] make-list ;
-
-: word. ( word -- ) dup word-name swap word-attrs write-attr ;
+M: object prettyprint* ( indent obj -- indent )
+    unparse. ;
 
 M: word prettyprint* ( indent word -- indent )
-    dup parsing? [ \ POSTPONE: word. bl ] when word. ;
+    dup parsing? [ \ POSTPONE: unparse. bl ] when unparse. ;
 
 : indent ( indent -- )
     #! Print the given number of spaces.
@@ -54,8 +43,8 @@ M: word prettyprint* ( indent word -- indent )
 : prettyprint-elements ( indent list -- indent )
     [
         dup \? [
-            \ \ word. bl
-            uncons >r car word. bl
+            \ \ unparse. bl
+            uncons >r car unparse. bl
             r> cdr prettyprint-elements
         ] [
             uncons >r prettyprint* bl
@@ -96,11 +85,11 @@ M: word prettyprint* ( indent word -- indent )
     #! or { }, or << >>. The body of the list is indented,
     #! unless the list is empty.
     over [
-        >r >r word. <prettyprint
+        >r >r unparse. <prettyprint
         r> prettyprint-elements
-        prettyprint> r> word.
+        prettyprint> r> unparse.
     ] [
-        >r >r word. bl r> drop r> word.
+        >r >r unparse. bl r> drop r> unparse.
     ] ifte ;
 
 M: list prettyprint* ( indent list -- indent )
@@ -130,16 +119,16 @@ M: tuple prettyprint* ( indent tuple -- indent )
     ] check-recursion ;
 
 M: alien prettyprint* ( alien -- str )
-    \ ALIEN: word. bl alien-address unparse write ;
+    \ ALIEN: unparse. bl alien-address unparse write ;
 
 : matrix-rows. ( indent list -- indent )
     uncons >r [ one-line on prettyprint* ] with-scope r>
     [ over ?prettyprint-newline matrix-rows. ] when* ;
 
 M: matrix prettyprint* ( indent obj -- indent )
-    \ M[ word. bl >r 3 + r>
+    \ M[ unparse. bl >r 3 + r>
     row-list matrix-rows.
-    bl \ ]M word. 3 - ;
+    bl \ ]M unparse. 3 - ;
 
 : prettyprint ( obj -- )
     [
@@ -147,9 +136,6 @@ M: matrix prettyprint* ( indent obj -- indent )
         0 swap prettyprint* drop terpri
     ] with-scope ;
 
-: vocab-link ( vocab -- link )
-    "vocabularies'" swap append ;
-
 : . ( obj -- )
     [
         one-line on

library/syntax/see.factor

@@ -20,11 +20,11 @@ streams strings styles unparser words ;
 : vocab. ( vocab -- ) dup vocab-attrs write-attr ;
 
 : prettyprint-IN: ( word -- )
-    \ IN: word. bl word-vocabulary vocab. terpri ;
+    \ IN: unparse. bl word-vocabulary vocab. terpri ;
 
 : prettyprint-prop ( word prop -- )
     tuck word-name word-prop [
-        bl word.
+        bl unparse.
     ] [
         drop
     ] ifte ;
@@ -72,23 +72,23 @@ streams strings styles unparser words ;
         ] each
     ] when* ;
 
-: definer. ( word -- ) dup definer word. bl word. bl ;
+: definer. ( word -- ) dup definer unparse. bl unparse. bl ;
 
 GENERIC: (see) ( word -- )
 
 M: compound (see) ( word -- )
     tab-size get dup indent swap
     [ documentation. ] keep
-    [ word-def prettyprint-elements \ ; word. ] keep
+    [ word-def prettyprint-elements \ ; unparse. ] keep
     prettyprint-plist terpri drop ;
 
 : prettyprint-M: ( -- indent )
-    \ M: word. bl tab-size get ;
+    \ M: unparse. bl tab-size get ;
 
-: prettyprint-; \ ; word. terpri ;
+: prettyprint-; \ ; unparse. terpri ;
 
 : method. ( word [[ class method ]] -- )
-    uncons >r >r >r prettyprint-M: r> r> word. bl word. bl
+    uncons >r >r >r prettyprint-M: r> r> unparse. bl unparse. bl
     dup prettyprint-newline r> prettyprint-elements
     prettyprint-; drop ;
 
@@ -99,7 +99,7 @@ M: generic (see) ( word -- )
         over "dispatcher" word-prop prettyprint* bl
     ] with-scope
     drop
-    \ ; word. terpri
+    \ ; unparse. terpri
     dup methods [ method. ] each-with ;
 
 M: word (see) drop ;
@@ -107,34 +107,34 @@ M: word (see) drop ;
 GENERIC: class.
 
 M: union class.
-    \ UNION: word. bl
-    dup word. bl
+    \ UNION: unparse. bl
+    dup unparse. bl
     0 swap "members" word-prop prettyprint-elements drop
     prettyprint-; ;
 
 M: complement class.
-    \ COMPLEMENT: word. bl
-    dup word. bl
-    "complement" word-prop word. terpri ;
+    \ COMPLEMENT: unparse. bl
+    dup unparse. bl
+    "complement" word-prop unparse. terpri ;
 
 M: builtin class.
-    \ BUILTIN: word. bl
-    dup word. bl
+    \ BUILTIN: unparse. bl
+    dup unparse. bl
     dup "builtin-type" word-prop unparse write bl
     0 swap "slots" word-prop prettyprint-elements drop
     prettyprint-; ;
 
 M: predicate class.
-    \ PREDICATE: word. bl
-    dup "superclass" word-prop word. bl
-    dup word. bl
+    \ PREDICATE: unparse. bl
+    dup "superclass" word-prop unparse. bl
+    dup unparse. bl
     tab-size get dup prettyprint-newline swap
     "definition" word-prop prettyprint-elements drop
     prettyprint-; ;
 
 M: tuple-class class.
-    \ TUPLE: word. bl
-    dup word. bl
+    \ TUPLE: unparse. bl
+    dup unparse. bl
     "slot-names" word-prop [ write bl ] each
     prettyprint-; ;
 

library/tools/debugger.factor

@@ -17,8 +17,8 @@ vectors words ;
 : type-check-error. ( list -- )
     "Type check error" print
     uncons car dup "Object: " write .
-    "Object type: " write class word. terpri
-    "Expected type: " write builtin-type word. terpri ;
+    "Object type: " write class unparse. terpri
+    "Expected type: " write builtin-type unparse. terpri ;
 
 : float-format-error. ( list -- )
     "Invalid floating point literal format: " write . ;
@@ -86,9 +86,9 @@ M: object error. ( error -- ) . ;
 : :get ( var -- value ) "error-namestack" get (get) ;
 
 : debug-help ( -- )
-    [ :s :r :n :c ] [ word. bl ] each
+    [ :s :r :n :c ] [ unparse. bl ] each
     "show stacks at time of error." print
-    \ :get word.
+    \ :get unparse.
     " ( var -- value ) inspects the error namestack." print ;
 
 : flush-error-handler ( error -- )

library/tools/inspector.factor

@@ -48,19 +48,13 @@ M: hashtable sheet hash>alist unzip 2list ;
     seq-transpose
     [ " | " join ] map ;
 
-: a/an ( noun -- str )
-    first "aeiouAEIOU" contains? "an " "a " ? ;
-
-: a/an. ( noun -- )
-    dup a/an write write ;
-
 : interned? ( word -- ? )
     dup word-name swap word-vocabulary vocab hash ;
 
 : class-banner ( word -- )
     dup metaclass dup [
         "This is a class whose behavior is specifed by the " write
-        unparse write " metaclass," print
+        unparse. " metaclass," print
         "currently having " write
         "predicate" word-prop instances length unparse write
         " instances." print
@@ -91,9 +85,9 @@ M: object extra-banner ( obj -- ) drop ;
 
 : inspect-banner ( obj -- )
     dup references length >r
-    "You are looking at " write dup class unparse a/an.
-    " object with the following printed representation:" print
-    "  " write dup unparse print
+    "You are looking at an instance of the " write dup class unparse.
+    " class:" print
+    "  " write dup unparse. terpri
     "The object has been placed in the inspecting variable." print
     "It is located at address " write dup address >hex write
     " and takes up " write dup size unparse write

library/tools/walker.factor

@@ -50,14 +50,14 @@ sequences io strings vectors words ;
     set-callstack call ;
 
 : walk-banner ( -- )
-    [ &s &r &n &c ] [ word. bl ] each
+    [ &s &r &n &c ] [ unparse. bl ] each
     "show stepper stacks." print
-    \ &get word.
+    \ &get unparse.
     " ( var -- value ) inspects the stepper namestack." print
-    \ step word. " -- single step over" print
-    \ into word. " -- single step into" print
-    \ continue word. " -- continue execution" print
-    \ bye word. " -- exit single-stepper" print
+    \ step unparse. " -- single step over" print
+    \ into unparse. " -- single step into" print
+    \ continue unparse. " -- continue execution" print
+    \ bye unparse. " -- exit single-stepper" print
     report ;
 
 : walk-listener walk-banner "walk " listener-prompt set listener ;

library/ui/hand.factor

@@ -42,6 +42,8 @@ C: hand ( world -- hand )
     [ set-gadget-parent ] 2keep
     [ set-hand-gadget ] keep ;
 
+: hand world get world-hand ;
+
 : button/ ( n hand -- )
     dup hand-gadget over set-hand-clicked
     dup screen-loc over set-hand-click-loc

library/ui/init-world.factor

@@ -5,9 +5,6 @@ USING: generic io kernel listener math namespaces styles threads ;
 
 SYMBOL: stack-display
 
-: <stack-display>
-     ;
-
 : init-world
     global [
         <world> world set

library/ui/load.factor

@@ -7,11 +7,11 @@ USING: kernel parser sequences io ;
     "/library/ui/fonts.factor"
     "/library/ui/text.factor"
     "/library/ui/gestures.factor"
-    "/library/ui/hand.factor"
     "/library/ui/layouts.factor"
     "/library/ui/borders.factor"
     "/library/ui/frames.factor"
     "/library/ui/world.factor"
+    "/library/ui/hand.factor"
     "/library/ui/labels.factor"
     "/library/ui/buttons.factor"
     "/library/ui/line-editor.factor"
@@ -20,9 +20,9 @@ USING: kernel parser sequences io ;
     "/library/ui/editors.factor"
     "/library/ui/menus.factor"
     "/library/ui/splitters.factor"
-    "/library/ui/presentations.factor"
     "/library/ui/incremental.factor"
     "/library/ui/panes.factor"
+    "/library/ui/presentations.factor"
     "/library/ui/init-world.factor"
     "/library/ui/ui.factor"
 ] [

library/ui/panes.factor

@@ -4,6 +4,8 @@ IN: gadgets
 USING: generic hashtables io kernel line-editor listener lists
 math namespaces prettyprint sequences strings styles threads ;
 
+DEFER: <presentation>
+
 ! A pane is an area that can display text.
 
 ! output: pile
@@ -62,7 +64,7 @@ M: pane focusable-child* ( pane -- editor )
     pane-input ;
 
 : pane-write-1 ( style text pane -- )
-    [ <presentation> ] keep pane-current add-gadget ;
+    >r <presentation> r> pane-current add-gadget ;
 
 : pane-terpri ( pane -- )
     dup pane-current over pane-output add-incremental

library/ui/presentations.factor

@@ -11,39 +11,36 @@ global [ 100 <vector> commands set ] bind
 : define-command ( class name quot -- )
     3list commands get push ;
 
-: applicable ( object -- )
-    commands get >list
-    [ car call ] subset-with ;
+: applicable ( object -- list )
+    commands get >list [ car call ] subset-with ;
 
-DEFER: pane-call
+: command-quot ( presented quot -- quot )
+    [ swap literal, % ] make-list
+    [ pane get pane-call drop ] cons ;
 
-: command-menu ( pane -- menu )
-    presented get dup applicable [
-        3dup third [
-            [ swap literal, % ] make-list , ,
-            [ pane-call drop ] %
-        ] make-list >r second r> cons
-    ] map 2nip ;
+: command-menu ( presented -- menu )
+    dup applicable
+    [ [ third command-quot ] keep second swons ] map-with
+    <menu> ;
 
-: init-commands ( gadget pane -- )
-    over presented paint-prop [
-        [ drop ] swap
-        unit
-        [ command-menu <menu> show-menu ] append3
+: init-commands ( gadget -- )
+    dup presented paint-prop dup [
+        [
+            \ drop ,
+            literal,
+            [ command-menu show-menu ] %
+        ] make-list
         button-gestures
     ] [
         2drop
     ] ifte ;
 
 : <styled-label> ( style text -- label )
-    <label> swap alist>hash over set-gadget-paint ;
+    <label> swap dup [ alist>hash ] when over set-gadget-paint ;
 
-: <presentation> ( style text pane -- presentation )
-    pick gadget swap assoc dup [
-        >r 3drop r>
-    ] [
-        drop >r <styled-label> dup r> init-commands
-    ] ifte ;
+: <presentation> ( style text -- presentation )
+    gadget pick assoc dup
+    [ 2nip ] [ drop <styled-label> dup init-commands ] ifte ;
 
 : gadget. ( gadget -- )
     gadget swons unit "" swap write-attr ;

library/ui/world.factor

@@ -11,6 +11,8 @@ vectors ;
 ! need to be layout.
 TUPLE: world running? hand glass invalid ;
 
+DEFER: <hand>
+
 C: world ( -- world )
     f <stack> over set-delegate
     t over set-world-running?
@@ -42,11 +44,8 @@ C: world ( -- world )
 
 M: world inside? ( point world -- ? ) 2drop t ;
 
-: hand world get world-hand ;
-
 : draw-world ( world -- )
     [
-        dup
         { 0 0 0 } width get height get 0 3vector <rectangle> clip set
         draw-gadget
     ] with-surface ;
@@ -55,7 +54,7 @@ DEFER: handle-event
 
 : world-step ( -- ? )
     world get dup world-invalid >r layout-world r>
-    [ dup world-hand update-hand draw-world ] [ drop ] ifte ;
+    [ draw-world ] [ drop ] ifte ;
 
 : next-event ( -- event ? )
     <event> dup SDL_PollEvent ;

library/words.factor

@@ -121,3 +121,7 @@ M: compound definer drop \ : ;
     over f "picker" set-word-prop
     over f "dispatcher" set-word-prop
     (define-compound) ;
+
+: literalize ( word/obj -- quot )
+    #! Produce a quotation that pushes this object.
+    dup word? [ unit [ car ] ] [ f ] ifte cons ;