diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 7a45d38cac..9814298fae 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/library/ui/cocoa/services.factor b/library/ui/cocoa/services.factor index 7f95435abd..6d141be282 100644 --- a/library/ui/cocoa/services.factor +++ b/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" @@ -27,7 +27,12 @@ parser prettyprint styles ; { "evalInListener:userData:error:" "void" { "id" "SEL" "id" "id" "void*" } - [ nip [ show f ] do-service 2drop ] + [ + nip + [ listener-tool call-listener f ] + do-service + 2drop + ] } { "evalToString:userData:error:" "void" diff --git a/library/ui/commands.factor b/library/ui/commands.factor index 2a88157392..346bf02da4 100644 --- a/library/ui/commands.factor +++ b/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 ] 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> 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 diff --git a/library/ui/gadgets/presentations.factor b/library/ui/gadgets/presentations.factor index 241e211408..4ac986177d 100644 --- a/library/ui/gadgets/presentations.factor +++ b/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 ] - r> set-gadget-delegate - ] keep ; + [ >r f 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 ) diff --git a/library/ui/text/interactor.factor b/library/ui/text/interactor.factor index 8f1aca486c..d2836ed41b 100644 --- a/library/ui/text/interactor.factor +++ b/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 ) diff --git a/library/ui/tools/browser.factor b/library/ui/tools/browser.factor index 64c7990853..3c13ad7021 100644 --- a/library/ui/tools/browser.factor +++ b/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" ; : browser-tool [ 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 diff --git a/library/ui/tools/help.factor b/library/ui/tools/help.factor index 8c997bccf3..0a41ecf1cf 100644 --- a/library/ui/tools/help.factor +++ b/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? ] [ ] [ show-help ] ; -M: link show help-tool call-tool ; +[ link? ] 1 "Browse" [ help-tool call-tool ] define-operation diff --git a/library/ui/tools/launchpad.factor b/library/ui/tools/launchpad.factor index b389b7b599..07cbbafe6a 100644 --- a/library/ui/tools/launchpad.factor +++ b/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 "Memory" open-titled-window ; : globals-window ( -- ) - global show ; + [ global inspect ] listener-tool call-tool ; ! world { ! { f "Listener" f [ drop listener-window ] } diff --git a/library/ui/tools/listener.factor b/library/ui/tools/listener.factor index 7725b42f2d..dbad7aa72a 100644 --- a/library/ui/tools/listener.factor +++ b/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" ; [ [ 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 diff --git a/library/ui/ui.factor b/library/ui/ui.factor index 34847f4e34..c0c3d153b8 100644 --- a/library/ui/ui.factor +++ b/library/ui/ui.factor @@ -139,7 +139,8 @@ C: titled-gadget ( gadget title -- ) windows get [ empty? not ] [ f ] if* ; : ( gadget -- toolbar ) - commands [ ] map make-shelf ; + commands [ ] map make-shelf + dup highlight-theme ; : error-window ( error -- ) [ print-error ] make-pane "Error" open-titled-window ;