1 ! Copyright (C) 2006, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs combinators continuations documents
4 hashtables io io.styles kernel math math.order math.vectors
5 models models.delay namespaces parser lexer prettyprint
6 quotations sequences strings threads listener classes.tuple
7 ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
8 ui.gadgets.presentations ui.gadgets.worlds ui.gestures
9 definitions calendar concurrency.flags concurrency.mailboxes
10 ui.tools.workspace accessors sets destructors fry ;
11 IN: ui.tools.interactor
13 ! If waiting is t, we're waiting for user input, and invoking
14 ! evaluate-input resumes the thread.
15 TUPLE: interactor < source-editor
16 output history flag mailbox thread waiting help ;
18 : register-self ( interactor -- )
23 : interactor-continuation ( interactor -- continuation )
24 thread>> continuation>> value>> ;
26 : interactor-busy? ( interactor -- ? )
27 #! We're busy if there's no thread to resume.
29 [ thread>> dup [ thread-registered? ] when ]
32 : interactor-use ( interactor -- seq )
33 dup interactor-busy? [ drop f ] [
35 interactor-continuation name>>
39 : <help-model> ( interactor -- model ) caret>> 1/3 seconds <delay> ;
41 : <interactor> ( output -- gadget )
45 dup <help-model> >>help
49 [ call-next-method ] [ dup help>> add-connection ] bi ;
51 M: interactor ungraft*
52 [ dup help>> remove-connection ] [ call-next-method ] bi ;
54 : word-at-loc ( loc interactor -- word )
56 [ model>> T{ one-word-elt } elt-string ] keep
57 interactor-use assoc-stack
62 M: interactor model-changed
64 swap value>> over word-at-loc swap show-summary
69 : write-input ( string input -- )
70 <input> presented associate
71 [ H{ { font-style bold } } format ] with-nesting ;
73 : interactor-input. ( string interactor -- )
75 dup string? [ dup write-input nl ] [ short. ] if
76 ] with-output-stream* ;
78 : add-interactor-history ( str interactor -- )
79 over empty? [ 2drop ] [ history>> adjoin ] if ;
81 : interactor-continue ( obj interactor -- )
82 mailbox>> mailbox-put ;
84 : clear-input ( interactor -- )
85 #! The with-datastack is a kludge to make it infer. Stupid.
86 model>> 1array [ clear-doc ] with-datastack drop ;
88 : interactor-finish ( interactor -- )
89 [ editor-string ] keep
90 [ interactor-input. ] 2keep
91 [ add-interactor-history ] keep
94 : interactor-eof ( interactor -- )
95 dup interactor-busy? [
96 f over interactor-continue
99 : evaluate-input ( interactor -- )
100 dup interactor-busy? [
101 dup control-value over interactor-continue
104 : interactor-yield ( interactor -- obj )
105 dup thread>> self eq? [
108 [ flag>> raise-flag ]
109 [ mailbox>> mailbox-get ]
114 : interactor-read ( interactor -- lines )
115 [ interactor-yield ] [ interactor-finish ] bi ;
117 M: interactor stream-readln
118 interactor-read dup [ first ] when ;
120 : interactor-call ( quot interactor -- )
121 dup interactor-busy? [
122 2dup interactor-input.
123 2dup interactor-continue
126 M: interactor stream-read
130 [ interactor-read dup [ "\n" join ] when ] dip short head
133 M: interactor stream-read-partial
136 M: interactor stream-read1
137 dup interactor-read {
138 { [ dup not ] [ 2drop f ] }
139 { [ dup empty? ] [ drop stream-read1 ] }
140 { [ dup first empty? ] [ 2drop CHAR: \n ] }
144 M: interactor dispose drop ;
146 : go-to-error ( interactor error -- )
147 [ line>> 1- ] [ column>> ] bi 2array
151 : handle-parse-error ( interactor error -- )
152 dup lexer-error? [ 2dup go-to-error error>> ] when
153 swap find-workspace debugger-popup ;
155 : try-parse ( lines interactor -- quot/error/f )
157 drop parse-lines-interactive
161 dup error>> unexpected-eof? [ drop f ] when
165 : handle-interactive ( lines interactor -- quot/f ? )
167 { [ dup quotation? ] [ nip t ] }
168 { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
169 [ handle-parse-error f f ]
172 M: interactor stream-read-quot
173 [ interactor-yield ] keep {
174 { [ over not ] [ drop ] }
175 { [ over callable? ] [ drop ] }
177 [ handle-interactive ] keep swap
178 [ interactor-finish ] [ nip stream-read-quot ] if
182 interactor "interactor" f {
183 { T{ key-down f f "RET" } evaluate-input }
184 { T{ key-down f { C+ } "k" } clear-input }