Presentation cleanup

TODO.FACTOR.txt

@@ -4,7 +4,6 @@
 
 + ui:
 
-- command presentation shouldn't really be a presentation at all
 - completion is not ideal: eg, search for "buttons"
 - live search: timer delay would be nice
 - some way of intercepting all gestures

doc/handbook/ui/tools.facts

@@ -12,7 +12,7 @@ $terpri
 $terpri
 "Clicking and holding the right mouse button on a presentation displays a popup menu listing available operations."
 $terpri
-"Presentation gadgets can be constructed directly using the " { $link <object-presentation> } " word, and they can also be written to " { $link pane } " gadgets using the " { $link write-object } " word." ;
+"Presentation gadgets can be constructed directly using the " { $link <presentation> } " word, and they can also be written to " { $link pane } " gadgets using the " { $link write-object } " word." ;
 
 ARTICLE: "ui-listener" "UI listener"
 "The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds the following features:"

library/ui/gadgets/presentations.factor

@@ -11,36 +11,10 @@ generic hashtables tools io kernel prettyprint sequences strings
 styles words help math models namespaces ;
 
 ! Clickable objects
-TUPLE: presentation object command ;
-
-C: presentation ( button object command -- button )
-    [ set-presentation-command ] keep
-    [ set-presentation-object ] keep
-    [ set-gadget-delegate ] keep ;
-
-: <object-presentation> ( gadget object -- button )
-    >r f <roll-button> r> f <presentation> ;
-
-: <command-presentation> ( target command -- button )
-    dup command-name f <bevel-button> -rot <presentation> ;
-
-: <commands-menu> ( target commands -- gadget )
-    [ hand-clicked get find-world hide-glass ] modify-operations
-    [ <command-presentation> ] map-with
-    make-pile 1 over set-pack-fill ;
-
-: operations-menu ( presentation -- gadget )
-    dup presentation-command [
-        drop
-    ] [
-        dup presentation-object
-        dup object-operations <commands-menu>
-        swap show-menu
-    ] if ;
+TUPLE: presentation object ;
 
 : invoke-presentation ( presentation -- )
-    dup presentation-object swap presentation-command
-    [ dup default-operation ] unless*
+    dup presentation-object dup default-operation
     invoke-command ;
 
 : show-mouse-help ( presentation -- )
@@ -52,17 +26,37 @@ C: presentation ( button object command -- button )
 M: presentation ungraft* ( presentation -- )
     dup hide-mouse-help delegate ungraft* ;
 
+C: presentation ( gadget object -- button )
+    [ set-presentation-object ] keep
+    swap [ invoke-presentation ] <roll-button>
+    over set-gadget-delegate ;
+
+: <command-button> ( target command -- button )
+    dup command-name -rot
+    [ invoke-command drop ] curry curry
+    <bevel-button> ;
+
+: <commands-menu> ( target commands -- gadget )
+    [ hand-clicked get find-world hide-glass ] modify-operations
+    [ <command-button> ] map-with
+    make-pile 1 over set-pack-fill ;
+
+: operations-menu ( presentation -- gadget )
+    dup presentation-object
+    dup object-operations <commands-menu>
+    swap show-menu ;
+
 presentation H{
-    { T{ button-up } [ [ invoke-presentation ] if-clicked ] }
-    { T{ button-down f f 3 } [ [ operations-menu ] if-clicked ] }
+    { T{ button-down f f 3 } [ operations-menu ] }
     { T{ mouse-leave } [ dup hide-mouse-help button-update ] }
     { T{ motion } [ dup show-mouse-help button-update ] }
 } set-gestures
 
 ! Presentation help bar
 : <presentation-help> ( model -- gadget )
-    [ [ presentation-object summary ] [ "" ] if* ] <filter>
-    <label-control> dup reverse-video-theme ;
+    [
+        [ presentation-object summary ] [ "" ] if*
+    ] <filter> <label-control> dup reverse-video-theme ;
 
 : <listener-button> ( gadget quot -- button )
     [ call-listener ] curry <roll-button> ;
@@ -87,7 +81,7 @@ presentation H{
     over specified-font over set-label-font ;
 
 : apply-presentation-style ( style gadget -- style gadget )
-    presented [ <object-presentation> ] apply-style ;
+    presented [ <presentation> ] apply-style ;
 
 : apply-quotation-style ( style gadget -- style gadget )
     quotation [ <listener-button> ] apply-style ;

library/ui/gestures.factor

@@ -152,8 +152,6 @@ SYMBOL: scroll-direction
     hand-gadget get-global hand-clicked set-global
     hand-loc get-global hand-click-loc set-global ;
 
-SYMBOL: menu-mode?
-
 : move-hand ( loc world -- )
     dup hand-world set-global
     under-hand >r over hand-loc set-global

library/ui/load.factor

@@ -49,6 +49,7 @@ PROVIDE: library/ui {
     "tools/operations.factor"
     "text/editor.facts"
 } {
+    "test/editor.factor"
     "test/gadgets.factor"
     "test/models.factor"
     "test/document.factor"
@@ -57,7 +58,7 @@ PROVIDE: library/ui {
     "test/rectangles.factor"
     "test/commands.factor"
     "test/panes.factor"
-    "test/editor.factor"
+    "test/presentations.factor"
     "test/search.factor"
     "test/sliders.factor"
     "test/tracks.factor"

library/ui/test/presentations.factor

@@ -0,0 +1,15 @@
+IN: temporary
+USING: math gadgets-presentations gadgets generic test
+prettyprint gadgets-buttons io kernel ;
+
+[ t ] [
+    "Hi" \ + <presentation> [ gadget? ] is?
+] unit-test
+
+[ "+" ] [
+    [
+        \ +
+        "Test" f [ pprint ] <command> <command-button>
+        dup button-quot call
+    ] string-out
+] unit-test

library/ui/tools/dataflow.factor

@@ -106,12 +106,12 @@ M: #push node-presents >#push< first ;
     [ length ] keep
     [
         >r number>string "Child " swap append <label> r>
-        <object-presentation>
+        <presentation>
     ] 2map ;
 
 : <node-presentation> ( node -- gadget )
     class [ word-name <label> ] keep <link>
-    <object-presentation> ;
+    <presentation> ;
 
 : default-node-content ( node -- gadget )
     dup node-children <child-nodes>
@@ -167,7 +167,7 @@ DEFER: (compute-heights)
 ! Then we create gadgets for every node
 : node>gadget ( height node -- gadget )
     [ node>gadget* ] keep node-presents
-    [ <object-presentation> ] when* ;
+    [ <presentation> ] when* ;
 
 : print-node ( d-height node -- )
     dup full-height-node? [

library/ui/ui.factor

@@ -121,7 +121,7 @@ C: titled-gadget ( gadget title -- )
 
 : <toolbar> ( target classes -- toolbar )
     [ commands "toolbar" swap hash ] map concat
-    [ <command-presentation> ] map-with
+    [ <command-button> ] map-with
     make-shelf ;
 
 : command-description ( command -- element )

library/ui/world.factor

@@ -22,6 +22,8 @@ focus focused?
 fonts handle
 loc ;
 
+SYMBOL: menu-mode?
+
 : free-fonts ( world -- )
     dup world-handle select-gl-context
     world-fonts hash-values [ second free-sprites ] each ;