Commands/operations cleanup

TODO.FACTOR.txt

@@ -14,8 +14,6 @@
 - signal 4 on datastack underflow on mac intel??
 - new section in cookbook: philosophy
 - help gadget should not re-render every time it is grafted
-- clean up interactor and listener commands -- there is a lot of
-  duplication
 - keyboard help persists after clicking on a link
 - apropos and help search
 
@@ -49,12 +47,6 @@
 - fonts/ should go inside the .app -- we need multi-tier resource-path
 - should be possible to drop an image file on the .app to run it
 - add-gadget, model-changed, set-model should compile
-- shortcuts:
-  - find a listener
-  - find a browser
-  - find a help window
-  - they'll either focus such a window, or if the current window is of
-    that type, cycle
 - support x11's large selections, if needed
 - own-selection violates ICCCM
 - cocoa: windows are not updated while resizing

library/collections/arrays.factor

@@ -30,3 +30,9 @@ M: byte-array resize resize-array ;
     3 swap <array>
     [ 1 swap set-array-nth ] keep
     [ 0 swap set-array-nth ] keep ;
+
+: 4array ( x y z t -- array )
+    4 swap <array>
+    [ 2 swap set-array-nth ] keep
+    [ 1 swap set-array-nth ] keep
+    [ 0 swap set-array-nth ] keep ;

library/ui/commands.factor

