From 76b1f9ce03d0679b0a492a6b4c93bc6ba9801352 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 22 Jun 2009 19:01:50 -0500
Subject: [PATCH] some new UI words: handles-gesture? checks whether a gesture
 will be handled. topmost-window returns the topmost world object

---
 basis/ui/gestures/gestures-docs.factor | 15 +++++++++++++--
 basis/ui/gestures/gestures.factor      | 13 ++++++++++++-
 basis/ui/ui-docs.factor                |  4 ++++
 basis/ui/ui.factor                     |  3 +++
 4 files changed, 32 insertions(+), 3 deletions(-)

diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index 91c5ea8312..1e5a8df1dd 100644
--- 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 dcfb8d4d66..26eb45c8d0 100644
--- 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 b381c4e677..43dd22cde7 100644
--- 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 37ec4f35b1..db05465986 100644
--- 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