The event loop thread now adds events to a queue slurped by the UI update thread instead of handling them directly. This fixes a race condition where a gadget could end up handling an event before it was grafted or laid out

basis/ui/cocoa/cocoa.factor

@@ -15,9 +15,7 @@ C: <handle> handle
 SINGLETON: cocoa-ui-backend
 
 M: cocoa-ui-backend do-events ( -- )
-    [
+    [ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
-        [ NSApp [ do-event ] curry loop ui-wait ] ui-try
-    ] with-autorelease-pool ;
 
 TUPLE: pasteboard handle ;
 

basis/ui/cocoa/views/views.factor

@@ -62,9 +62,6 @@ IN: ui.cocoa.views
 : send-key-event ( view gesture -- )
     swap window-focus propagate-gesture ;
 
-: send-user-input ( view string -- )
-    CF>string swap window-focus user-input ;
-
 : interpret-key-event ( view event -- )
     NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
 
@@ -138,83 +135,83 @@ CLASS: {
 }
 
 { "mouseEntered:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "mouseExited:" "void" { "id" "SEL" "id" }
-    [ [ 3drop forget-rollover ] ui-try ]
+    [ 3drop forget-rollover ]
 }
 
 { "mouseMoved:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "mouseDragged:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "rightMouseDragged:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "otherMouseDragged:" "void" { "id" "SEL" "id" }
-    [ [ nip send-mouse-moved ] ui-try ]
+    [ nip send-mouse-moved ]
 }
 
 { "mouseDown:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-down$ ] ui-try ]
+    [ nip send-button-down$ ]
 }
 
 { "mouseUp:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-up$ ] ui-try ]
+    [ nip send-button-up$ ]
 }
 
 { "rightMouseDown:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-down$ ] ui-try ]
+    [ nip send-button-down$ ]
 }
 
 { "rightMouseUp:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-up$ ] ui-try ]
+    [ nip send-button-up$ ]
 }
 
 { "otherMouseDown:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-down$ ] ui-try ]
+    [ nip send-button-down$ ]
 }
 
 { "otherMouseUp:" "void" { "id" "SEL" "id" }
-    [ [ nip send-button-up$ ] ui-try ]
+    [ nip send-button-up$ ]
 }
 
 { "scrollWheel:" "void" { "id" "SEL" "id" }
-    [ [ nip send-wheel$ ] ui-try ]
+    [ nip send-wheel$ ]
 }
 
 { "keyDown:" "void" { "id" "SEL" "id" }
-    [ [ nip send-key-down-event ] ui-try ]
+    [ nip send-key-down-event ]
 }
 
 { "keyUp:" "void" { "id" "SEL" "id" }
-    [ [ nip send-key-up-event ] ui-try ]
+    [ nip send-key-up-event ]
 }
 
 { "cut:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ cut-action } send-action$ ] ui-try ]
+    [ nip T{ cut-action } send-action$ ]
 }
 
 { "copy:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ copy-action } send-action$ ] ui-try ]
+    [ nip T{ copy-action } send-action$ ]
 }
 
 { "paste:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ paste-action } send-action$ ] ui-try ]
+    [ nip T{ paste-action } send-action$ ]
 }
 
 { "delete:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ delete-action } send-action$ ] ui-try ]
+    [ nip T{ delete-action } send-action$ ]
 }
 
 { "selectAll:" "id" { "id" "SEL" "id" }
-    [ [ nip T{ select-all-action } send-action$ ] ui-try ]
+    [ nip T{ select-all-action } send-action$ ]
 }
 
 ! Multi-touch gestures: this is undocumented.
@@ -290,7 +287,7 @@ CLASS: {
 
 ! Text input
 { "insertText:" "void" { "id" "SEL" "id" }
-    [ [ nip send-user-input ] ui-try ]
+    [ nip CF>string swap window-focus user-input ]
 }
 
 { "hasMarkedText" "char" { "id" "SEL" }
@@ -335,11 +332,11 @@ CLASS: {
 
 ! Initialization
 { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
-    [
+    [ 2drop dup view-dim swap window (>>dim) yield ]
-        [
+}
-            2drop dup view-dim swap window (>>dim) yield
+
-        ] ui-try
+{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
-    ]
+    [ 3drop ]
 }
 
 { "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }

basis/ui/gadgets/editors/editors.factor

@@ -356,7 +356,7 @@ M: editor gadget-text* editor-string % ;
     [ drop dup extend-selection dup mark>> click-loc ]
     [ select-elt ] if ;
 
-: insert-newline ( editor -- ) "\n" swap user-input ;
+: insert-newline ( editor -- ) "\n" swap user-input* ;
 
 : delete-next-character ( editor -- ) 
     T{ char-elt } editor-delete ;

basis/ui/gadgets/gadgets.factor

@@ -10,11 +10,9 @@ SYMBOL: ui-notify-flag
 
 : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
 
-TUPLE: gadget < rect
+TUPLE: gadget < rect pref-dim parent children orientation focus
-       pref-dim parent children orientation focus
+visible? root? clipped? layout-state graft-state graft-node
-       visible? root? clipped? layout-state graft-state graft-node
+interior boundary model ;
-       interior boundary
-       model ;
 
 M: gadget equal? 2drop f ;
 

basis/ui/gadgets/panes/panes-tests.factor

@@ -40,7 +40,7 @@ IN: ui.gadgets.panes.tests
 [ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
 [ t ] [ [ \ + describe ] test-gadget-text ] unit-test
 [ t ] [ [ \ = see ] test-gadget-text ] unit-test
-[ t ] [ [ \ = help ] test-gadget-text ] unit-test
+[ t ] [ [ \ = print-topic ] test-gadget-text ] unit-test
 
 [ t ] [
     [
@@ -84,16 +84,16 @@ ARTICLE: "test-article-1" "This is a test article"
 
 [ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
 
-[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-1" print-topic ] test-gadget-text ] unit-test
 
 ARTICLE: "test-article-2" "This is a test article"
 "Hello world, how are you today."
 { $table { "a" "b" } { "c" "d" } } ;
 
-[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-2" print-topic ] test-gadget-text ] unit-test
 
 <pane> [ \ = see ] with-pane
-<pane> [ \ = help ] with-pane
+<pane> [ \ = print-topic ] with-pane
 
 [ ] [
     \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget

basis/ui/gestures/gestures-docs.factor

@@ -22,7 +22,7 @@ HELP: propagate-gesture
 { $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 } }
+{ $values { "string" string } { "gadget" gadget } }
 { $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
 
 HELP: motion
@@ -90,10 +90,6 @@ HELP: select-all-action
 { $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
 { $examples { $code "T{ select-all-action }" } } ;
 
-HELP: generalize-gesture
-{ $values { "gesture" "a gesture" } { "newgesture" "a new gesture" } }
-{ $description "Turns a " { $link button-down } ", " { $link button-up } " or " { $link drag } " action naming a specific mouse button into one which can apply regardless of which mouse button was pressed." } ;
-
 HELP: C+
 { $description "Control key modifier." } ;
 

basis/ui/gestures/gestures.factor

@@ -3,11 +3,9 @@
 USING: accessors arrays assocs kernel math models namespaces
 make sequences words strings system hashtables math.parser
 math.vectors classes.tuple classes  boxes calendar
-alarms symbols combinators sets columns fry ui.gadgets ;
+alarms symbols combinators sets columns fry deques ui.gadgets ;
 IN: ui.gestures
 
-: set-gestures ( class hash -- ) "gestures" set-word-prop ;
-
 GENERIC: handle-gesture ( gesture gadget -- ? )
 
 M: object handle-gesture
@@ -15,17 +13,42 @@ M: object handle-gesture
     [ "gestures" word-prop ] map
     assoc-stack dup [ call f ] [ 2drop t ] if ;
 
+: set-gestures ( class hash -- ) "gestures" set-word-prop ;
+
+: gesture-queue ( -- deque ) \ gesture-queue get ;
+
+GENERIC: send-queued-gesture ( request -- )
+
+TUPLE: send-gesture gesture gadget ;
+
+M: send-gesture send-queued-gesture
+    [ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
+
+: queue-gesture ( ... class -- )
+    boa gesture-queue push-front notify-ui-thread ; inline
+
 : send-gesture ( gesture gadget -- )
-    handle-gesture drop ;
+    \ send-gesture queue-gesture ;
 
-: each-gesture ( gesture seq -- )
+: each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
-    [ send-gesture ] with each ;
 
-: propagate-gesture ( gesture gadget -- )
+TUPLE: propagate-gesture gesture gadget ;
+
+M: propagate-gesture send-queued-gesture
+    [ gesture>> ] [ gadget>> ] bi
     [ handle-gesture ] with each-parent drop ;
 
-: user-input ( str gadget -- )
+: propagate-gesture ( gesture gadget -- )
-    '[ _ [ user-input* ] with each-parent drop ] unless-empty ;
+    \ propagate-gesture queue-gesture ;
+
+TUPLE: user-input string gadget ;
+
+M: user-input send-queued-gesture
+    [ string>> ] [ gadget>> ] bi
+    [ user-input* ] with each-parent drop ;
+
+: user-input ( string gadget -- )
+    '[ _ \ user-input queue-gesture ] unless-empty ;
 
 ! Gesture objects
 TUPLE: motion ;             C: <motion> motion

basis/ui/tools/debugger/debugger-docs.factor

@@ -8,7 +8,7 @@ HELP: <debugger>
     "Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
 } ;
 
-{ <debugger> debugger-window ui-try } related-words
+{ <debugger> debugger-window } related-words
 
 HELP: debugger-window
 { $values { "error" "an error" } }

basis/ui/tools/interactor/interactor.factor

@@ -164,7 +164,7 @@ M: interactor dispose drop ;
 : handle-interactive ( lines interactor -- quot/f ? )
     tuck try-parse {
         { [ dup quotation? ] [ nip t ] }
-        { [ dup not ] [ drop "\n" swap user-input f f ] }
+        { [ dup not ] [ drop "\n" swap user-input* f f ] }
         [ handle-parse-error f f ]
     } cond ;
 

basis/ui/tools/listener/listener.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: inspector help help.markup io io.styles
+USING: inspector help help.markup io io.styles kernel models
-kernel models namespaces parser quotations sequences  vocabs words
+namespaces parser quotations sequences vocabs words prettyprint
-prettyprint listener debugger threads boxes concurrency.flags
+listener debugger threads boxes concurrency.flags math arrays
-math arrays generic accessors combinators assocs fry ui.commands
+generic accessors combinators assocs fry ui.commands ui.gadgets
-ui.gadgets ui.gadgets.editors ui.gadgets.labelled
+ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
-ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
+ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
 ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
 ui.tools.browser ui.tools.interactor ui.tools.inspector
 ui.tools.workspace ;
@@ -13,20 +13,12 @@ IN: ui.tools.listener
 
 TUPLE: listener-gadget < track input output ;
 
-: listener-output, ( listener -- listener )
-    <scrolling-pane>
-    [ >>output ] [ <scroller> 1 track-add ] bi ;
-
 : listener-streams ( listener -- input output )
     [ input>> ] [ output>> <pane-stream> ] bi ;
 
 : <listener-input> ( listener -- gadget )
     output>> <pane-stream> <interactor> ;
 
-: listener-input, ( listener -- listener )
-    dup <listener-input>
-    [ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
-
 : welcome. ( -- )
     "If this is your first time with Factor, please read the " print
     "handbook" ($link) ". To see a list of keyboard shortcuts," print
@@ -109,7 +101,7 @@ M: engine-word word-completion-string
 
 : insert-word ( word -- )
     get-workspace listener>> input>>
-    [ >r word-completion-string r> user-input ]
+    [ >r word-completion-string r> user-input* ]
     [ interactor-use use-if-necessary ]
     2bi ;
 
@@ -156,11 +148,21 @@ M: engine-word word-completion-string
         [ wait-for-listener ]
     } cleave ;
 
+: init-listener ( listener -- listener )
+    <scrolling-pane> >>output
+    dup <listener-input> >>input ;
+
+: <listener-scroller> ( listener -- scroller )
+    <filled-pile>
+        over output>> add-gadget
+        swap input>> add-gadget
+    <scroller> ;
+
 : <listener-gadget> ( -- gadget )
     { 0 1 } listener-gadget new-track
         add-toolbar
-        listener-output,
+        init-listener
-        listener-input, ;
+        dup <listener-scroller> 1 track-add ;
 
 : listener-help ( -- ) "ui-listener" help-window ;
 
@@ -177,9 +179,9 @@ listener-gadget "misc" "Miscellaneous commands" {
 
 listener-gadget "toolbar" f {
     { f restart-listener }
-    { T{ key-down f { A+ } "a" } com-auto-use }
+    { T{ key-down f { A+ } "u" } com-auto-use }
-    { T{ key-down f { A+ } "c" } clear-output }
+    { T{ key-down f { A+ } "k" } clear-output }
-    { T{ key-down f { A+ } "C" } clear-stack }
+    { T{ key-down f { A+ } "K" } clear-stack }
     { T{ key-down f { C+ } "d" } com-end }
 } define-command-map
 

basis/ui/ui-docs.factor

@@ -47,11 +47,6 @@ HELP: (open-window)
 { $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
 { $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
 
-HELP: ui-try
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
-{ $notes "This is essentially a graphical variant of " { $link try } "." } ;
-
 ARTICLE: "ui-glossary" "UI glossary"
 { $table
     { "color specifier"

basis/ui/ui.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs io kernel math models namespaces make
 prettyprint dlists deques sequences threads sequences words
@@ -87,6 +87,7 @@ SYMBOL: ui-hook
 : init-ui ( -- )
     <dlist> \ graft-queue set-global
     <dlist> \ layout-queue set-global
+    <dlist> \ gesture-queue set-global
     V{ } clone windows set-global ;
 
 : restore-gadget-later ( gadget -- )
@@ -138,14 +139,22 @@ SYMBOL: ui-hook
 : notify-queued ( -- )
     graft-queue [ notify ] slurp-deque ;
 
+: send-queued-gestures ( -- )
+    gesture-queue [ send-queued-gesture ] slurp-deque ;
+
 : update-ui ( -- )
-    [ notify-queued layout-queued redraw-worlds ] assert-depth ;
+    [
+        [
+            notify-queued
+            layout-queued
+            redraw-worlds
+            send-queued-gestures
+        ] assert-depth
+    ] [ ui-error ] recover ;
 
 : ui-wait ( -- )
     10 sleep ;
 
-: ui-try ( quot -- ) [ ui-error ] recover ;
-
 SYMBOL: ui-thread
 
 : ui-running ( quot -- )
@@ -156,11 +165,9 @@ SYMBOL: ui-thread
     \ ui-running get-global ;
 
 : update-ui-loop ( -- )
-    ui-running? ui-thread get-global self eq? and [
+    [ ui-running? ui-thread get-global self eq? and ]
-        ui-notify-flag get lower-flag
+    [ ui-notify-flag get lower-flag update-ui ]
-        [ update-ui ] ui-try
+    [ ] while ;
-        update-ui-loop
-    ] when ;
 
 : start-ui-thread ( -- )
     [ self ui-thread set-global update-ui-loop ]

basis/ui/windows/windows.factor

@@ -381,11 +381,9 @@ SYMBOL: trace-messages?
 ! return 0 if you handle the message, else just let DefWindowProc return its val
 : ui-wndproc ( -- object )
     "uint" { "void*" "uint" "long" "long" } "stdcall" [
-        [
         pick
         trace-messages? get-global [ dup windows-message-name name>> print flush ] when
         wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
-        ] ui-try
      ] alien-callback ;
 
 : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;

basis/ui/x11/x11.factor

@@ -189,7 +189,7 @@ M: world client-event
 
 M: x11-ui-backend do-events
     wait-event dup XAnyEvent-window window dup
-    [ [ [ 2dup handle-event ] ui-try ] assert-depth ] when 2drop ;
+    [ handle-event ] [ 2drop ] if ;
 
 : x-clipboard@ ( gadget clipboard -- prop win )
     atom>> swap