better presentations in UI

library/styles.factor

@@ -28,3 +28,5 @@ SYMBOL: plain
 SYMBOL: bold
 SYMBOL: italic
 SYMBOL: bold-italic
+
+SYMBOL: presented

library/syntax/prettyprint.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: prettyprint
-USING: alien errors generic hashtables kernel lists math
+USING: alien errors generic hashtables io kernel lists math
-matrices memory namespaces parser presentation sequences io
+matrices memory namespaces parser presentation sequences strings
-strings unparser vectors words ;
+styles unparser vectors words ;
 
 SYMBOL: prettyprint-limit
 SYMBOL: one-line
@@ -15,43 +15,17 @@ GENERIC: prettyprint* ( indent obj -- indent )
 M: object prettyprint* ( indent obj -- indent )
     unparse write ;
 
-: word-link ( word -- link )
+: word-attrs ( word -- style )
-    [
-        dup word-name unparse ,
-        " [ " ,
-        word-vocabulary unparse ,
-        " ] search" ,
-    ] make-string ;
-
-: word-actions ( -- list )
-    [
-        [[ "See"        "see"          ]]
-        [[ "Push"       ""             ]]
-        [[ "Execute"    "execute"      ]]
-        [[ "jEdit"      "jedit"        ]]
-        [[ "Usages"     "usages ."     ]]
-        [[ "Implements" "implements ." ]]
-    ] ;
-
-: browser-attrs ( word -- style )
     #! Return the style values for the HTML word browser
-    dup word-vocabulary [ 
+    [
-        swap word-name "word" swons 
+        presented over cons ,
-        swap "vocab" swons 
+        dup word-vocabulary [ 
-        2list
+            "word" over word-name cons ,
-    ] [
+            "vocab" swap word-vocabulary cons ,
-        drop [ ]  
+        ] [
-    ] ifte* ;
+            drop
-
+        ] ifte
-: word-attrs ( word -- attrs )
+    ] make-list ;
-    #! Words without a vocabulary do not get a link or an action
-    #! popup.
-    dup word-vocabulary [
-         dup word-link word-actions <actions> "actions" swons unit
-         swap browser-attrs append
-    ] [
-        drop [ ]
-    ] ifte ;
 
 : word. ( word -- ) dup word-name swap word-attrs write-attr ;
 

library/tools/inspector.factor

@@ -29,13 +29,6 @@ M: hashtable sheet hash>alist unzip 2list ;
     [ [ length ] map 0 [ max ] reduce ] keep
     [ swap CHAR: \s pad-right ] map-with ;
 
-: describe ( obj -- list )
-    sheet dup first length count swons
-    dup peek over first zip [ uncons set ] each
-    [ column ] map
-    seq-transpose
-    [ " " join ] map ;
-
 : (join) ( list glue -- )
     over [
         over car % >r cdr dup
@@ -48,6 +41,13 @@ M: hashtable sheet hash>alist unzip 2list ;
     #! The new sequence is of the same type as glue.
     [ [ (join) ] make-vector ] keep like ;
 
+: describe ( obj -- list )
+    sheet dup first length count swons
+    dup peek over first zip [ uncons set ] each
+    [ column ] map
+    seq-transpose
+    [ " | " join ] map ;
+
 : a/an ( noun -- str )
     first "aeiouAEIOU" contains? "an " "a " ? ;
 
@@ -82,6 +82,8 @@ M: hashtable sheet hash>alist unzip 2list ;
         "The word is a uniquely generated symbol." print
     ] ifte ;
 
+GENERIC: extra-banner ( obj -- )
+
 M: word extra-banner ( obj -- )
     dup vocab-banner swap class-banner ;
 
@@ -92,14 +94,16 @@ M: object extra-banner ( obj -- ) drop ;
     "You are looking at " write dup class unparse a/an.
     " object with the following printed representation:" print
     "  " write dup unparse print
+    "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
     " bytes of memory." print
     "This object is referenced from " write r> unparse write
     " other objects in the heap." print
-    extra-banner ;
+    extra-banner
+    "The object's slots, if any, are stored in integer variables," print
+    "numbered starting from 0." print ;
 
 : inspect ( obj -- )
-    dup inspect-banner
     dup inspecting set
-    describe [ print ] each ;
+    dup inspect-banner describe [ print ] each ;

library/tools/jedit-wire.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: jedit
 USING: generic kernel listener lists namespaces parser
-prettyprint sequences io strings words ;
+prettyprint sequences io strings words styles ;
 
 ! Wire protocol for jEdit to evaluate Factor code.
 ! Packets are of the form:
@@ -39,7 +39,7 @@ prettyprint sequences io strings words ;
 ! remaining -- input
 : jedit-write-attr ( str style -- )
     CHAR: w write
-    [ swap . "USE: styles" print . ] string-out
+    [ swap . "USE: styles" print [ car presented = not ] subset . ] string-out
     dup write-len write ;
 
 TUPLE: jedit-stream ;

library/ui/frames.factor

@@ -45,6 +45,11 @@ C: frame ( -- frame )
 : add-h pref-size nip height [ + ] change ;
 : add-w pref-size drop width [ + ] change ;
 
