1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs calendar combinators locals
4 source-files.errors colors.constants combinators.short-circuit
5 compiler.units help.tips concurrency.flags concurrency.mailboxes
6 continuations destructors documents documents.elements fry hashtables
7 help help.markup io io.styles kernel lexer listener math models sets
8 models.delay models.arrow namespaces parser prettyprint quotations
9 sequences strings threads vocabs vocabs.refresh vocabs.loader
10 vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
11 ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors
12 ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
13 ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
14 ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
15 ui.tools.listener.completion ui.tools.listener.popups
16 ui.tools.listener.history ui.images ui.tools.error-list
18 FROM: source-files.errors => all-errors ;
19 FROM: namespaces => set ;
22 ! If waiting is t, we're waiting for user input, and invoking
23 ! evaluate-input resumes the thread.
24 TUPLE: interactor < source-editor
25 output history flag mailbox thread waiting token-model word-model popup ;
27 : register-self ( interactor -- )
32 : interactor-continuation ( interactor -- continuation )
33 thread>> thread-continuation ;
35 : interactor-busy? ( interactor -- ? )
36 #! We're busy if there's no thread to resume.
39 [ thread>> dup [ thread-registered? ] when ]
44 M: interactor manifest>>
45 dup interactor-busy? [ drop f ] [
46 interactor-continuation name>>
47 manifest swap assoc-stack
50 : vocab-exists? ( name -- ? )
51 '[ _ { [ vocab ] [ find-vocab-root ] } 1|| ] [ drop f ] recover ;
53 GENERIC: (word-at-caret) ( token completion-mode -- obj )
55 M: vocab-completion (word-at-caret)
56 drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
58 M: word-completion (word-at-caret)
60 '[ _ _ search-manifest ] [ drop f ] recover
63 M: char-completion (word-at-caret)
66 : word-at-caret ( token interactor -- obj )
67 completion-mode (word-at-caret) ;
69 : <word-model> ( interactor -- model )
70 [ token-model>> 1/3 seconds <delay> ]
71 [ '[ _ word-at-caret ] ] bi
74 : <interactor> ( -- gadget )
77 dup one-word-elt <element-model> >>token-model
78 dup <word-model> >>word-model
79 dup model>> <history> >>history ;
82 [ call-next-method ] [ dup word-model>> add-connection ] bi ;
84 M: interactor ungraft*
85 [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
87 M: interactor model-changed
88 2dup word-model>> eq? [
90 [ 2drop ] [ [ value>> ] dip show-summary ] if
91 ] [ call-next-method ] if ;
93 M: interactor stream-element-type drop +character+ ;
95 GENERIC: (print-input) ( object -- )
97 M: input (print-input)
98 dup presented associate
99 [ string>> H{ { font-style bold } } format ] with-nesting nl ;
101 M: word (print-input)
104 "sans-serif" font-name set
106 ] H{ } make-assoc format . ;
108 : print-input ( object interactor -- )
109 output>> [ (print-input) ] with-output-stream* ;
111 : interactor-continue ( obj interactor -- )
112 mailbox>> mailbox-put ;
114 : interactor-finish ( interactor -- )
115 [ history>> history-add ] keep
117 [ clear-editor drop ]
118 [ model>> clear-undo drop ] 2tri ;
120 : interactor-eof ( interactor -- )
121 dup interactor-busy? [
122 f over interactor-continue
125 : evaluate-input ( interactor -- )
126 dup interactor-busy? [ drop ] [
127 [ control-value ] keep interactor-continue
130 : interactor-yield ( interactor -- obj )
131 dup thread>> self eq? [
134 [ flag>> raise-flag ]
135 [ mailbox>> mailbox-get ]
140 : interactor-read ( interactor -- lines )
141 [ interactor-yield ] [ interactor-finish ] bi ;
143 M: interactor stream-readln
144 interactor-read dup [ first ] when ;
146 : (call-listener) ( quot command listener -- )
147 input>> dup interactor-busy? [ 3drop ] [
149 [ nip interactor-continue ]
153 M: interactor stream-read
157 [ interactor-read dup [ "\n" join ] when ] dip short head
160 M: interactor stream-read-partial
163 M: interactor stream-read1
164 dup interactor-read {
165 { [ dup not ] [ 2drop f ] }
166 { [ dup empty? ] [ drop stream-read1 ] }
167 { [ dup first empty? ] [ 2drop CHAR: \n ] }
171 M: interactor dispose drop ;
173 : go-to-error ( interactor error -- )
174 [ line>> 1 - ] [ column>> ] bi 2array
178 TUPLE: listener-gadget < tool error-summary output scroller input ;
180 { 600 700 } listener-gadget set-tool-dim
182 : find-listener ( gadget -- listener )
183 [ listener-gadget? ] find-parent ;
185 : listener-streams ( listener -- input output )
186 [ input>> ] [ output>> <pane-stream> ] bi ;
188 : init-input/output ( listener -- listener )
190 [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
191 dup listener-streams >>output drop ;
193 : error-summary. ( -- )
195 H{ { table-gap { 3 3 } } } [
196 [ [ [ icon>> write-image ] with-cell ] each ] with-row
198 { "Press " { $command tool "common" show-error-list } " to view errors." }
202 : <error-summary> ( -- gadget )
203 error-list-model get [ drop error-summary. ] <pane-control>
204 COLOR: light-yellow <solid> >>interior ;
206 : init-error-summary ( listener -- listener )
207 <error-summary> >>error-summary
208 dup error-summary>> f track-add ;
210 : <listener-gadget> ( -- listener )
211 vertical listener-gadget new-track
214 dup output>> <scroller> >>scroller
215 dup scroller>> 1 track-add
218 M: listener-gadget focusable-child*
219 input>> dup popup>> or ;
221 : wait-for-listener ( listener -- )
222 #! Wait for the listener to start.
223 input>> flag>> wait-for-flag ;
225 : listener-busy? ( listener -- ? )
226 input>> interactor-busy? ;
228 : listener-window* ( -- listener )
230 dup "Listener" open-status-window ;
232 : listener-window ( -- )
233 [ listener-window* drop ] with-ui ;
235 \ listener-window H{ { +nullary+ t } } define-command
237 : (get-listener) ( quot -- listener )
243 [ input>> scroll>caret ]
244 [ input>> request-focus ] tri
246 ] [ listener-window* ] if* ; inline
248 : get-listener ( -- listener )
249 [ listener-gadget? ] (get-listener) ;
251 : show-listener ( -- )
254 \ show-listener H{ { +nullary+ t } } define-command
256 : get-ready-listener ( -- listener )
260 [ listener-busy? not ]
264 GENERIC: listener-input ( obj -- )
266 M: input listener-input string>> listener-input ;
268 M: string listener-input
270 [ set-editor-string ] [ request-focus ] bi ;
272 : call-listener ( quot command -- )
274 '[ _ _ _ dup wait-for-listener (call-listener) ]
275 "Listener call" spawn drop ;
277 M: listener-command invoke-command ( target command -- )
278 [ command-quot ] [ nip ] 2bi call-listener ;
280 M: listener-operation invoke-command ( target command -- )
281 [ operation-quot ] [ nip command>> ] 2bi call-listener ;
283 : eval-listener ( string -- )
284 get-listener input>> [ set-editor-string ] keep
287 : listener-run-files ( seq -- )
289 '[ _ [ run-file ] each ]
294 : com-end ( listener -- )
295 input>> interactor-eof ;
297 : clear-output ( listener -- )
298 output>> pane-clear ;
300 \ clear-output H{ { +listener+ t } } define-command
302 : clear-stack ( listener -- )
303 [ [ clear ] \ clear ] dip (call-listener) ;
305 : use-if-necessary ( word manifest -- )
306 2dup [ vocabulary>> ] dip and [
308 [ vocabulary>> use-vocab ]
309 [ dup name>> associate use-words ] bi
313 M: word accept-completion-hook
314 interactor>> manifest>> use-if-necessary ;
316 M: object accept-completion-hook 2drop ;
318 : quot-action ( interactor -- lines )
319 [ history>> history-add drop ] [ control-value ] [ select-all ] tri
320 [ parse-lines ] with-compilation-unit ;
322 : <debugger-popup> ( error continuation -- popup )
323 over compute-restarts [ hide-glass ] <debugger> "Error" <labeled-gadget> ;
325 : debugger-popup ( interactor error continuation -- )
326 [ one-line-elt ] 2dip <debugger-popup> show-listener-popup ;
328 : handle-parse-error ( interactor error -- )
329 dup lexer-error? [ 2dup go-to-error error>> ] when
330 error-continuation get
333 : try-parse ( lines interactor -- quot/error/f )
334 [ drop parse-lines-interactive ] [
337 dup error>> unexpected-eof? [ drop f ] when
341 : handle-interactive ( lines interactor -- quot/f ? )
342 [ nip ] [ try-parse ] 2bi {
343 { [ dup quotation? ] [ nip t ] }
344 { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
345 [ handle-parse-error f f ]
348 M: interactor stream-read-quot
349 [ interactor-yield ] keep {
350 { [ over not ] [ drop ] }
351 { [ over callable? ] [ drop ] }
353 [ handle-interactive ] keep swap
354 [ interactor-finish ] [ nip stream-read-quot ] if
358 : interactor-operation ( gesture interactor -- ? )
359 [ token-model>> value>> ] keep word-at-caret
360 [ nip ] [ gesture>operation ] 2bi
361 dup [ invoke-command f ] [ 2drop t ] if ;
363 M: interactor handle-gesture
365 { [ over key-gesture? not ] [ call-next-method ] }
366 { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
367 { [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
371 interactor "interactor" f {
372 { T{ key-down f f "RET" } evaluate-input }
373 { T{ key-down f { C+ } "k" } clear-editor }
376 interactor "completion" f {
377 { T{ key-down f f "TAB" } code-completion-popup }
378 { T{ key-down f { C+ } "p" } recall-previous }
379 { T{ key-down f { C+ } "n" } recall-next }
380 { T{ key-down f { C+ } "r" } history-completion-popup }
383 : introduction. ( -- )
385 { $strong "Press " { $snippet "F1" } " at any time for help." } print-content nl nl ;
387 : listener-thread ( listener -- )
388 dup listener-streams [
389 [ com-browse ] help-hook set
390 '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
395 "The listener has exited. To start it again, click “Restart Listener”." print
398 : start-listener-thread ( listener -- )
401 [ input>> register-self ]
404 ] "Listener" spawn drop ;
406 : restart-listener ( listener -- )
407 #! Returns when listener is ready to receive input.
411 [ input>> clear-editor ]
412 [ start-listener-thread ]
413 [ wait-for-listener ]
416 : com-help ( -- ) "help.home" com-browse ;
418 \ com-help H{ { +nullary+ t } } define-command
420 : com-auto-use ( -- )
421 auto-use? [ not ] change ;
423 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
425 listener-gadget "toolbar" f {
426 { f restart-listener }
427 { T{ key-down f { A+ } "u" } com-auto-use }
428 { T{ key-down f { A+ } "k" } clear-output }
429 { T{ key-down f { A+ } "K" } clear-stack }
430 { T{ key-down f { C+ } "d" } com-end }
431 { T{ key-down f f "F1" } com-help }
434 listener-gadget "scrolling"
435 "The listener's scroller can be scrolled from the keyboard."
437 { T{ key-down f { A+ } "UP" } com-scroll-up }
438 { T{ key-down f { A+ } "DOWN" } com-scroll-down }
439 { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
440 { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
443 listener-gadget "multi-touch" f {
444 { up-action refresh-all }
447 M: listener-gadget graft*
448 [ call-next-method ] [ restart-listener ] bi ;
450 M: listener-gadget ungraft*
451 [ com-end ] [ call-next-method ] bi ;