-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs io kernel math models namespaces make dlists
-deques sequences threads words continuations init
-combinators combinators.short-circuit hashtables concurrency.flags
-sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
-strings ;
+USING: accessors arrays assocs boxes classes.tuple
+classes.tuple.parser combinators combinators.short-circuit
+concurrency.flags concurrency.promises continuations deques
+destructors dlists kernel lexer make math math.functions
+namespaces parser sequences sets strings threads ui.backend
+ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
+ui.render vectors vocabs.parser words ;
IN: ui
<PRIVATE
-! Assoc mapping aliens to gadgets
-SYMBOL: windows
+! Assoc mapping aliens to worlds
+SYMBOL: worlds
-: window ( handle -- world ) windows get-global at ;
-
-: window-focus ( handle -- gadget ) window world-focus ;
+: window ( handle -- world ) worlds get-global at ;
: register-window ( world handle -- )
- #! Add the new window just below the topmost window. Why?
- #! So that if the new window doesn't actually receive focus
- #! (eg, we're using focus follows mouse and the mouse is not
- #! in the new window when it appears) Factor doesn't get
- #! confused and send workspace operations to the new window,
- #! etc.
- swap 2array windows get-global push
- windows get-global dup length 1 >
+ ! Add the new window just below the topmost window. Why?
+ ! So that if the new window doesn't actually receive focus
+ ! (eg, we're using focus follows mouse and the mouse is not
+ ! in the new window when it appears) Factor doesn't get
+ ! confused and send workspace operations to the new window,
+ ! etc.
+ swap 2array worlds get-global push
+ worlds get-global dup length 1 >
[ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
- windows [ [ first = not ] with filter ] change-global ;
+ worlds [ [ first = ] with reject ] change-global ;
: raised-window ( world -- )
- windows get-global
+ worlds get-global
[ [ second eq? ] with find drop ] keep
[ nth ] [ remove-nth! drop ] [ nip ] 2tri push ;
[ [ title>> ] keep set-title ]
[ begin-world ]
[ resize-world ]
- [ t >>active? drop ]
[ request-focus ]
- } cleave ;
+ } cleave gl-init ;
: clean-up-broken-window ( world -- )
[
M: world graft*
[ (open-window) ]
[
- [ set-up-window ]
- [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
+ [ set-up-window ] [ ] [ clean-up-broken-window ] cleanup
] bi ;
-: reset-world ( world -- )
- #! This is used when a window is being closed, but also
- #! when restoring saved worlds on image startup.
- f >>handle unfocus-world ;
+: dispose-window-resources ( world -- )
+ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ;
-: (ungraft-world) ( world -- )
+M: world ungraft*
{
[ set-gl-context ]
[ text-handle>> [ dispose ] when* ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
[ end-world ]
- [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
+ [ dispose-window-resources ]
+ [ unfocus-world ]
+ [ [ (close-window) f ] change-handle drop ]
+ [ promise>> t swap fulfill ]
} cleave ;
-M: world ungraft*
- [ (ungraft-world) ]
- [ handle>> (close-window) ]
- [ reset-world ] tri ;
-
: init-ui ( -- )
+ <box> drag-timer set-global
+ f hand-gadget set-global
+ f hand-clicked set-global
+ f hand-world set-global
+ f world set-global
<dlist> \ graft-queue set-global
- <dlist> \ layout-queue set-global
+ 100 <vector> \ layout-queue set-global
<dlist> \ gesture-queue set-global
- V{ } clone windows set-global ;
-
-: restore-gadget-later ( gadget -- )
- dup graft-state>> {
- { { f f } [ ] }
- { { f t } [ ] }
- { { t t } [ { f f } >>graft-state ] }
- { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
- } case graft-later ;
-
-: restore-gadget ( gadget -- )
- dup restore-gadget-later
- children>> [ restore-gadget ] each ;
-
-: restore-world ( world -- )
- {
- [ reset-world ]
- [ f >>text-handle f >>images drop ]
- [ restore-gadget ]
- } cleave ;
+ V{ } clone worlds set-global ;
: update-hand ( world -- )
dup hand-world get-global eq?
[ hand-loc get-global swap move-hand ] [ drop ] if ;
+: slurp-vector ( ... seq quot: ( ... elt -- ... ) -- ... )
+ over '[ _ empty? not ] -rot '[ _ pop @ ] while ; inline
+
: layout-queued ( -- seq )
- [
+ layout-queue [
in-layout? on
- layout-queue [
- dup layout find-world [ , ] when*
- ] slurp-deque
- ] { } make prune ;
+ [ dup layout find-world [ , ] when* ] slurp-vector
+ ] { } make members ;
: redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ;
redraw-worlds
send-queued-gestures ;
-SYMBOL: ui-thread
-
-: ui-running ( quot -- )
- t \ ui-running set-global
- [ f \ ui-running set-global ] [ ] cleanup ; inline
+SYMBOL: ui-running
PRIVATE>
-: find-window ( quot -- world )
- [ windows get values ] dip
+: find-windows ( quot: ( world -- ? ) -- seq )
+ [ worlds get-global values ] dip
'[ dup children>> [ ] [ nip first ] if-empty @ ]
- find-last nip ; inline
+ filter ; inline
+
+: find-window ( quot: ( world -- ? ) -- world/f )
+ find-windows ?last ; inline
: ui-running? ( -- ? )
- \ ui-running get-global ;
+ ui-running get-global ;
<PRIVATE
+SYMBOL: ui-thread
+
: update-ui-loop ( -- )
- #! Note the logic: if update-ui fails, we open an error window
- #! and run one iteration of update-ui. If that also fails, well,
- #! the whole UI subsystem is broken so we exit out of the
- #! update-ui-loop.
+ ! Note the logic: if update-ui fails, we open an error window and
+ ! run one iteration of update-ui. If that also fails, well, the
+ ! whole UI subsystem is broken so we throw the error to terminate
+ ! the update-ui-loop.
[ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
[
ui-notify-flag get lower-flag
- [ update-ui ] [ ui-error update-ui ] recover
+ [ update-ui ] [
+ [ ui-error update-ui ] [
+ stop-event-loop nip rethrow
+ ] recover
+ ] recover
] while ;
: start-ui-thread ( -- )
: start-ui ( quot -- )
call( -- ) notify-ui-thread start-ui-thread ;
-: restore-windows ( -- )
- [
- windows get [ values ] [ delete-all ] bi
- [ restore-world ] each
- forget-rollover
- ] (with-ui) ;
-
-: restore-windows? ( -- ? )
- windows get empty? not ;
-
: ?attributes ( gadget title/attributes -- attributes )
- dup string? [ world-attributes new swap >>title ] [ clone ] if
+ dup string? [ <world-attributes> swap >>title ] [ clone ] if
swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
PRIVATE>
: open-world-window ( world -- )
- dup pref-dim >>dim dup relayout graft ;
+ dup pref-dim [ ceiling ] map >>dim dup relayout graft ;
: open-window* ( gadget title/attributes -- window )
?attributes <world> [ open-world-window ] keep ;
find-world raise-window* ;
: topmost-window ( -- world )
- windows get last second ;
+ worlds get-global last second ;
HOOK: close-window ui-backend ( gadget -- )
M: object close-window
find-world [ ungraft ] when* ;
-[
- f \ ui-running set-global
+STARTUP-HOOK: [
+ f ui-running set-global
<flag> ui-notify-flag set-global
-] "ui" add-init-hook
-
-: with-ui ( quot -- )
- ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
+]
+
+HOOK: resize-window ui-backend ( world dim -- )
+M: object resize-window 2drop ;
+
+: relayout-window ( gadget -- )
+ [ relayout ]
+ [ find-world [ dup pref-dim resize-window ] when* ] bi ;
+
+: with-ui ( quot: ( -- ) -- )
+ ui-running? [ call( -- ) ] [
+ t ui-running set-global '[
+ [ init-ui @ ] (with-ui)
+ ] [
+ f ui-running set-global
+ ! Give running ui threads a chance to finish.
+ notify-ui-thread yield
+ ] finally
+ ] if ;
HOOK: beep ui-backend ( -- )
+
+HOOK: system-alert ui-backend ( caption text -- )
+
+: parse-window-attributes ( class -- attributes )
+ "{" expect dup all-slots parse-tuple-literal-slots ;
+
+: define-window ( word attributes quot -- )
+ '[ [ f _ clone @ open-window ] with-ui ] ( -- ) define-declared ;
+
+SYNTAX: WINDOW:
+ scan-new-word
+ world-attributes parse-window-attributes
+ parse-definition
+ define-window ;
+
+SYNTAX: MAIN-WINDOW:
+ scan-new-word
+ world-attributes parse-window-attributes
+ parse-definition
+ [ define-window ] [ 2drop current-vocab main<< ] 3bi ;
projects / factor.git / blobdiff