-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
continuations combinators compiler compiler.alien kernel math
namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private parser lexer init core-foundation fry
- generalizations specialized-arrays.direct.alien ;
+ generalizations specialized-arrays.direct.alien call ;
IN: cocoa.messages
: make-sender ( method function -- quot )
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
- drop over class-init-hooks get at [ assert-depth ] when*
+ drop over class-init-hooks get at [ call( -- ) ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
drop "void*"
] unless ;
+ERROR: no-objc-type name ;
+
+: decode-type ( ch -- ctype )
+ 1string dup objc>alien-types get at
+ [ ] [ no-objc-type ] ?if ;
+
: (parse-objc-type) ( i string -- ctype )
[ [ 1+ ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
- [ 2nip 1string objc>alien-types get at ]
+ [ 2nip decode-type ]
} cond ;
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs io kernel math models namespaces make
-dlists deques sequences threads sequences words ui.gadgets
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend
-ui.render continuations init combinators hashtables
-concurrency.flags sets accessors calendar call ;
+USING: arrays assocs io kernel math models namespaces make dlists
- deques sequences threads sequences words continuations init
++deques sequences threads sequences words continuations init call
+combinators hashtables concurrency.flags sets accessors calendar fry
+ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gadgets.tracks
+ui.gestures ui.backend ui.render ui.text ui.text.private ;
IN: ui
! Assoc mapping aliens to gadgets
: focus-gestures ( new old -- )
drop-prefix <reversed>
- T{ lose-focus } swap each-gesture
- T{ gain-focus } swap each-gesture ;
+ lose-focus swap each-gesture
+ gain-focus swap each-gesture ;
: focus-world ( world -- )
t >>focused?
[ f >>handle drop ] tri ;
: (ungraft-world) ( world -- )
- [ free-fonts ]
- [ hand-clicked close-global ]
- [ hand-gadget close-global ] tri ;
+ {
+ [ handle>> select-gl-context ]
+ [ fonts>> free-fonts ]
+ [ hand-clicked close-global ]
+ [ hand-gadget close-global ]
+ } cleave ;
M: world ungraft*
[ (ungraft-world) ]
windows get values
[ gadget-child swap call ] with find-last nip ; inline
-SYMBOL: ui-hook
-
: init-ui ( -- )
<dlist> \ graft-queue set-global
<dlist> \ layout-queue set-global
: restore-world ( world -- )
dup reset-world restore-gadget ;
-: restore-windows ( -- )
- windows get [ values ] keep delete-all
- [ restore-world ] each
- forget-rollover ;
-
-: restore-windows? ( -- ? )
- windows get empty? not ;
-
: update-hand ( world -- )
dup hand-world get-global eq?
[ hand-loc get-global swap move-hand ] [ drop ] if ;
: redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ;
-: notify ( gadget -- )
- dup graft-state>>
- [ first { f f } { t t } ? >>graft-state ] keep
- {
- { { f t } [ dup activate-control graft* ] }
- { { t f } [ dup deactivate-control ungraft* ] }
- } case ;
-
-: notify-queued ( -- )
- graft-queue [ notify ] slurp-deque ;
-
: send-queued-gestures ( -- )
gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
layout-queued
redraw-worlds
send-queued-gestures
- ] assert-depth
+ ] call( -- )
] [ ui-error ] recover ;
SYMBOL: ui-thread
M: object close-window
find-world [ ungraft ] when* ;
-: start-ui ( -- )
- restore-windows? [
- restore-windows
- ] [
- init-ui ui-hook get call
- ] if
- notify-ui-thread start-ui-thread ;
+: start-ui ( quot -- )
+ call notify-ui-thread start-ui-thread ;
[
f \ ui-running set-global
<flag> ui-notify-flag set-global
] "ui" add-init-hook
-HOOK: ui ui-backend ( -- )
+HOOK: (with-ui) ui-backend ( quot -- )
+
+: restore-windows ( -- )
+ [
+ windows get [ values ] [ delete-all ] bi
+ [ restore-world ] each
+ forget-rollover
+ ] (with-ui) ;
-MAIN: ui
+: restore-windows? ( -- ? )
+ windows get empty? not ;
: with-ui ( quot -- )
- ui-running? [
- call
- ] [
- f windows set-global
- [
- ui-hook set
- ui
- ] with-scope
- ] if ;
+ ui-running? [ call ] [ '[ init-ui @ ] (with-ui) ] if ;
+
+HOOK: beep ui-backend ( -- )