some new UI words: handles-gesture? checks whether a gesture will be handled. topmost...

diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index 91c5ea831252433af466782a6b243633b6335ecb..1e5a8df1dd821281396b55f110390bd1fa378d3e 100644 (file)
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/basis/ui/gestures/gestures-docs.factor
@@ -13,9 +13,20 @@ $nl
 "Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's parent."
 $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 } "." } ;
+{ $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 } ". If you define a method on " { $snippet "handle-gesture" } ", you should also override " { $link handles-gesture? } "." } ;
 
-{ propagate-gesture handle-gesture set-gestures } related-words
+HELP: handles-gesture?
+{ $values { "gesture" "a gesture" } { "gadget" "the receiver of the gesture" } { "?" "a boolean" } }
+{ $contract "Returns a true value if " { $snippet "gadget" } " would handle " { $snippet "gesture" } " in its " { $link handle-gesture } " method."
+$nl
+"The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class and returns true if a handler is present for " { $snippet "gesture" } "." }
+{ $notes "This word is used in Factor's MacOS X UI to validate menu items." } ;
+
+HELP: parents-handle-gesture?
+{ $values { "gesture" "a gesture" } { "gadget" "the receiver of the gesture" } { "?" "a boolean" } }
+{ $contract "Returns a true value if " { $snippet "gadget" } " or any of its ancestors would handle " { $snippet "gesture" } " in its " { $link handle-gesture } " method." } ;
+
+{ propagate-gesture handle-gesture handles-gesture? set-gestures } related-words
 
 HELP: propagate-gesture
 { $values { "gesture" "a gesture" } { "gadget" gadget } }

diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index dcfb8d4d66b759015bf867e9d721fef1a4f549f6..26eb45c8d02196b2a5f20911057866de39abcbe2 100644 (file)
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -7,13 +7,24 @@ sets columns fry deques ui.gadgets ui.gadgets.private ascii
 combinators.short-circuit ;
 IN: ui.gestures
 
+: get-gesture-handler ( gesture gadget -- quot )
+    class superclasses [ "gestures" word-prop ] map assoc-stack ;
+
 GENERIC: handle-gesture ( gesture gadget -- ? )
 
 M: object handle-gesture
     [ nip ]
-    [ class superclasses [ "gestures" word-prop ] map assoc-stack ] 2bi
+    [ get-gesture-handler ] 2bi
     dup [ call( gadget -- ) f ] [ 2drop t ] if ;
 
+GENERIC: handles-gesture? ( gesture gadget -- ? )
+
+M: object handles-gesture? ( gesture gadget -- ? )
+    get-gesture-handler >boolean ;
+
+: parents-handle-gesture? ( gesture gadget -- ? )
+    [ handles-gesture? not ] with each-parent not ;
+
 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
 
 : gesture-queue ( -- deque ) \ gesture-queue get ;

diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index b381c4e677d3d51725ebed397621626b0756c219..43dd22cde7e0a4116e0ba4ff57286aa53962c689 100644 (file)
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -81,6 +81,10 @@ HELP: with-ui
 HELP: beep
 { $description "Plays the system beep sound." } ;
 
+HELP: topmost-window
+{ $values { "world" world } }
+{ $description "Returns the " { $link world } " representing the currently focused window." } ;
+
 ARTICLE: "ui-glossary" "UI glossary"
 { $table
     { "color" { "an instance of " { $link color } } }

diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 37ec4f35b1cdefc3c8e5d7a0d749d35dab97ab72..db05465986c35764841a77723401509dd6e15768 100644 (file)
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -224,6 +224,9 @@ PRIVATE>
 : raise-window ( gadget -- )
     find-world raise-window* ;
 
+: topmost-window ( -- world )
+    windows get last second ;
+
 HOOK: close-window ui-backend ( gadget -- )
 
 M: object close-window