+: with-pref-size ( quot -- )
+    [
+        0 width set 0 height set call width get height get
+    ] with-scope ; inline
+
 M: frame pref-dim ( glue -- dim )
     [
         dup frame-major [ max-w ] each

library/ui/layouts.factor

@@ -19,6 +19,8 @@ namespaces sdl sequences ;
         drop
     ] ifte ;
 
+TUPLE: pack align fill vector ;
+
 : pref-dims ( gadget -- list )
     gadget-children [ pref-dim ] map ;
 
@@ -57,8 +59,6 @@ namespaces sdl sequences ;
 : packed-layout ( gadget sizes -- )
     2dup packed-locs packed-dims ;
 
-TUPLE: pack align fill vector ;
-
 C: pack ( align fill vector -- pack )
     #! align: 0 left aligns, 1/2 center, 1 right.
     #! gap: between each child.

library/ui/menus.factor

@@ -36,7 +36,7 @@ TUPLE: menu ;
 C: menu ( assoc -- gadget )
     #! Given an association list mapping labels to quotations.
     [ f line-border swap set-delegate ] keep
-    <line-pile> [ swap add-gadget ] 2keep
+    0 1 <pile> [ swap add-gadget ] 2keep
     rot assoc>menu dup menu-actions ;
 
 ! While a menu is open, clicking anywhere sends the click to

library/ui/panes.factor

@@ -29,9 +29,11 @@ TUPLE: pane output active current input continuation ;
 : pop-continuation ( pane -- quot )
     dup pane-continuation f rot set-pane-continuation ;
 
-: pane-eval ( line pane -- )
+: pane-eval ( string pane -- )
-    2dup stream-write "\n" over stream-write
+    2dup stream-print pop-continuation in-thread drop ;
-    pop-continuation in-thread drop ;
+
+: pane-call ( quot pane -- )
+    [ "(Structured input) " write dup . call ] with-stream* ;
 
 : pane-return ( pane -- )
     [
@@ -49,7 +51,7 @@ TUPLE: pane output active current input continuation ;
 
 C: pane ( -- pane )
     <line-pile> over set-delegate
-    <line-pile> <incremental> over add-output
+    <line-pile> ( <incremental> ) over add-output
     <line-shelf> over set-pane-current
     "" <editor> over set-pane-input
     dup init-active-line
@@ -60,10 +62,10 @@ M: pane focusable-child* ( pane -- editor )
     pane-input ;
 
 : pane-write-1 ( style text pane -- )
-    [ <presentation> ] keep pane-current add-incremental ;
+    [ <presentation> ] keep pane-current add-gadget ;
 
 : pane-terpri ( pane -- )
-    dup pane-current over pane-output add-incremental
+    dup pane-current over pane-output ( add-incremental ) add-gadget
     <line-shelf> over set-pane-current init-active-line ;
 
 : pane-write ( style pane list -- )

library/ui/presentations.factor

@@ -1,23 +1,45 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: hashtables io kernel lists namespaces parser prettyprint
+USING: generic hashtables inspector io jedit kernel lists memory
-sequences ;
+namespaces parser prettyprint sequences styles vectors words ;
+
+SYMBOL: commands
+
+global [ 100 <vector> commands set ] bind
+
+: define-command ( class name quot -- )
+    3list commands get push ;
+
+: applicable ( object -- )
+    commands get >list
+    [ car "predicate" word-prop call ] subset-with ;
 
 DEFER: pane-eval
 
-: actions-menu ( pane actions -- menu )
+: command-menu ( pane -- menu )
-    [ uncons rot [ pane-eval ] cons cons cons ] map-with <menu> ;
+    presented get dup applicable [
+        3dup third [
+            [ swap literal, % ] make-list , , \ pane-call ,
+        ] make-list >r second r> cons
+    ] map 2nip ;
 
-: init-actions ( gadget pane -- )
+: init-commands ( gadget pane -- )
-    over "actions" paint-prop dup [
+    over presented paint-prop
-        actions-menu [ show-menu ] cons button-gestures
+    [ [ command-menu <menu> show-menu ] cons button-gestures ]
-    ] [
+    [ 2drop ] ifte ;
-        3drop
-    ] ifte ;
 
 : <styled-label> ( style text -- label )
     <label> swap alist>hash over set-gadget-paint ;
 
 : <presentation> ( style text pane -- presentation )
-    >r <styled-label> dup r> init-actions ;
+    >r <styled-label> dup r> init-commands ;
+
+object "Prettyprint" [ prettyprint ] define-command
+object "Inspect" [ inspect ] define-command
+object "References" [ references inspect ] define-command
+
+\ word "See" [ see ] define-command
+\ word "Execute" [ execute ] define-command
+\ word "Usage" [ usage . ] define-command
+\ word "jEdit" [ jedit ] define-command

library/ui/splitters.factor

@@ -17,7 +17,7 @@ TUPLE: splitter split ;
 
 : divider-motion ( splitter -- )
     dup hand>split
-    over shape-dim { 1 1 1 } vmax v/ over orientation v.
+    over shape-dim { 1 1 1 } vmax v/ over pack-vector v.
     0 max 1 min over set-splitter-split relayout ;
 
 : divider-actions ( thumb -- )