Operation tweaks

core/ui/commands.factor

@@ -63,7 +63,7 @@ SYMBOL: +keyboard+
 SYMBOL: +primary+
 SYMBOL: +secondary+
 
-TUPLE: operation predicate primary? secondary? ;
+TUPLE: operation predicate primary? secondary? listener? hook ;
 
 : (command) ( -- command )
     +name+ get +keyboard+ get +quot+ get <command> ;
@@ -83,14 +83,6 @@ SYMBOL: operations
 : secondary-operation ( obj -- command )
     object-operations [ operation-secondary? ] find-last nip ;
 
-: modify-command ( quot operation -- operation )
-    clone
-    [ command-quot append ] keep
-    [ set-command-quot ] keep ;
-
-: modify-commands ( operations quot -- operations )
-    swap [ modify-command ] map-with ;
-
 : command-description ( command -- element )
     dup command-name swap command-gesture gesture>string
     2array ;

core/ui/debugger.factor

@@ -19,8 +19,7 @@ queues sequences test threads help sequences words timers ;
 TUPLE: debugger restarts ;
 
 : <debugger-display> ( error restart-list -- gadget )
-    >r [ print-error ] make-pane r> 2array make-pile
-    1 over set-pack-fill ;
+    >r [ print-error ] make-pane r> 2array make-filled-pile ;
 
 C: debugger ( error restart-hook -- gadget )
     {

core/ui/gadgets/presentations.factor

@@ -52,26 +52,21 @@ C: presentation ( gadget object -- button )
     [ <command-button> ] map-with
     make-shelf ;
 
-: <menu-command> ( command -- command )
-    [ hand-clicked get find-world hide-glass ]
-    swap modify-command ;
+: <menu-item> ( hook target command -- button )
+    rot >r
+    (command-button) [ hand-clicked get find-world hide-glass ]
+    r> append3 <roll-button> ;
 
-: <menu-item> ( target command -- button )
-    <menu-command> (command-button) <roll-button> ;
-
-: <commands-menu> ( target commands -- gadget )
-    [ <menu-item> ] map-with
-    make-pile 1 over set-pack-fill
+: <commands-menu> ( hook target commands -- gadget )
+    [ >r 2dup r> <menu-item> ] map 2nip make-filled-pile
     <default-border>
     dup menu-theme ;
 
-: hooked-operations ( hook obj -- seq )
-    object-operations swap modify-commands ;
-
 : operations-menu ( presentation -- )
-    dup dup presentation-hook curry
-    over presentation-object hooked-operations
-    over presentation-object swap <commands-menu>
+    dup
+    dup presentation-hook curry
+    over presentation-object
+    dup object-operations <commands-menu>
     swap show-menu ;
 
 presentation H{

core/ui/hierarchy.factor

@@ -111,4 +111,7 @@ M: gadget focusable-child* drop t ;
 
 : make-pile ( children -- pack ) <pile> [ add-gadgets ] keep ;
 
+: make-filled-pile ( children -- pack )
+    make-pile 1 over set-pack-fill ;
+
 : make-shelf ( children -- pack ) <shelf> [ add-gadgets ] keep ;

core/ui/test/listener.factor

@@ -7,8 +7,6 @@ timers [ init-timers ] unless
 [
     <listener-gadget> "listener" set
     
-    "kernel" vocab 1array "listener" get set-listener-gadget-use
-    
     [ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
     
     [ "USE: words word-name" ]

core/ui/tools/dataflow.factor

@@ -172,7 +172,7 @@ DEFER: (compute-heights)
     ] [
         [ node-in-d length - <height-gadget> ] 2keep
         node>gadget swap 2array
-        make-pile 1 over set-pack-fill
+        make-filled-pile
     ] if , ;
 
 : <dataflow-graph> ( node -- gadget )

core/ui/tools/listener.factor

@@ -8,10 +8,9 @@ generic hashtables tools io kernel listener math models
 namespaces parser prettyprint sequences shells strings styles
 threads words definitions help errors ;
 
-TUPLE: listener-gadget input output stack use ;
+TUPLE: listener-gadget input output stack ;
 
 : ui-listener-hook ( listener -- )
-    use get over set-listener-gadget-use
     >r datastack r> listener-gadget-stack set-model ;
 
 : ui-error-hook ( error listener -- )

core/ui/tools/operations.factor

@@ -9,22 +9,38 @@ test tools words generic models io modules errors ;
 
 V{ } clone operations set-global
 
-: handle-listener-operation
-    +listener+ get [
-        +quot+ [ [ curry call-listener ] curry ] change
-    ] when ;
-
 C: operation ( predicate hash -- operation )
-    swap clone [
-        handle-listener-operation
+    swap [
         (command) over set-delegate
         +primary+ get over set-operation-primary?
         +secondary+ get over set-operation-secondary?
+        +listener+ get over set-operation-listener?
     ] bind
     [ set-operation-predicate ] keep ;
 
+M: operation invoke-command
+    [ operation-hook call ] keep
+    dup command-quot swap operation-listener?
+    [ curry call-listener ] [ call ] if ;
+
 : define-operation ( class props -- )
-    <operation> operations get push-new ;
+    <operation> operations get push ;
+
+: listener-operation ( hook quot operation -- operation )
+    modify-command
+    tuck set-operation-hook
+    t over set-operation-listener? ;
+
+: listener-operations ( operations hook quot -- operations )
+    rot [ >r 2dup r> listener-operation ] map 2nip ;
+
+: modify-command ( quot command -- command )
+    clone
+    [ command-quot append ] keep
+    [ set-command-quot ] keep ;
+
+: modify-commands ( commands quot -- commands )
+    swap [ modify-command ] map-with ;
 
 ! Objects
 [ drop t ] H{
@@ -88,7 +104,7 @@ C: operation ( predicate hash -- operation )
 
 : word-completion-string ( word listener -- string )
     >r dup word-name swap word-vocabulary dup vocab r>
-    listener-gadget-use memq?
+    listener-gadget-input interactor-use memq?
     [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
 
 : insert-word ( word -- )
@@ -305,20 +321,17 @@ C: operation ( predicate hash -- operation )
 ! Define commands in terms of operations
 
 ! Interactor commands
-: word-action ( target -- quot )
-    selected-word search ;
-
 : quot-action ( interactor -- quot )
-    dup editor-text swap select-all parse ;
+    dup editor-text swap select-all ;
 
 interactor "words"
 { word compound } [ class-operations ] map concat
-[ word-action ] modify-commands
+[ selected-word ] [ search ] listener-operations
 define-commands
 
 interactor "quotations"
 quotation class-operations
-[ quot-action ] modify-commands
+[ quot-action ] [ parse ] listener-operations
 define-commands
 
 help-gadget "toolbar" {