From 758ccb33fc53b3b8aae1199dd26d8a16876ca83f Mon Sep 17 00:00:00 2001 From: slava Date: Thu, 24 Aug 2006 22:23:48 +0000 Subject: [PATCH] Command framework --- TODO.FACTOR.txt | 15 +++++++- library/bootstrap/boot-stage1.factor | 1 + library/test/gadgets/commands.factor | 8 ++++ library/test/test.factor | 1 + library/ui/commands.factor | 56 ++++++++++++++++++++++++++++ library/ui/gadgets/buttons.factor | 5 +++ library/ui/gestures.factor | 7 ---- library/ui/tools/browser.factor | 9 +---- library/ui/tools/help.factor | 27 ++++---------- library/ui/tools/launchpad.factor | 46 +++++++++-------------- library/ui/tools/walker.factor | 31 +++++---------- library/ui/ui.factor | 4 +- 12 files changed, 123 insertions(+), 87 deletions(-) create mode 100644 library/test/gadgets/commands.factor create mode 100644 library/ui/commands.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index e1f2ed5b98..7a45d38cac 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 81ebd82e19..90aeeb0cfd 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/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" diff --git a/library/test/gadgets/commands.factor b/library/test/gadgets/commands.factor new file mode 100644 index 0000000000..45a907434e --- /dev/null +++ b/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 diff --git a/library/test/test.factor b/library/test/test.factor index 147b1885bf..65c57a28b7 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -86,6 +86,7 @@ SYMBOL: failures "gadgets/document" "gadgets/rectangles" "gadgets/fields" + "gadgets/commands" "generic" "help/porter-stemmer" "help/topics" diff --git a/library/ui/commands.factor b/library/ui/commands.factor new file mode 100644 index 0000000000..4f569bcf30 --- /dev/null +++ b/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 ] 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 diff --git a/library/ui/gadgets/buttons.factor b/library/ui/gadgets/buttons.factor index 9f7b3cb1bc..3bf0b6ffc4 100644 --- a/library/ui/gadgets/buttons.factor +++ b/library/ui/gadgets/buttons.factor @@ -52,6 +52,11 @@ C: button ( gadget quot -- button ) : ( gadget quot -- button )