@@ -71,9 +71,6 @@ world H{
 
 SYMBOL: operations
 
-: define-operation ( pred button# name quot -- )
-    >r >r f r> f r> <command> 3array operations get push-new ;
-
 : object-operation ( obj button# -- command )
     swap operations get
     [ >r class r> first class< ] subset-with
@@ -82,3 +79,6 @@ SYMBOL: operations
 
 : object-operations ( object -- seq )
     3 [ 1+ object-operation ] map-with ;
+
+: <operation> ( name quot -- command )
+    >r >r f r> f r> <command> ;

library/ui/text/interactor.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-text
-USING: definitions gadgets gadgets-controls gadgets-panes
+USING: arrays definitions gadgets gadgets-controls gadgets-panes
 generic hashtables help io kernel namespaces prettyprint styles
 threads sequences vectors definitions parser words ;
 
@@ -60,33 +60,48 @@ SYMBOL: structured-input
         swap interactor-eval
     ] if ;
 
-: interactor-history. ( interactor -- )
+: interactor-history. ( -- )
-    dup interactor-output [
+    stdio get dup duplex-stream-out [
-        interactor-history [ dup print-input ] each
+        duplex-stream-in interactor-history
+        [ dup print-input ] each
     ] with-stream* ;
 
-: word-action ( interactor word -- )
+: token-action ( interactor quot -- )
     over gadget-selection?
     [ over T{ word-elt } select-elt ] unless
     over gadget-selection add* swap interactor-call ;
 
+: word-action ( interactor quot -- )
+    search token-action ;
+
 : usable-words ( -- seq )
     use get [ hash-values natural-sort ] map concat prune ;
 
-interactor {
+interactor [
-    { f "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] }
+    { f "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] } ,
-    { f "History" T{ key-down f { C+ } "h" } [ dup [ interactor-history. ] curry swap interactor-call ] }
+    { f "History" T{ key-down f { C+ } "h" } [ [ interactor-history. ] swap interactor-call ] } ,
-    { f "Send EOF" T{ key-down f { C+ } "d" } [ f swap interactor-eval ] }
+    { f "Send EOF" T{ key-down f { C+ } "d" } [ f swap interactor-eval ] } ,
-    { f "Stack effect" T{ key-down f { C+ A+ } "i" } [ "infer ." quot-action ] }
+
-    { f "Single step" T{ key-down f { C+ A+ } "w" } [ "walk" quot-action ] }
+    {
-    { f "See" T{ key-down f { A+ } "s" } [ [ search see ] word-action ] }
+        { f "Stack effect" T{ key-down f { C+ A+ } "i" } "infer ." }
-    { f "Help" T{ key-down f { A+ } "h" } [ [ search help ] word-action ] }
+        { f "Single step" T{ key-down f { C+ A+ } "w" } "walk" }
-    { f "Callers" T{ key-down f { A+ } "u" } [ [ search usage. ] word-action ] }
+        { f "Single step" T{ key-down f { C+ A+ } "t" } "time" }
-    { f "Edit" T{ key-down f { A+ } "e" } [ [ search edit ] word-action ] }
+    } [ first4 [ quot-action ] curry 4array ] map %
-    { f "Reload" T{ key-down f { A+ } "r" } [ [ search reload ] word-action ] }
+
-    { f "Apropos (all)" T{ key-down f { A+ } "a" } [ [ apropos ] word-action ] }
+    {
-    { f "Apropos (used)" T{ key-down f f "TAB" } [ [ usable-words (apropos) ] word-action ] }
+        { f "See" T{ key-down f { A+ } "s" } [ see ] }
-} define-commands
+        { f "Help" T{ key-down f { A+ } "h" } [ help ] }
+        { f "Callers" T{ key-down f { A+ } "u" } [ usage. ] }
+        { f "Edit" T{ key-down f { A+ } "e" } [ edit ] }
+        { f "Reload" T{ key-down f { A+ } "r" } [ reload ] }
+        { f "Reload" T{ key-down f { A+ } "w" } [ watch ] }
+    } [ first4 [ word-action ] curry 4array ] map %
+
+    {
+        { f "Apropos (all)" T{ key-down f { A+ } "a" } [ apropos ] }
+        { f "Apropos (used)" T{ key-down f f "TAB" } [ usable-words (apropos) ] }
+    } [ first4 [ token-action ] curry 4array ] map %
+] { } make define-commands
 
 M: interactor stream-readln
     dup interactor-queue empty? [

library/ui/tools/listener.factor

@@ -2,11 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-listener
 USING: arrays gadgets gadgets-frames gadgets-labels
-gadgets-panes gadgets-scrolling
+gadgets-panes gadgets-scrolling gadgets-text gadgets-theme
-gadgets-text gadgets-theme gadgets-tiles gadgets-tracks generic
+gadgets-tiles gadgets-tracks generic hashtables inspector io
-hashtables inspector io kernel listener math models
+kernel listener math models namespaces parser prettyprint
-namespaces parser prettyprint sequences shells styles threads
+sequences shells styles threads words memory ;
-words memory ;
 
 TUPLE: listener-gadget input output stack ;
 
@@ -60,5 +59,5 @@ M: listener-gadget gadget-title drop "Listener" <model> ;
         drop f
     ] if ;
 
-: clear-listener ( listener -- )
+: clear-listener ( -- )
-    listener-gadget-output pane-clear ;
+    stdio get duplex-stream-out pane-clear ;

library/ui/tools/workspace.factor

@@ -82,12 +82,17 @@ workspace {
     { f "Walker" T{ key-down f f "F3" } [ walker-gadget select-tool ] }
     { f "Dictionary" T{ key-down f f "F4" } [ browser select-tool ] }
     { f "Documentation" T{ key-down f f "F5" } [ help-gadget select-tool ] }
+    { f "New workspace" T{ key-down f { C+ } "n" } [ workspace-window drop ] }
 } define-commands
 
 V{ } clone operations set-global
 
-\ word 2 "Edit" [ edit ] define-operation
+: define-operation ( pred button# name tool quot -- )
-link 2 "Edit" [ edit ] define-operation
+    [ % , \ call-tool , ] [ ] make <operation> 3array
+    operations get push-new ;
+
+\ word 2 "Edit" [ [ edit ] curry ] listener-gadget define-operation
+link 2 "Edit" [ [ edit ] curry ] listener-gadget define-operation
 
 ! Listener tool
 M: listener-gadget call-tool* ( quot/string listener -- )
@@ -102,14 +107,16 @@ M: listener-gadget call-tool* ( quot/string listener -- )
     ] if ;
 
 listener-gadget {
-    { f "Clear" T{ key-down f f "CLEAR" } [ dup [ clear-listener ] curry listener-gadget call-tool ] }
+    { f "Clear" T{ key-down f f "CLEAR" } [ clear-listener ] }
-    { f "Globals" f [ [ global inspect ] listener-gadget call-tool ] }
+    { f "Globals" f [ global inspect ] }
-    { f "Memory" f [ [ heap-stats. room. ] listener-gadget call-tool ] }
+    { f "Memory" f [ heap-stats. room. ] }
-} define-commands
+}
+[ first4 [ listener-gadget call-tool ] curry 4array ] map
+define-commands
 
-object 1 "Inspect" [ [ inspect ] curry listener-gadget call-tool ] define-operation
+object 1 "Inspect" [ [ inspect ] curry ] listener-gadget define-operation
-object 3 "Inspect" [ [ inspect ] curry listener-gadget call-tool ] define-operation
+object 3 "Inspect" [ [ inspect ] curry ] listener-gadget define-operation
-input 1 "Input" [ input-string listener-gadget call-tool ] define-operation
+input 1 "Input" [ input-string ] listener-gadget define-operation
 
 ! Browser tool
 M: browser call-tool*
@@ -119,13 +126,13 @@ M: browser call-tool*
         show-word
     ] if ;
 
-\ word 1 "Browse" [ browser call-tool ] define-operation
+\ word 1 "Browse" [ ] browser define-operation
-vocab-link 1 "Browse" [ browser call-tool ] define-operation
+vocab-link 1 "Browse" [ ] browser define-operation
 
 ! Help tool
 M: help-gadget call-tool* show-help ;
 
-link 1 "Follow link" [ help-gadget call-tool ] define-operation
+link 1 "Follow link" [ ] help-gadget define-operation
 
 ! Walker tool
 M: walker-gadget call-tool* ( arg tool -- )