1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs calendar combinators locals
4 colors.constants combinators.short-circuit compiler.units
5 concurrency.flags concurrency.mailboxes continuations destructors
6 documents documents.elements fry hashtables help help.markup io
7 io.styles kernel lexer listener math models models.delay models.arrow
8 namespaces parser prettyprint quotations sequences strings threads
9 tools.vocabs vocabs vocabs.loader vocabs.parser words debugger ui ui.commands
10 ui.pens.solid ui.gadgets ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors
11 ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
12 ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
13 ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
14 ui.tools.listener.completion ui.tools.listener.popups
15 ui.tools.listener.history ;
18 ! If waiting is t, we're waiting for user input, and invoking
19 ! evaluate-input resumes the thread.
20 TUPLE: interactor < source-editor
21 output history flag mailbox thread waiting token-model word-model popup ;
23 : register-self ( interactor -- )
28 : interactor-continuation ( interactor -- continuation )
29 thread>> continuation>> value>> ;
31 : interactor-busy? ( interactor -- ? )
32 #! We're busy if there's no thread to resume.
34 [ thread>> dup [ thread-registered? ] when ]
39 M: interactor vocabs>>
40 dup interactor-busy? [ drop f ] [
42 interactor-continuation name>>
46 : vocab-exists? ( name -- ? )
47 '[ _ { [ vocab ] [ find-vocab-root ] } 1|| ] [ drop f ] recover ;
49 GENERIC: (word-at-caret) ( token completion-mode -- obj )
51 M: vocab-completion (word-at-caret)
52 drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
54 M: word-completion (word-at-caret)
55 vocabs>> assoc-stack ;
57 M: char-completion (word-at-caret)
60 : word-at-caret ( token interactor -- obj )
61 completion-mode (word-at-caret) ;
63 : <word-model> ( interactor -- model )
64 [ token-model>> 1/3 seconds <delay> ]
65 [ '[ _ word-at-caret ] ] bi
68 : <interactor> ( -- gadget )
71 dup one-word-elt <element-model> >>token-model
72 dup <word-model> >>word-model
73 dup model>> <history> >>history ;
76 [ call-next-method ] [ dup word-model>> add-connection ] bi ;
78 M: interactor ungraft*
79 [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
81 M: interactor model-changed
82 2dup word-model>> eq? [
84 [ 2drop ] [ [ value>> ] dip show-summary ] if
85 ] [ call-next-method ] if ;
87 M: interactor stream-element-type drop +character+ ;
89 GENERIC: (print-input) ( object -- )
91 M: input (print-input)
92 dup presented associate
93 [ string>> H{ { font-style bold } } format ] with-nesting nl ;
98 "sans-serif" font-name set
100 ] H{ } make-assoc format . ;
102 : print-input ( object interactor -- )
103 output>> [ (print-input) ] with-output-stream* ;
105 : interactor-continue ( obj interactor -- )
106 mailbox>> mailbox-put ;
108 : interactor-finish ( interactor -- )
109 [ history>> history-add ] keep
111 [ clear-editor drop ]
112 [ model>> clear-undo drop ] 2tri ;
114 : interactor-eof ( interactor -- )
115 dup interactor-busy? [
116 f over interactor-continue
119 : evaluate-input ( interactor -- )
120 dup interactor-busy? [ drop ] [
121 [ control-value ] keep interactor-continue
124 : interactor-yield ( interactor -- obj )
125 dup thread>> self eq? [
128 [ flag>> raise-flag ]
129 [ mailbox>> mailbox-get ]
134 : interactor-read ( interactor -- lines )
135 [ interactor-yield ] [ interactor-finish ] bi ;
137 M: interactor stream-readln
138 interactor-read dup [ first ] when ;
140 : (call-listener) ( quot command listener -- )
141 input>> dup interactor-busy? [ 3drop ] [
143 [ nip interactor-continue ]
147 M: interactor stream-read
151 [ interactor-read dup [ "\n" join ] when ] dip short head
154 M: interactor stream-read-partial
157 M: interactor stream-read1
158 dup interactor-read {
159 { [ dup not ] [ 2drop f ] }
160 { [ dup empty? ] [ drop stream-read1 ] }
161 { [ dup first empty? ] [ 2drop CHAR: \n ] }
165 M: interactor dispose drop ;
167 : go-to-error ( interactor error -- )
168 [ line>> 1- ] [ column>> ] bi 2array
172 TUPLE: listener-gadget < tool input output scroller ;
174 { 600 700 } listener-gadget set-tool-dim
176 : find-listener ( gadget -- listener )
177 [ listener-gadget? ] find-parent ;
179 : listener-streams ( listener -- input output )
180 [ input>> ] [ output>> <pane-stream> ] bi ;
182 : init-listener ( listener -- listener )
184 [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
185 dup listener-streams >>output drop ;
187 : <listener-gadget> ( -- gadget )
188 vertical listener-gadget new-track
191 dup output>> <scroller> >>scroller
192 dup scroller>> 1 track-add ;
194 M: listener-gadget focusable-child*
195 input>> dup popup>> or ;
197 : wait-for-listener ( listener -- )
198 #! Wait for the listener to start.
199 input>> flag>> wait-for-flag ;
201 : listener-busy? ( listener -- ? )
202 input>> interactor-busy? ;
204 : listener-window* ( -- listener )
206 dup "Listener" open-status-window ;
208 : listener-window ( -- )
209 [ listener-window* drop ] with-ui ;
211 \ listener-window H{ { +nullary+ t } } define-command
213 : (get-listener) ( quot -- listener )
219 [ input>> scroll>caret ]
220 [ input>> request-focus ] tri
222 ] [ listener-window* ] if* ; inline
224 : get-listener ( -- listener )
225 [ listener-gadget? ] (get-listener) ;
227 : show-listener ( -- )
230 \ show-listener H{ { +nullary+ t } } define-command
232 : get-ready-listener ( -- listener )
236 [ listener-busy? not ]
240 GENERIC: listener-input ( obj -- )
242 M: input listener-input string>> listener-input ;
244 M: string listener-input
246 [ set-editor-string ] [ request-focus ] bi ;
248 : call-listener ( quot command -- )
250 '[ _ _ _ dup wait-for-listener (call-listener) ]
251 "Listener call" spawn drop ;
253 M: listener-command invoke-command ( target command -- )
254 [ command-quot ] [ nip ] 2bi call-listener ;
256 M: listener-operation invoke-command ( target command -- )
257 [ operation-quot ] [ nip command>> ] 2bi call-listener ;
259 : eval-listener ( string -- )
260 get-listener input>> [ set-editor-string ] keep
263 : listener-run-files ( seq -- )
265 [ \ listener-run-files ] dip
266 '[ _ [ run-file ] each ] call-listener
269 : com-end ( listener -- )
270 input>> interactor-eof ;
272 : clear-output ( listener -- )
273 output>> pane-clear ;
275 \ clear-output H{ { +listener+ t } } define-command
277 : clear-stack ( listener -- )
278 [ [ clear ] \ clear ] dip (call-listener) ;
280 : use-if-necessary ( word seq -- )
281 2dup [ vocabulary>> ] dip and [
282 2dup [ assoc-stack ] keep = [ 2drop ] [
283 [ vocabulary>> vocab-words ] dip push
287 M: word accept-completion-hook
288 interactor>> vocabs>> use-if-necessary ;
290 M: object accept-completion-hook 2drop ;
292 : quot-action ( interactor -- lines )
293 [ history>> history-add drop ] [ control-value ] [ select-all ] tri
294 [ parse-lines ] with-compilation-unit ;
296 : <debugger-popup> ( error continuation -- popup )
297 over compute-restarts [ hide-glass ] <debugger> "Error" <labeled-gadget> ;
299 : debugger-popup ( interactor error continuation -- )
300 [ one-line-elt ] 2dip <debugger-popup> show-listener-popup ;
302 : handle-parse-error ( interactor error -- )
303 dup lexer-error? [ 2dup go-to-error error>> ] when
304 error-continuation get
307 : try-parse ( lines interactor -- quot/error/f )
308 [ drop parse-lines-interactive ] [
311 dup error>> unexpected-eof? [ drop f ] when
315 : handle-interactive ( lines interactor -- quot/f ? )
316 [ nip ] [ try-parse ] 2bi {
317 { [ dup quotation? ] [ nip t ] }
318 { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
319 [ handle-parse-error f f ]
322 M: interactor stream-read-quot
323 [ interactor-yield ] keep {
324 { [ over not ] [ drop ] }
325 { [ over callable? ] [ drop ] }
327 [ handle-interactive ] keep swap
328 [ interactor-finish ] [ nip stream-read-quot ] if
332 : interactor-operation ( gesture interactor -- ? )
333 [ token-model>> value>> ] keep word-at-caret
334 [ nip ] [ gesture>operation ] 2bi
335 dup [ invoke-command f ] [ 2drop t ] if ;
337 M: interactor handle-gesture
339 { [ over key-gesture? not ] [ call-next-method ] }
340 { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
341 { [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
345 interactor "interactor" f {
346 { T{ key-down f f "RET" } evaluate-input }
347 { T{ key-down f { C+ } "k" } clear-editor }
350 interactor "completion" f {
351 { T{ key-down f f "TAB" } code-completion-popup }
352 { T{ key-down f { C+ } "p" } recall-previous }
353 { T{ key-down f { C+ } "n" } recall-next }
354 { T{ key-down f { C+ } "r" } history-completion-popup }
358 "If this is your first time with Factor, please read the " print
359 "handbook" ($link) ". To see a list of keyboard shortcuts," print
360 "press F1." print nl ;
362 : listener-thread ( listener -- )
363 dup listener-streams [
364 [ com-browse ] help-hook set
365 '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
370 : start-listener-thread ( listener -- )
373 [ input>> register-self ]
376 ] "Listener" spawn drop ;
378 : restart-listener ( listener -- )
379 #! Returns when listener is ready to receive input.
383 [ input>> clear-editor ]
384 [ start-listener-thread ]
385 [ wait-for-listener ]
388 : listener-help ( -- ) "ui-listener" com-browse ;
390 \ listener-help H{ { +nullary+ t } } define-command
392 : com-auto-use ( -- )
393 auto-use? [ not ] change ;
395 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
397 listener-gadget "misc" "Miscellaneous commands" {
398 { T{ key-down f f "F1" } listener-help }
401 listener-gadget "toolbar" f {
402 { f restart-listener }
403 { T{ key-down f { A+ } "u" } com-auto-use }
404 { T{ key-down f { A+ } "k" } clear-output }
405 { T{ key-down f { A+ } "K" } clear-stack }
406 { T{ key-down f { C+ } "d" } com-end }
409 listener-gadget "scrolling"
410 "The listener's scroller can be scrolled from the keyboard."
412 { T{ key-down f { A+ } "UP" } com-scroll-up }
413 { T{ key-down f { A+ } "DOWN" } com-scroll-down }
414 { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
415 { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
418 listener-gadget "multi-touch" f {
419 { up-action refresh-all }
422 M: listener-gadget graft*
423 [ call-next-method ] [ restart-listener ] bi ;
425 M: listener-gadget ungraft*
426 [ com-end ] [ call-next-method ] bi ;