[ global [ "Error in print-error!" print drop ] bind ]
recover ;
+: print-error-and-restarts ( error -- )
+ print-error
+ restarts.
+ nl
+ "Type :help for debugging help." print flush ;
+
: try ( quot -- )
- [
- print-error
- restarts.
- nl
- "Type :help for debugging help." print flush
- ] recover ;
+ [ print-error-and-restarts ] recover ;
ERROR: assert got expect ;
SYMBOL: error-hook
+[ print-error-and-restarts ] error-hook set-global
+
: listen ( -- )
listener-hook get call prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
USING: namespaces io tools.test threads kernel
-concurrency.combinators math ;
+concurrency.combinators concurrency.promises locals math
+words ;
IN: threads.tests
3 "x" set
"i" tget
] parallel-map
] unit-test
+
+[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
+
+:: spawn-namespace-test ( -- )
+ [let | p [ <promise> ] g [ gensym ] |
+ [
+ g "x" set
+ [ "x" get p fulfill ] "B" spawn drop
+ ] with-scope
+ p ?promise g eq?
+ ] ;
+
+[ t ] [ spawn-namespace-test ] unit-test
[ sleep-queue heap-peek nip millis [-] ]
} cond ;
+DEFER: stop
+
<PRIVATE
: schedule-sleep ( thread dt -- )
[ ] while
drop ;
+: start ( namestack thread -- )
+ [
+ set-self
+ set-namestack
+ V{ } set-catchstack
+ { } set-retainstack
+ { } set-datastack
+ self quot>> [ call stop ] call-clear
+ ] 2 (throw) ;
+
+DEFER: next
+
+: no-runnable-threads ( -- * )
+ ! We should never be in a state where the only threads
+ ! are sleeping; the I/O wait thread is always runnable.
+ ! However, if it dies, we handle this case
+ ! semi-gracefully.
+ !
+ ! And if sleep-time outputs f, there are no sleeping
+ ! threads either... so WTF.
+ sleep-time [ die 0 ] unless* (sleep) next ;
+
+: (next) ( arg thread -- * )
+ f >>state
+ dup set-self
+ dup continuation>> ?box
+ [ nip continue-with ] [ drop start ] if ;
+
: next ( -- * )
expire-sleep-loop
run-queue dup dlist-empty? [
- ! We should never be in a state where the only threads
- ! are sleeping; the I/O wait thread is always runnable.
- ! However, if it dies, we handle this case
- ! semi-gracefully.
- !
- ! And if sleep-time outputs f, there are no sleeping
- ! threads either... so WTF.
- drop sleep-time [ die 0 ] unless* (sleep) next
+ drop no-runnable-threads
] [
- pop-back
- dup array? [ first2 ] [ f swap ] if dup set-self
- f >>state
- continuation>> box>
- continue-with
+ pop-back dup array? [ first2 ] [ f swap ] if (next)
] if ;
PRIVATE>
: stop ( -- )
- self dup exit-handler>> call
- unregister-thread next ;
+ self [ exit-handler>> call ] [ unregister-thread ] bi next ;
: suspend ( quot state -- obj )
[
- self continuation>> >box
- self (>>state)
- self swap call next
+ >r
+ >r self swap call
+ r> self (>>state)
+ r> self continuation>> >box
+ next
] callcc1 2nip ; inline
: yield ( -- ) [ resume ] f suspend drop ;
] when drop ;
: (spawn) ( thread -- )
- [
- resume-now [
- dup set-self
- dup register-thread
- V{ } set-catchstack
- { } set-retainstack
- >r { } set-datastack r>
- quot>> [ call stop ] call-clear
- ] 1 (throw)
- ] "spawn" suspend 2drop ;
+ [ register-thread ] [ namestack swap resume-with ] bi ;
: spawn ( quot name -- thread )
<thread> [ (spawn) ] keep ;
>r [ [ ] [ ] while ] curry r> spawn ;
: in-thread ( quot -- )
- >r datastack namestack r>
- [ >r set-namestack set-datastack r> call ] 3curry
+ >r datastack r>
+ [ >r set-datastack r> call ] 2curry
"Thread" spawn drop ;
GENERIC: error-in-thread ( error thread -- )
IN: ui.tools.interactor.tests
USING: ui.tools.interactor ui.gadgets.panes namespaces
ui.gadgets.editors concurrency.promises threads listener
-tools.test kernel calendar parser ;
+tools.test kernel calendar parser accessors ;
-[
- \ <interactor> must-infer
+\ <interactor> must-infer
+[
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
[ ] [ <promise> "promise" set ] unit-test
[
+ self "interactor" get (>>thread)
"interactor" get stream-read-quot "promise" get fulfill
] "Interactor test" spawn drop
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
] with-interactive-vocabs
+
+! Hang
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
+
+[ ] [ 1000 sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators continuations documents
- hashtables io io.styles kernel math
-math.vectors models namespaces parser prettyprint quotations
-sequences strings threads listener
-classes.tuple ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes calendar concurrency.flags ui.tools.workspace
-accessors math.order ;
+hashtables io io.styles kernel math math.order math.vectors
+models namespaces parser prettyprint quotations sequences
+strings threads listener classes.tuple ui.commands ui.gadgets
+ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
+ui.gestures definitions calendar concurrency.flags
+ui.tools.workspace accessors ;
IN: ui.tools.interactor
-TUPLE: interactor history output flag thread help ;
+! If waiting is t, we're waiting for user input, and invoking
+! evaluate-input resumes the thread.
+TUPLE: interactor output history flag thread waiting help ;
+
+: register-self ( interactor -- )
+ self >>thread drop ;
: interactor-continuation ( interactor -- continuation )
- interactor-thread box-value
- thread-continuation box-value ;
+ thread>> continuation>> value>> ;
: interactor-busy? ( interactor -- ? )
- interactor-thread box-full? not ;
+ #! We're busy if there's no thread to resume.
+ [ waiting>> ]
+ [ thread>> dup [ thread-registered? ] when ]
+ bi and not ;
: interactor-use ( interactor -- seq )
dup interactor-busy? [ drop f ] [
use swap
- interactor-continuation continuation-name
+ interactor-continuation name>>
assoc-stack
] if ;
-: init-caret-help ( interactor -- )
- dup editor-caret 1/3 seconds <delay>
- swap set-interactor-help ;
-
-: init-interactor-history ( interactor -- )
- V{ } clone swap set-interactor-history ;
-
-: init-interactor-state ( interactor -- )
- <flag> over set-interactor-flag
- <box> swap set-interactor-thread ;
+: <help-model> ( interactor -- model )
+ editor-caret 1/3 seconds <delay> ;
: <interactor> ( output -- gadget )
<source-editor>
interactor construct-editor
- tuck set-interactor-output
- dup init-interactor-history
- dup init-interactor-state
- dup init-caret-help ;
+ V{ } clone >>history
+ <flag> >>flag
+ dup <help-model> >>help
+ swap >>output ;
M: interactor graft*
- dup delegate graft*
- dup interactor-help add-connection ;
+ [ delegate graft* ] [ dup help>> add-connection ] bi ;
+
+M: interactor ungraft*
+ [ dup help>> remove-connection ] [ delegate ungraft ] bi ;
: word-at-loc ( loc interactor -- word )
over [
] if ;
M: interactor model-changed
- 2dup interactor-help eq? [
+ 2dup help>> eq? [
swap model-value over word-at-loc swap show-summary
] [
delegate model-changed
[ H{ { font-style bold } } format ] with-nesting ;
: interactor-input. ( string interactor -- )
- interactor-output [
+ output>> [
dup string? [ dup write-input nl ] [ short. ] if
] with-output-stream* ;
over empty? [ 2drop ] [ interactor-history push-new ] if ;
: interactor-continue ( obj interactor -- )
- interactor-thread box> resume-with ;
+ thread>> resume-with ;
: clear-input ( interactor -- ) gadget-model clear-doc ;
] unless drop ;
: interactor-yield ( interactor -- obj )
- [
- [ interactor-thread >box ] keep
- interactor-flag raise-flag
- ] curry "input" suspend ;
+ dup thread>> self eq? [
+ t >>waiting
+ [ [ flag>> raise-flag ] curry "input" suspend ] keep
+ f >>waiting
+ drop
+ ] [ drop f ] if ;
M: interactor stream-readln
[ interactor-yield ] keep interactor-finish
} cond ;
M: interactor pref-dim*
- 0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
+ [ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi
+ vmax ;
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads arrays generic ;
+threads arrays generic threads accessors listener ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
[ "dup" ] [
\ dup word-completion-string
] unit-test
-
+
[ "equal?" ]
[ \ array \ equal? method word-completion-string ] unit-test
[ ] [
"i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
] unit-test
-
+
[ t ] [
"i" get gadget-model doc-end
"i" get editor-caret* =
] unit-test
+
+ ! Race condition discovered by SimonRC
+ [ ] [
+ [
+ "listener" get input>>
+ [ stream-read-quot drop ]
+ [ stream-read-quot drop ] bi
+ ] "OH, HAI" spawn drop
+ ] unit-test
+
+ [ ] [ "listener" get clear-output ] unit-test
+
+ [ ] [ "listener" get restart-listener ] unit-test
+
+ [ ] [ 1000 sleep ] unit-test
+
+ [ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
[ input>> ] [ output>> <pane-stream> ] bi ;
: <listener-input> ( listener -- gadget )
-
listener-gadget-output <pane-stream> <interactor> ;
+
output>> <pane-stream> <interactor> ;
: listener-input, ( -- )
g <listener-input> g-> set-listener-gadget-input
"cookbook" ($link) "." print nl ;
M: listener-gadget focusable-child*
- listener-gadget-input ;
+ input>> ;
M: listener-gadget call-tool* ( input listener -- )
- >r input-string r> listener-gadget-input set-editor-string ;
+ >r string>> r> input>> set-editor-string ;
M: listener-gadget tool-scroller
- listener-gadget-output find-scroller ;
+ output>> find-scroller ;
: wait-for-listener ( listener -- )
#! Wait for the listener to start.
- listener-gadget-input interactor-flag wait-for-flag ;
+ input>> flag>> wait-for-flag ;
: workspace-busy? ( workspace -- ? )
- workspace-listener listener-gadget-input interactor-busy? ;
+ listener>> input>> interactor-busy? ;
: listener-input ( string -- )
- get-workspace
- workspace-listener
- listener-gadget-input set-editor-string ;
+ get-workspace listener>> input>> set-editor-string ;
: (call-listener) ( quot listener -- )
- listener-gadget-input interactor-call ;
+ input>> interactor-call ;
: call-listener ( quot -- )
- [ workspace-busy? not ] get-workspace* workspace-listener
+ [ workspace-busy? not ] get-workspace* listener>>
[ dup wait-for-listener (call-listener) ] 2curry
"Listener call" spawn drop ;
: eval-listener ( string -- )
get-workspace
- workspace-listener
- listener-gadget-input [ set-editor-string ] keep
+ listener>> input>> [ set-editor-string ] keep
evaluate-input ;
: listener-run-files ( seq -- )
] if ;
: com-end ( listener -- )
- listener-gadget-input interactor-eof ;
+ input>> interactor-eof ;
: clear-output ( listener -- )
- listener-gadget-output pane-clear ;
+ output>> pane-clear ;
\ clear-output H{ { +listener+ t } } define-command
: listener-thread ( listener -- )
dup listener-streams [
- [
- [ [ ui-listener-hook ] curry listener-hook set ]
- [ [ ui-error-hook ] curry error-hook set ]
- [ [ ui-inspector-hook ] curry inspector-hook set ] tri
- welcome.
- listener
- ] with-input-stream*
- ] with-output-stream* ;
+ [ [ ui-listener-hook ] curry listener-hook set ]
+ [ [ ui-error-hook ] curry error-hook set ]
+ [ [ ui-inspector-hook ] curry inspector-hook set ] tri
+ welcome.
+ listener
+ ] with-streams* ;
: start-listener-thread ( listener -- )
- [ listener-thread ] curry "Listener" spawn drop ;
+ [
+ [ input>> register-self ] [ listener-thread ] bi
+ ] curry "Listener" spawn drop ;
: restart-listener ( listener -- )
#! Returns when listener is ready to receive input.
- dup com-end dup clear-output
- dup start-listener-thread
- wait-for-listener ;
+ {
+ [ com-end ]
+ [ clear-output ]
+ [ start-listener-thread ]
+ [ wait-for-listener ]
+ } cleave ;
: init-listener ( listener -- )
f <model> swap set-listener-gadget-stack ;
[ default-gesture-handler ] [ 3drop f ] if ;
M: listener-gadget graft*
- dup delegate graft*
- dup listener-gadget-input interactor-thread ?box 2drop
- restart-listener ;
+ [ delegate graft* ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
- dup com-end
- delegate ungraft* ;
+ [ com-end ] [ delegate ungraft* ] bi ;
projects / factor.git / commitdiff