Command framework

TODO.FACTOR.txt

@@ -1,5 +1,17 @@
 + 0.84:
 
+new browser:
+- show currently selected vocab & words
+- 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
@@ -34,6 +46,7 @@
 
 + ui:
 
+- closing walker should continue; clicking continue should close walker
 - continuation handling in walker is screwy
 - graphical module manager tool
 - figure out what goes in the .app and what doesn't
@@ -75,7 +88,6 @@
   - TYPEDEF: float FTFloat ;  ==> \ float \ FTFloat "c-type" swp
   - make typedef aliasing explicit
 - seeing a C struct word should show its def
-- TUPLE: module files tests articles article main ;
 - file out
 
 + compiler/ffi:
@@ -105,6 +117,7 @@
 
 + misc:
 
+- move jedit word to contrib
 - growable data heap
 - incremental GC
 - UDP

library/bootstrap/boot-stage1.factor

@@ -188,6 +188,7 @@ sequences vectors words ;
         "/library/ui/world.factor"
         "/library/ui/paint.factor"
         "/library/ui/gestures.factor"
+        "/library/ui/commands.factor"
         "/library/ui/gadgets/controls.factor"
         "/library/ui/gadgets/grid-lines.factor"
         "/library/ui/gadgets/theme.factor"

library/test/gadgets/commands.factor

@@ -0,0 +1,8 @@
+IN: temporary
+USING: gadgets test ;
+
+[ "A+a" ] [ T{ key-down f { A+ } "a" } gesture>string ] unit-test
+[ "b" ] [ T{ key-down f f "b" } gesture>string ] unit-test
+[ "Mouse Down 2" ] [ T{ button-down f 2 } gesture>string ] unit-test
+[ "Test (Mouse Down 2)" ]
+[ T{ command f f "Test" T{ button-down f 2 } [ ] } command-string ] unit-test

library/test/test.factor

@@ -86,6 +86,7 @@ SYMBOL: failures
         "gadgets/document"
         "gadgets/rectangles"
         "gadgets/fields"
+        "gadgets/commands"
         "generic"
         "help/porter-stemmer"
         "help/topics"

library/ui/commands.factor

