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

@@ -18,8 +18,8 @@ IN: ui.cocoa.views
     {
         { S+ HEX: 20000 }
         { C+ HEX: 40000 }
-        { A+ HEX: 80000 }
+        { A+ HEX: 100000 }
-        { M+ 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 -- ? )
+: send-key-event ( view gesture -- )
-    >r key-event>gesture r> call swap window-focus
+    swap window-focus propagate-gesture ;
-    send-gesture ; inline
 
 : 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 [ <key-down> ] send-key-event
+    [ key-event>gesture <key-down> send-key-event ]
-    [ interpret-key-event ] [ 2drop ] if ;
+    [ interpret-key-event ]
+    2bi ;
 
 : send-key-up-event ( view event -- )
-    [ <key-up> ] send-key-event drop ;
+    key-event>gesture <key-up> send-key-event ;
 
 : mouse-event>gesture ( event -- modifiers button )
     dup event-modifiers swap button ;
 
 : send-button-down$ ( view event -- )
-    [ mouse-event>gesture <button-down> ] 2keep
+    [ mouse-event>gesture <button-down> ]
-    mouse-location rot window send-button-down ;
+    [ mouse-location rot window send-button-down ] 2bi ;
 
 : send-button-up$ ( view event -- )
     [ mouse-event>gesture <button-up> ] 2keep

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 ;
 
 : <edit-button> ( -- gadget )
     "..."
-    [ T{ edit-slot } swap send-gesture drop ]
+    [ T{ edit-slot } swap propagate-gesture ]
     <roll-button> ;
 
 : display-slot ( gadget editable-slot -- )

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 ;

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 } }

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
+math.vectors classes.tuple classes  boxes calendar
-alarms symbols combinators sets columns ;
+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 -- ? )
+: send-gesture ( gesture gadget -- )
-    [ dupd handle-gesture ] each-parent nip ;
+    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?
+    '[ _ [ user-input* ] with each-parent drop ] unless-empty ;
-    [ [ dupd user-input* ] each-parent ] unless
-    2drop ;
 
 ! Gesture objects
 TUPLE: motion ;             C: <motion> motion
@@ -46,11 +50,8 @@ TUPLE: right-action ;       C: <right-action> right-action
 TUPLE: up-action ;          C: <up-action> up-action
 TUPLE: down-action ;        C: <down-action> down-action
 
-TUPLE: zoom-in-action ;  C: <zoom-in-action> zoom-in-action
+TUPLE: zoom-in-action ;     C: <zoom-in-action> zoom-in-action
-TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
+TUPLE: zoom-out-action ;    C: <zoom-out-action> zoom-out-action
-
-: generalize-gesture ( gesture -- newgesture )
-    clone f >># ;
 
 ! Modifiers
 SYMBOLS: C+ A+ M+ S+ ;
@@ -58,7 +59,7 @@ SYMBOLS: C+ A+ M+ S+ ;
 TUPLE: key-down mods sym ;
 
 : <key-gesture> ( mods sym action? class -- mods' sym' )
-    >r [ S+ rot remove swap ] unless r> boa ; inline
+    [ [ S+ rot remove swap ] unless ] dip boa ; inline
 
 : <key-down> ( mods sym action? -- key-down )
     key-down <key-gesture> ;
@@ -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 [
+    hand-clicked get-global propagate-gesture ;
-        >r generalize-gesture r> send-gesture drop
-    ] [
-        2drop
-    ] if ;
 
 : 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 <reversed>
     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
+    hand-gadget get-global
-    f hand-gadget set-global
+    [ f hand-gadget set-global f ] dip
-    f r> parents hand-gestures ;
+    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
+    under-hand [
-    pick-up hand-gadget set-global
+        over hand-loc set-global
-    under-hand r> hand-gestures ;
+        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
+    T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
-    drop ;
 
 : 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 )
 

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+ } "LEFT" } com-back }
-    { T{ key-down f { A+ } "f" } com-forward }
+    { T{ key-down f { A+ } "RIGHT" } com-forward }
-    { T{ key-down f { A+ } "h" } com-documentation }
+    { f com-documentation }
-    { T{ key-down f { A+ } "v" } com-vocabularies }
+    { f com-vocabularies }
     { T{ key-down f f "F1" } browser-help }
 } define-command-map
 

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 <key-down>
-        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 <key-up>
-    hWnd window-focus send-gesture drop ;
+    hWnd window-focus propagate-gesture ;
 
 :: set-window-active ( hwnd uMsg wParam lParam ? -- n )
     ? hwnd window (>>active?)

basis/ui/x11/x11.factor

@@ -72,15 +72,19 @@ M: world configure-event
     handle>> xic>> lookup-string
     >r swap event-modifiers r> key-code <key-down> ;
 
+: 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
+    [ key-down-event>gesture ] keep
-    [ send-gesture ] keep swap [ user-input ] [ 2drop ] if ;
+    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 <key-up> ;
 
 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