Operations

TODO.FACTOR.txt

@@ -5,13 +5,9 @@ new browser:
 - scroll to existing won't work
 - initial scroll dim is wrong
 - show callers
-
 listener:
 - show IN:
-
-- commands
 - list of key bindings
-
 - RT_WORD should refer to XTs not word objects.
 - services do not launch if factor not running
 - roundoff is still not quite right with tracks

library/ui/cocoa/services.factor

@@ -4,8 +4,8 @@ IN: objc-classes
 DEFER: FactorServiceProvider
 
 IN: cocoa
-USING: alien gadgets-presentations io kernel namespaces objc
-parser prettyprint styles ;
+USING: alien io kernel namespaces objc
+parser prettyprint styles gadgets-listener ;
 
 : pasteboard-error ( error -- f )
     "Pasteboard does not hold a string" <NSString>
@@ -27,7 +27,12 @@ parser prettyprint styles ;
     {
         "evalInListener:userData:error:" "void"
         { "id" "SEL" "id" "id" "void*" }
-        [ nip [ <input> show f ] do-service 2drop ]
+        [
+            nip
+            [ <input> listener-tool call-listener f ]
+            do-service
+            2drop
+        ]
     }
     {
         "evalToString:userData:error:" "void"

library/ui/commands.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets
-USING: kernel gadgets sequences strings math words generic
-namespaces hashtables ;
+USING: arrays kernel gadgets sequences strings math words
+generic namespaces hashtables jedit help ;
 
 TUPLE: command class group name gesture quot ;
 
@@ -29,9 +29,13 @@ M: object gesture>string drop f ;
         ] when*
     ] when* ;
 
-: invoke-command ( gadget command -- )
-    dup command-class rot [ class over eq? ] find-parent nip
-    swap command-quot call ;
+: command-target ( target command -- target )
+    command-class [
+        swap [ class over eq? ] find-parent nip
+    ] when* ;
+
+: invoke-command ( target command -- )
+    [ command-target ] keep command-quot call ;
 
 : define-commands ( class specs -- )
     [ dupd first4 <command> ] map
@@ -41,11 +45,7 @@ M: object gesture>string drop f ;
     "gestures" set-word-prop ;
 
 : commands ( gadget -- seq )