@@ -0,0 +1,56 @@
+! 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 ;
+
+TUPLE: command class group name gesture quot ;
+
+GENERIC: gesture>string ( gesture -- string )
+
+M: key-down gesture>string
+    dup key-down-mods [ word-name ] map concat >string
+    swap key-down-sym append ;
+
+M: button-up gesture>string
+    "Mouse Up" swap button-up-#
+    [ " " swap number>string append3 ] when* ;
+
+M: button-down gesture>string
+    "Mouse Down" swap button-down-#
+    [ " " swap number>string append3 ] when* ;
+
+M: object gesture>string drop f ;
+
+: command-string ( command -- string )
+    dup command-name swap command-gesture [
+        gesture>string [
+            [ swap % " (" % % ")" % ] "" make
+        ] when*
+    ] when* ;
+
+: invoke-command ( gadget command -- )
+    dup command-class rot [ class over eq? ] find-parent nip
+    swap command-quot call ;
+
+: add-command ( class command -- )
+    over "commands" word-prop
+    [ command-name over command-name = not ] subset
+    swap add "commands" set-word-prop ;
+
+: define-commands ( class specs -- )
+    [ dupd first4 <command> ] map
+    2dup [ add-command ] each-with
+    [ command-gesture ] subset
+    [ dup command-gesture swap command-quot ] map>hash
+    "gestures" set-word-prop ;
+
+: commands ( gadget -- seq )
+    delegates [ class "commands" word-prop ] map concat ;
+
+world {
+    { f "Cut" T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
+    { f "Copy" T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
+    { 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

library/ui/gadgets/buttons.factor

@@ -52,6 +52,11 @@ C: button ( gadget quot -- button )
 : <bevel-button> ( gadget quot -- button )
     <button> dup bevel-button-theme ;
 
+: <command-button> ( command -- button )
+    dup command-string
+    swap [ invoke-command ] curry
+    <bevel-button> ;
+
 : repeat-button-down ( button -- )
     dup 100 add-timer button-clicked ;
 

library/ui/gestures.factor

@@ -187,10 +187,3 @@ V{ } clone hand-buttons set-global
 
 : send-action ( world gesture -- )
     swap world-focus handle-gesture drop ;
-
-world H{
-    { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
-    { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
-    { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
-    { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
-} set-gestures

library/ui/tools/browser.factor

@@ -137,17 +137,10 @@ C: browser-tracks ( browser -- browser-track )
     browser-tabs dup length [ swap first 2array ] 2map
     <radio-box> ;
 
-: <browser-toolbar> ( browser -- toolbar )
-    [
-        <browser-tabs> ,
-        <spacing> ,
-        "Apropos" [ drop apropos-window ] <bevel-button> ,
-    ] make-toolbar ;
-
 C: browser ( -- browser )
     0 <model> over set-browser-page
     dup dup {
-        { [ <browser-toolbar> ] f f @top }
+        { [ <browser-tabs> ] f f @top }
         { [ <browser-tracks> ] set-browser-track f @center }
     } make-frame* ;
 

library/ui/tools/help.factor

@@ -13,25 +13,18 @@ TUPLE: help-gadget history ;
 
 : go-home ( help -- ) "handbook" swap show-help ;
 
-: find-help-gadget [ help-gadget? ] find-parent ;
-
-: history-action find-help-gadget help-gadget-history ;
-
-: <help-toolbar> ( -- gadget )
-    [
-        "Back" [ history-action go-back ] <bevel-button> ,
-        "Forward" [ history-action go-forward ] <bevel-button> ,
-        "Home" [ find-help-gadget go-home ] <bevel-button> ,
-        <spacing> ,
-        "Search" [ drop search-help-window ] <bevel-button> ,
-    ] make-toolbar ;
+help-gadget {
+    { f "Back" T{ key-down f f "b" } [ help-gadget-history go-back ] }
+    { f "Forward" T{ key-down f f "f" } [ help-gadget-history go-forward ] }
+    { f "Home" T{ key-down f f "h" } [ go-home ] }
+} define-commands
 
 : <help-pane> ( -- gadget )
     gadget get help-gadget-history [ help ] <pane-control> ;
 
 C: help-gadget ( -- gadget )
     f <history> over set-help-gadget-history {
-        { [ <help-toolbar> ] f f @top }
+        { [ gadget get <toolbar> ] f f @top }
         { [ <help-pane> <scroller> ] f f @center }
     } make-frame* ;
 
@@ -39,12 +32,8 @@ M: help-gadget gadget-title
     help-gadget-history
     [ "Help - " swap article-title append ] <filter> ;
 
-M: help-gadget pref-dim*
-    drop { 500 600 } ;
+M: help-gadget pref-dim* drop { 500 600 } ;
 
-: help-tool
-    [ help-gadget? ]
-    [ <help-gadget> ]
-    [ show-help ] ;
+: help-tool [ help-gadget? ] [ <help-gadget> ] [ show-help ] ;
 
 M: link show help-tool call-tool ;

library/ui/tools/launchpad.factor

@@ -1,40 +1,28 @@
 ! Copyright (C) 2006 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-IN: gadgets-launchpad
-USING: gadgets gadgets-borders gadgets-browser
-gadgets-buttons gadgets-labels gadgets-listener gadgets-panes
-gadgets-presentations gadgets-scrolling gadgets-search
-gadgets-theme generic help inspector io kernel memory namespaces
-prettyprint sequences words ;
-
-: <launchpad> ( menu -- )
-    [ first2 [ drop ] append <bevel-button> ] map make-pile
-    1 over set-pack-fill
-    { 5 5 } over set-pack-gap
-    <default-border> dup highlight-theme ;
-
-: pane-window ( quot title -- )
-    >r make-pane <scroller> r> open-titled-window ;
+IN: gadgets
+USING: gadgets-presentations memory io gadgets-panes
+gadgets-scrolling namespaces help kernel gadgets-listener
+gadgets-browser ;
 
 : handbook-window ( -- )
     T{ link f "handbook" } show ;
 
 : memory-window ( -- )
-    [ heap-stats. terpri room. ] "Memory" pane-window ;
+    [ heap-stats. terpri room. ] make-pane <scroller>
+    "Memory" open-titled-window ;
 
 : globals-window ( -- )
     global show ;
 
-: default-launchpad
-    {
-        { "Listener" [ listener-window ] }
-        { "Browser" [ browser-window ] }
-        { "Documentation" [ handbook-window ] }
-        { "Globals" [ globals-window ] }
-        { "Memory" [ memory-window ] }
-        { "Save image" [ save ] }
-        { "Exit" [ 0 exit ] }
-    } <launchpad> ;
-
-: launchpad-window ( -- )
-    default-launchpad open-window ;
+world {
+    { f "Listener" f [ drop listener-window ] }
+    { f "Browser" f [ drop browser-window ] }
+    { f "Apropos" f [ drop apropos-window ] }
+    { f "Help" f [ drop handbook-window ] }
+    { f "Search Help" f [ drop search-help-window ] }
+    { f "Globals" f [ drop globals-window ] }
+    { f "Memory" f [ drop memory-window ] }
+    { f "Save image" f [ drop save ] }
+    { f "Exit" f [ drop 0 exit ] }
+} define-commands

library/ui/tools/walker.factor

@@ -45,15 +45,13 @@ namespaces sequences shells threads vectors ;
 
 TUPLE: walker-gadget model quot ns ;
 
-: find-walker-gadget [ walker-gadget? ] find-parent ;
-
 : update-stacks ( walker -- )
     meta-interp get over walker-gadget-model set-model
     meta-callframe swap walker-gadget-quot set-model ;
 
 : with-walker ( gadget quot -- )
-    swap find-walker-gadget
-    dup walker-gadget-ns [ slip update-stacks ] bind ; inline
+    swap dup walker-gadget-ns
+    [ slip update-stacks ] bind ; inline
 
 : walker-step [ step ] with-walker ;
 : walker-step-in [ step-in ] with-walker ;
@@ -61,14 +59,13 @@ TUPLE: walker-gadget model quot ns ;
 : walker-step-all [ step-all ] with-walker ;
 : walker-step-back [ step-back ] with-walker ;
 
-: <walker-toolbar> ( -- gadget )
-    [
-        "Step" [ walker-step ] <bevel-button> ,
-        "Step in" [ walker-step-in ] <bevel-button> ,
-        "Step out" [ walker-step-out ] <bevel-button> ,
-        "Continue" [ walker-step-all ] <bevel-button> ,
-        "Step back" [ walker-step-back ] <bevel-button> ,
-    ] make-toolbar ;
+walker-gadget {
+    { f "Step" T{ key-down f f "s" } [ walker-step ] }
+    { f "Step in" T{ key-down f f "i" } [ walker-step-in ] }
+    { f "Step out" T{ key-down f f "o" } [ walker-step-out ] }
+    { f "Step back" T{ key-down f f "b" } [ walker-step-back ] }
+    { f "Continue" T{ key-down f f "c" } [ walker-step-all ] }
+} define-commands
 
 : init-walker-models ( walker -- )
     f <model> over set-walker-gadget-model
@@ -93,18 +90,10 @@ M: walker-gadget pref-dim*
 
 C: walker-gadget ( -- gadget )
     dup init-walker-models {
-        { [ <walker-toolbar> ] f f @top }
+        { [ gadget get <toolbar> ] f f @top }
         { [ walker-models <walker-track> ] f f @center }
     } make-frame* ;
 
-\ walker-gadget H{
-    { T{ key-down f f "s" } [ walker-step ] }
-    { T{ key-down f f "i" } [ walker-step-in ] }
-    { T{ key-down f f "o" } [ walker-step-out ] }
-    { T{ key-down f f "a" } [ walker-step-all ] }
-    { T{ key-down f f "b" } [ walker-step-back ] }
-} set-gestures
-
 : walk ( quot -- )
     continuation dup continuation-data pop*
     <walker-gadget> [ (walk) ] keep open-window stop ;

library/ui/ui.factor

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