Merge branch 'master' of git://factorcode.org/git/factor

basis/opengl/gl/gl.factor

@@ -356,10 +356,6 @@ CONSTANT: GL_DITHER                         HEX: 0BD0
 CONSTANT: GL_RGB                            HEX: 1907
 CONSTANT: GL_RGBA                           HEX: 1908
 
-! GL_BGRA_ext: http://www.opengl.org/registry/specs/EXT/bgra.txt
-CONSTANT: GL_BGR_EXT                        HEX: 80E0
-CONSTANT: GL_BGRA_EXT                       HEX: 80E1
-
 ! Implementation limits
 CONSTANT: GL_MAX_LIST_NESTING               HEX: 0B31
 CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH         HEX: 0D35

basis/opengl/textures/textures.factor

@@ -44,10 +44,10 @@ M: BGR component-order>format drop GL_BGR ;
 M: RGBA component-order>format drop GL_RGBA ;
 M: ARGB component-order>format
     swap GL_UNSIGNED_BYTE =
-    [ drop GL_UNSIGNED_INT_8_8_8_8_REV GL_BGRA_EXT ]
+    [ drop GL_UNSIGNED_INT_8_8_8_8_REV GL_BGRA ]
     [ unsupported-component-order ] if ;
-M: BGRA component-order>format drop GL_BGRA_EXT ;
+M: BGRA component-order>format drop GL_BGRA ;
-M: BGRX component-order>format drop GL_BGRA_EXT ;
+M: BGRX component-order>format drop GL_BGRA ;
 M: LA component-order>format drop GL_LUMINANCE_ALPHA ;
 M: L component-order>format drop GL_LUMINANCE ;
 

basis/ui/backend/cocoa/views/views.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays assocs cocoa kernel math
+USING: accessors alien alien.c-types alien.strings arrays assocs
-cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
+cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes
-cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences
+cocoa.views cocoa.application cocoa.pasteboard cocoa.types
-ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds
+cocoa.windows sequences io.encodings.ascii ui ui.private ui.gadgets
-ui.gestures core-foundation.strings core-graphics core-graphics.types
+ui.gadgets.private ui.gadgets.worlds ui.gestures
-threads combinators math.rectangles ;
+core-foundation.strings core-graphics core-graphics.types threads
+combinators math.rectangles ;
 IN: ui.backend.cocoa.views
 
 : send-mouse-moved ( view event -- )
@@ -121,6 +122,25 @@ CONSTANT: key-codes
     [ drop dim>> first2 ]
     2bi <CGRect> ;
 
+CONSTANT: selector>action H{
+    { "undo:" undo-action }
+    { "redo:" redo-action }
+    { "cut:" cut-action }
+    { "copy:" copy-action }
+    { "paste:" paste-action }
+    { "delete:" delete-action }
+    { "selectAll:" select-all-action }
+    { "newDocument:" new-action }
+    { "openDocument:" open-action }
+    { "saveDocument:" save-action }
+    { "saveDocumentAs:" save-as-action }
+    { "revertDocumentToSaved:" revert-action }
+}
+
+: validate-action ( world selector -- ? validated? )
+    selector>action at 
+    [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ; 
+
 CLASS: {
     { +superclass+ "NSOpenGLView" }
     { +name+ "FactorView" }
@@ -197,6 +217,14 @@ CLASS: {
     [ nip send-key-up-event ]
 }
 
+{ "validateUserInterfaceItem:" "char" { "id" "SEL" "id" }
+    [
+        nip -> action
+        2dup [ window ] [ ascii alien>string ] bi* validate-action
+        [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
+    ]
+}
+
 { "undo:" "id" { "id" "SEL" "id" }
     [ nip undo-action send-action$ ]
 }

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

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 ;

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

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