steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2008-11-21 23:01:20 -06:00
parent b6d6849394
commit fb918ab756
14 changed files with 112 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/ui/cocoa/cocoa.factor
View File

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

55
basis/ui/cocoa/views/views.factor
View File

@ -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
] ui-try
]
[ 2drop dup view-dim swap window (>>dim) yield ]
}
{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
[ 3drop ]
}
{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }

2
basis/ui/gadgets/editors/editors.factor
View File

@ -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 ;

8
basis/ui/gadgets/gadgets.factor
View File

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

8
basis/ui/gadgets/panes/panes-tests.factor
View File

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

6
basis/ui/gestures/gestures-docs.factor
View File

@ -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." } ;

41
basis/ui/gestures/gestures.factor
View File

@ -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 -- )
[ send-gesture ] with each ;
: each-gesture ( gesture seq -- ) [ 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 -- )
'[ _ [ user-input* ] with each-parent drop ] unless-empty ;
: propagate-gesture ( gesture gadget -- )
\ 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

2
basis/ui/tools/debugger/debugger-docs.factor
View File

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

2
basis/ui/tools/interactor/interactor.factor
View File

@ -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 ;

42
basis/ui/tools/listener/listener.factor
View File

@ -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
kernel models namespaces parser quotations sequences vocabs words
prettyprint listener debugger threads boxes concurrency.flags
math arrays generic accessors combinators assocs fry ui.commands
ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
USING: inspector help help.markup io io.styles kernel models
namespaces parser quotations sequences vocabs words prettyprint
listener debugger threads boxes concurrency.flags math arrays
generic accessors combinators assocs fry ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
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,
listener-input, ;
init-listener
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+ } "c" } clear-output }
{ T{ key-down f { A+ } "C" } clear-stack }
{ T{ key-down f { A+ } "u" } com-auto-use }
{ T{ key-down f { A+ } "k" } clear-output }
{ T{ key-down f { A+ } "K" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
} define-command-map

5
basis/ui/ui-docs.factor
View File

@ -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"

25
basis/ui/ui.factor
View File

@ -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-notify-flag get lower-flag
[ update-ui ] ui-try
update-ui-loop
] when ;
[ ui-running? ui-thread get-global self eq? and ]
[ ui-notify-flag get lower-flag update-ui ]
[ ] while ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]

8
basis/ui/windows/windows.factor
View File

@ -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
pick
trace-messages? get-global [ dup windows-message-name name>> print flush ] when
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
] alien-callback ;
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;

2
basis/ui/x11/x11.factor
View File

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