From e65368a1372d23a5f1decda8e6b49eb9fe4c5a43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Nov 2008 22:03:14 -0600 Subject: [PATCH] UI event handling refactoring - A+ is now the command key, and M+ is the option key, on mac - new send-gesture, propagate-gesture words clean up gesture sending - always send user-input after key-down, without checking if a gadget handled the key-down first --- basis/ui/cocoa/views/views.factor | 20 ++++----- basis/ui/gadgets/slots/slots.factor | 10 ++--- basis/ui/gadgets/worlds/worlds.factor | 14 ++++++ basis/ui/gestures/gestures-docs.factor | 6 +-- basis/ui/gestures/gestures.factor | 61 ++++++++++++-------------- basis/ui/tools/browser/browser.factor | 8 ++-- basis/ui/windows/windows.factor | 4 +- basis/ui/x11/x11.factor | 10 +++-- 8 files changed, 73 insertions(+), 60 deletions(-) diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index c6942a8158..f72eab0862 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -18,8 +18,8 @@ IN: ui.cocoa.views { { S+ HEX: 20000 } { C+ HEX: 40000 } - { A+ HEX: 80000 } - { M+ HEX: 100000 } + { A+ HEX: 100000 } + { M+ HEX: 80000 } } ; : key-codes @@ -59,9 +59,8 @@ IN: ui.cocoa.views : key-event>gesture ( event -- modifiers keycode action? ) dup event-modifiers swap key-code ; -: send-key-event ( view event quot -- ? ) - >r key-event>gesture r> call swap window-focus - send-gesture ; inline +: send-key-event ( view gesture -- ) + swap window-focus propagate-gesture ; : send-user-input ( view string -- ) CF>string swap window-focus user-input ; @@ -70,18 +69,19 @@ IN: ui.cocoa.views NSArray swap -> arrayWithObject: -> interpretKeyEvents: ; : send-key-down-event ( view event -- ) - 2dup [ ] send-key-event - [ interpret-key-event ] [ 2drop ] if ; + [ key-event>gesture send-key-event ] + [ interpret-key-event ] + 2bi ; : send-key-up-event ( view event -- ) - [ ] send-key-event drop ; + key-event>gesture send-key-event ; : mouse-event>gesture ( event -- modifiers button ) dup event-modifiers swap button ; : send-button-down$ ( view event -- ) - [ mouse-event>gesture ] 2keep - mouse-location rot window send-button-down ; + [ mouse-event>gesture ] + [ mouse-location rot window send-button-down ] 2bi ; : send-button-up$ ( view event -- ) [ mouse-event>gesture ] 2keep diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor index ff2220b60e..e04b288a5d 100644 --- a/basis/ui/gadgets/slots/slots.factor +++ b/basis/ui/gadgets/slots/slots.factor @@ -26,10 +26,10 @@ TUPLE: slot-editor < track ref text ; GENERIC: finish-editing ( slot-editor ref -- ) M: key-ref finish-editing - drop T{ update-object } swap send-gesture drop ; + drop T{ update-object } swap propagate-gesture ; M: value-ref finish-editing - drop T{ update-slot } swap send-gesture drop ; + drop T{ update-slot } swap propagate-gesture ; : slot-editor-value ( slot-editor -- object ) text>> control-value parse-fresh ; @@ -55,14 +55,14 @@ M: value-ref finish-editing : delete ( slot-editor -- ) dup ref>> delete-ref - T{ update-object } swap send-gesture drop ; + T{ update-object } swap propagate-gesture ; \ delete H{ { +description+ "Delete the slot and close the slot editor." } } define-command : close ( slot-editor -- ) - T{ update-slot } swap send-gesture drop ; + T{ update-slot } swap propagate-gesture ; \ close H{ { +description+ "Close the slot editor without saving changes." } @@ -92,7 +92,7 @@ TUPLE: editable-slot < track printer ref ; : ( -- gadget ) "..." - [ T{ edit-slot } swap send-gesture drop ] + [ T{ edit-slot } swap propagate-gesture ] ; : display-slot ( gadget editable-slot -- ) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index e338d6d4f4..29c663e914 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -107,6 +107,20 @@ world H{ { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] } } set-gestures +PREDICATE: specific-button-up < button-up #>> ; + +PREDICATE: specific-button-down < button-down #>> ; + +: generalize-gesture ( gesture -- ) + clone f >># button-gesture ; + +M: world handle-gesture ( gesture gadget -- ? ) + { + { [ over specific-button-up? ] [ drop generalize-gesture t ] } + { [ over specific-button-down? ] [ drop generalize-gesture t ] } + [ call-next-method ] + } cond ; + : close-global ( world global -- ) dup get-global find-world rot eq? [ f swap set-global ] [ drop ] if ; diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor index 3471bd2cdb..69425cca0f 100644 --- a/basis/ui/gestures/gestures-docs.factor +++ b/basis/ui/gestures/gestures-docs.factor @@ -15,11 +15,11 @@ $nl "The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class." } { $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ; -{ send-gesture handle-gesture set-gestures } related-words +{ propagate-gesture handle-gesture set-gestures } related-words -HELP: send-gesture +HELP: propagate-gesture { $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } } -{ $description "Calls " { $link send-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ; +{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ; HELP: user-input { $values { "str" string } { "gadget" gadget } } diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 2a29d32055..63ecbc2a80 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math models namespaces make sequences words strings system hashtables math.parser -math.vectors classes.tuple classes ui.gadgets boxes calendar -alarms symbols combinators sets columns ; +math.vectors classes.tuple classes boxes calendar +alarms symbols combinators sets columns fry ui.gadgets ; IN: ui.gestures : set-gestures ( class hash -- ) "gestures" set-word-prop ; @@ -15,13 +15,17 @@ M: object handle-gesture [ "gestures" word-prop ] map assoc-stack dup [ call f ] [ 2drop t ] if ; -: send-gesture ( gesture gadget -- ? ) - [ dupd handle-gesture ] each-parent nip ; +: send-gesture ( gesture gadget -- ) + handle-gesture drop ; + +: each-gesture ( gesture seq -- ) + [ send-gesture ] with each ; + +: propagate-gesture ( gesture gadget -- ) + [ handle-gesture ] with each-parent drop ; : user-input ( str gadget -- ) - over empty? - [ [ dupd user-input* ] each-parent ] unless - 2drop ; + '[ _ [ user-input* ] with each-parent drop ] unless-empty ; ! Gesture objects TUPLE: motion ; C: motion @@ -46,11 +50,8 @@ TUPLE: right-action ; C: right-action TUPLE: up-action ; C: up-action TUPLE: down-action ; C: down-action -TUPLE: zoom-in-action ; C: zoom-in-action -TUPLE: zoom-out-action ; C: zoom-out-action - -: generalize-gesture ( gesture -- newgesture ) - clone f >># ; +TUPLE: zoom-in-action ; C: zoom-in-action +TUPLE: zoom-out-action ; C: zoom-out-action ! Modifiers SYMBOLS: C+ A+ M+ S+ ; @@ -58,7 +59,7 @@ SYMBOLS: C+ A+ M+ S+ ; TUPLE: key-down mods sym ; : ( mods sym action? class -- mods' sym' ) - >r [ S+ rot remove swap ] unless r> boa ; inline + [ [ S+ rot remove swap ] unless ] dip boa ; inline : ( mods sym action? -- key-down ) key-down ; @@ -100,11 +101,7 @@ SYMBOL: double-click-timeout hand-loc get hand-click-loc get = not ; : button-gesture ( gesture -- ) - hand-clicked get-global 2dup send-gesture [ - >r generalize-gesture r> send-gesture drop - ] [ - 2drop - ] if ; + hand-clicked get-global propagate-gesture ; : drag-gesture ( -- ) hand-buttons get-global @@ -130,14 +127,11 @@ SYMBOL: drag-timer : fire-motion ( -- ) hand-buttons get-global empty? [ - T{ motion } hand-gadget get-global send-gesture drop + T{ motion } hand-gadget get-global propagate-gesture ] [ drag-gesture ] if ; -: each-gesture ( gesture seq -- ) - [ handle-gesture drop ] with each ; - : hand-gestures ( new old -- ) drop-prefix T{ mouse-leave } swap each-gesture @@ -145,15 +139,15 @@ SYMBOL: drag-timer : forget-rollover ( -- ) f hand-world set-global - hand-gadget get-global >r - f hand-gadget set-global - f r> parents hand-gestures ; + hand-gadget get-global + [ f hand-gadget set-global f ] dip + parents hand-gestures ; : send-lose-focus ( gadget -- ) - T{ lose-focus } swap handle-gesture drop ; + T{ lose-focus } swap send-gesture ; : send-gain-focus ( gadget -- ) - T{ gain-focus } swap handle-gesture drop ; + T{ gain-focus } swap send-gesture ; : focus-child ( child gadget ? -- ) [ @@ -219,9 +213,11 @@ SYMBOL: drag-timer : move-hand ( loc world -- ) dup hand-world set-global - under-hand >r over hand-loc set-global - pick-up hand-gadget set-global - under-hand r> hand-gestures ; + under-hand [ + over hand-loc set-global + pick-up hand-gadget set-global + under-hand + ] dip hand-gestures ; : send-button-down ( gesture loc world -- ) move-hand @@ -240,14 +236,13 @@ SYMBOL: drag-timer : send-wheel ( direction loc world -- ) move-hand scroll-direction set-global - T{ mouse-scroll } hand-gadget get-global send-gesture - drop ; + T{ mouse-scroll } hand-gadget get-global propagate-gesture ; : world-focus ( world -- gadget ) dup focus>> [ world-focus ] [ ] ?if ; : send-action ( world gesture -- ) - swap world-focus send-gesture drop ; + swap world-focus propagate-gesture ; GENERIC: gesture>string ( gesture -- string/f ) diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index b717bbb2f9..becb401fa6 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -67,10 +67,10 @@ M: browser-gadget definitions-changed ( assoc browser -- ) \ browser-help H{ { +nullary+ t } } define-command browser-gadget "toolbar" f { - { T{ key-down f { A+ } "b" } com-back } - { T{ key-down f { A+ } "f" } com-forward } - { T{ key-down f { A+ } "h" } com-documentation } - { T{ key-down f { A+ } "v" } com-vocabularies } + { T{ key-down f { A+ } "LEFT" } com-back } + { T{ key-down f { A+ } "RIGHT" } com-forward } + { f com-documentation } + { f com-vocabularies } { T{ key-down f f "F1" } browser-help } } define-command-map diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 3e600d2e3c..81cc0a0b70 100644 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -194,7 +194,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; :: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) wParam exclude-key-wm-keydown? [ wParam keystroke>gesture - hWnd window-focus send-gesture drop + hWnd window-focus propagate-gesture ] unless ; :: handle-wm-char ( hWnd uMsg wParam lParam -- ) @@ -205,7 +205,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; :: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) wParam keystroke>gesture - hWnd window-focus send-gesture drop ; + hWnd window-focus propagate-gesture ; :: set-window-active ( hwnd uMsg wParam lParam ? -- n ) ? hwnd window (>>active?) diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index fd599635b1..04e47763a8 100644 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -72,15 +72,19 @@ M: world configure-event handle>> xic>> lookup-string >r swap event-modifiers r> key-code ; +: valid-input? ( string -- ? ) + [ f ] [ [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all? ] if-empty ; + M: world key-down-event - [ key-down-event>gesture ] keep world-focus - [ send-gesture ] keep swap [ user-input ] [ 2drop ] if ; + [ key-down-event>gesture ] keep + world-focus [ propagate-gesture ] keep + over valid-input? [ user-input ] [ 2drop ] if ; : key-up-event>gesture ( event -- gesture ) dup event-modifiers swap 0 XLookupKeysym key-code ; M: world key-up-event - >r key-up-event>gesture r> world-focus send-gesture drop ; + >r key-up-event>gesture r> world-focus propagate-gesture ; : mouse-event>gesture ( event -- modifiers button loc ) dup event-modifiers over XButtonEvent-button