-    [
-        parents [
-            delegates [ class "commands" word-prop % ] each
-        ] each
-    ] V{ } make ;
+    delegates [ class "commands" word-prop ] map concat ;
 
 world {
     { f "Cut" T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
@@ -53,3 +53,20 @@ world {
     { f "Paste" T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
     { f "Select all" T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
 } define-commands
+
+SYMBOL: operations
+global [
+    operations get [ V{ } clone operations set ] unless*
+] bind
+
+: define-operation ( pred button# name quot -- )
+    >r >r f f r> f r> <command> 3array operations get push-new ;
+
+: object-operation ( obj button# -- command )
+    swap operations get
+    [ first call ] subset-with
+    [ second = ] subset-with
+    dup empty? [ drop f ] [ peek third ] if ;
+
+[ word? ] 2 "jEdit" [ jedit ] define-operation
+[ link? ] 2 "jEdit" [ jedit ] define-operation

library/ui/gadgets/presentations.factor

@@ -9,18 +9,23 @@ kernel prettyprint sequences strings styles words ;
 ! Clickable objects
 TUPLE: object-button object ;
 
-GENERIC: show ( object -- )
-
 C: object-button ( gadget object -- button )
     [ set-object-button-object ] keep
-    [
-        >r [ object-button-object show ] <roll-button>
-        r> set-gadget-delegate
-    ] keep ;
+    [ >r f <roll-button> r> set-gadget-delegate ] keep ;
 
 M: object-button gadget-help
     object-button-object dup word? [ synopsis ] [ summary ] if ;
 
+: invoke-object-button ( gadget button# -- )
+    >r object-button-object dup r> object-operation
+    [ invoke-command ] [ drop ] if* ;
+
+object-button H{
+    { T{ button-down f 1 } [ 1 invoke-object-button ] }
+    { T{ button-down f 2 } [ 2 invoke-object-button ] }
+    { T{ button-down f 3 } [ 3 invoke-object-button ] }
+} set-gestures
+
 ! Character styles
 
 : apply-style ( style gadget key quot -- style gadget )

library/ui/text/interactor.factor

@@ -67,7 +67,7 @@ SYMBOL: structured-input
 
 : word-action ( interactor word -- )
     over gadget-selection?
-    [ over T{ word-elt } editor-select-prev ] unless
+    [ over T{ word-elt } select-elt ] unless
     over gadget-selection add* swap interactor-call ;
 
 : usable-words ( -- seq )

library/ui/tools/browser.factor

@@ -3,7 +3,7 @@
 IN: gadgets-browser
 USING: arrays definitions gadgets gadgets-books gadgets-borders
 gadgets-buttons gadgets-frames gadgets-labels gadgets-panes
-gadgets-presentations gadgets-scrolling gadgets-search
+gadgets-scrolling gadgets-search
 gadgets-theme gadgets-tiles gadgets-tracks generic hashtables
 help inspector kernel math models namespaces prettyprint
 sequences styles words ;
@@ -157,6 +157,5 @@ M: browser gadget-title drop "Browser" <model> ;
 
 : browser-tool [ browser? ] [ <browser> ] [ browse ] ;
 
-M: word show browser-tool call-tool ;
-
-M: vocab-link show browser-tool call-tool ;
+[ word? ] 1 "Browse" [ browser-tool call-tool ] define-operation
+[ vocab-link? ] 1 "Browse" [ browser-tool call-tool ] define-operation

library/ui/tools/help.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-help
 USING: gadgets gadgets-borders gadgets-buttons gadgets-frames
-gadgets-panes gadgets-presentations gadgets-search
+gadgets-panes gadgets-search
 gadgets-scrolling help kernel models namespaces sequences ;
 
 TUPLE: help-gadget history ;
@@ -36,4 +36,4 @@ M: help-gadget pref-dim* drop { 500 600 } ;
 
 : help-tool [ help-gadget? ] [ <help-gadget> ] [ show-help ] ;
 
-M: link show help-tool call-tool ;
+[ link? ] 1 "Browse" [ help-tool call-tool ] define-operation

library/ui/tools/launchpad.factor

@@ -1,19 +1,19 @@
 ! Copyright (C) 2006 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets
-USING: gadgets-presentations memory io gadgets-panes
+USING: memory io gadgets-panes
 gadgets-scrolling namespaces help kernel gadgets-listener
-gadgets-browser gadgets-search ;
+gadgets-browser gadgets-search gadgets-help inspector ;
 
 : handbook-window ( -- )
-    T{ link f "handbook" } show ;
+    T{ link f "handbook" } help-tool call-tool ;
 
 : memory-window ( -- )
     [ heap-stats. terpri room. ] make-pane <scroller>
     "Memory" open-titled-window ;
 
 : globals-window ( -- )
-    global show ;
+    [ global inspect ] listener-tool call-tool ;
 
 ! world {
 !     { f "Listener" f [ drop listener-window ] }

library/ui/tools/listener.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-listener
 USING: arrays gadgets gadgets-frames gadgets-labels
-gadgets-panes gadgets-presentations gadgets-scrolling
+gadgets-panes gadgets-scrolling
 gadgets-text gadgets-theme gadgets-tiles gadgets-tracks generic
 hashtables inspector io jedit kernel listener math models
 namespaces parser prettyprint sequences shells styles threads
@@ -81,8 +81,6 @@ M: listener-gadget gadget-title drop "Listener" <model> ;
         [ [ run-file ] each ] curry listener-tool call-tool
     ] if ;
 
-M: input show
-    input-string listener-tool call-tool ;
-
-M: object show
-    [ inspect ] curry listener-tool call-tool ;
+[ drop t ] 1 "Inspect" [ [ inspect ] curry listener-tool call-tool ] define-operation
+[ drop t ] 3 "Inspect" [ [ inspect ] curry listener-tool call-tool ] define-operation
+[ input? ] 1 "Replace input" [ input-string listener-tool call-tool ] define-operation

library/ui/ui.factor

@@ -139,7 +139,8 @@ C: titled-gadget ( gadget title -- )
     windows get [ empty? not ] [ f ] if* ;
 
 : <toolbar> ( gadget -- toolbar )
-    commands [ <command-button> ] map make-shelf ;
+    commands [ <command-button> ] map make-shelf
+    dup highlight-theme ;
 
 : error-window ( error -- )
     [ print-error ] make-pane "Error" open-titled-window ;