Gesture protocol allows a gadget to intercept arbitrary gestures

TODO.FACTOR.txt

@@ -7,7 +7,6 @@
 - http://paste.lisp.org/display/30426
 - robustify stepper -- see if step back past a throw works
 - listener: if partial parse, RETURN should insert newline
-- some way of intercepting all gestures
 - compiled call traces:
   - should be independent of whenever the runtime was built with
     -fomit-frame-pointer or not

library/ui/cocoa/view-utils.factor

@@ -79,7 +79,7 @@ opengl sequences ;
 
 : send-key-event ( view event quot -- ? )
     >r key-event>gesture r> call swap window-focus
-    handle-gesture ; inline
+    send-gesture ; inline
 
 : send-user-input ( view event -- )
     -> characters CF>string swap window-focus user-input ;

library/ui/gestures.factor

@@ -4,20 +4,19 @@ IN: gadgets
 USING: arrays generic hashtables kernel math models namespaces
 queues sequences words ;
 
-: gestures ( gadget -- seq )
-    delegates [ class "gestures" word-prop ] map [ ] subset ;
-
 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
 
-: handle-gesture* ( gesture gadget -- )
+GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
-    tuck gestures hash-stack [ call f ] [ drop t ] if* ;
+
+M: object handle-gesture*
+    class "gestures" word-prop ?hash*
+    [ call f ] [ 2drop t ] if ;
 
 : handle-gesture ( gesture gadget -- ? )
-    #! If a gadget's handle-gesture* generic returns t, the
+    tuck delegates [ >r 2dup r> handle-gesture* ] all? 2nip ;
-    #! event was not consumed and is passed on to the gadget's
+
-    #! parent. This word returns t if no gadget handled the
+: send-gesture ( gesture gadget -- ? )
-    #! gesture, otherwise returns f.
+    [ dupd handle-gesture ] each-parent nip ;
-    [ dupd handle-gesture* ] each-parent nip ;
 
 : user-input ( str gadget -- )
     [ dupd user-input* ] each-parent 2drop ;
@@ -41,7 +40,7 @@ TUPLE: delete-action ;
 TUPLE: select-all-action ;
 
 : handle-action ( gadget constructor -- )
-    execute swap handle-gesture drop ; inline
+    execute swap send-gesture drop ; inline
 
 : generalize-gesture ( gesture -- gesture )
     #! Strip button number from drag/button-up/button-down.
@@ -85,8 +84,8 @@ SYMBOL: double-click-timeout
 300 double-click-timeout set-global
 
 : button-gesture ( gesture -- )
-    hand-clicked get-global 2dup handle-gesture [
+    hand-clicked get-global 2dup send-gesture [
-        >r generalize-gesture r> handle-gesture drop
+        >r generalize-gesture r> send-gesture drop
     ] [
         2drop
     ] if ;
@@ -99,13 +98,13 @@ SYMBOL: double-click-timeout
     #! and if a mouse button is down, fire a drag gesture to the
     #! gadget that was clicked.
     hand-buttons get-global empty? [
-        T{ motion } hand-gadget get-global handle-gesture drop
+        T{ motion } hand-gadget get-global send-gesture drop
     ] [
         drag-gesture
     ] if ;
 
 : each-gesture ( gesture seq -- )
-    [ handle-gesture* drop ] each-with ;
+    [ handle-gesture drop ] each-with ;
 
 : hand-gestures ( new old -- )
     drop-prefix <reversed>
@@ -199,11 +198,11 @@ SYMBOL: double-click-timeout
 : send-wheel ( direction loc world -- )
     move-hand
     scroll-direction set-global
-    T{ mouse-scroll } hand-gadget get-global handle-gesture
+    T{ mouse-scroll } hand-gadget get-global send-gesture
     drop ;
 
 : send-action ( world gesture -- )
-    swap world-focus handle-gesture drop ;
+    swap world-focus send-gesture drop ;
 
 : resend-button-down ( gesture world -- )
     hand-loc get-global swap send-button-down ;

library/ui/windows/ui.factor

@@ -128,7 +128,7 @@ SYMBOL: hWnd
     lParam set wParam set uMsg set hWnd set
     wParam get exclude-key-wm-keydown? [
         wParam get keystroke>gesture <key-down>
-        hWnd get window-focus handle-gesture drop 
+        hWnd get window-focus send-gesture drop 
     ] unless ;
 
 : handle-wm-char ( hWnd uMsg wParam lParam -- )
@@ -141,7 +141,7 @@ SYMBOL: hWnd
 : handle-wm-keyup ( hWnd uMsg wParam lParam -- )
     lParam set wParam set uMsg set hWnd set
     wParam get keystroke>gesture <key-up>
-    hWnd get window-focus handle-gesture
+    hWnd get window-focus send-gesture
     drop ;
 
 : cleanup-window ( handle -- )

library/ui/x11/ui.factor

@@ -80,7 +80,7 @@ M: world configure-event
 
 M: world key-down-event
     world-focus over key-down-event>gesture [
-        over handle-gesture
+        over send-gesture
         [ swap lookup-string nip swap user-input ] [ 2drop ] if
     ] [
         2drop
@@ -88,7 +88,7 @@ M: world key-down-event
 
 M: world key-up-event
     world-focus swap key-event>gesture dup [
-        <key-up> dup [ swap handle-gesture drop ] [ 2drop ] if
+        <key-up> dup [ swap send-gesture drop ] [ 2drop ] if
     ] [
         3drop
     ] if ;