1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs calendar combinators
4 combinators.short-circuit concurrency.flags
5 concurrency.mailboxes continuations destructors documents
6 documents.elements fonts fry hashtables help help.markup
7 help.tips io io.styles kernel lexer listener literals locals
8 math models models.arrow models.delay namespaces parser
9 prettyprint sequences source-files.errors strings system threads
10 tools.errors.model ui ui.commands ui.gadgets ui.gadgets.editors
11 ui.gadgets.glass ui.gadgets.labeled ui.gadgets.panes
12 ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.theme
13 ui.gadgets.toolbar ui.gadgets.tracks ui.gestures ui.operations
14 ui.pens.solid ui.tools.browser ui.tools.common ui.tools.debugger
15 ui.tools.error-list ui.tools.listener.completion
16 ui.tools.listener.history ui.tools.listener.popups vocabs
17 vocabs.loader vocabs.parser vocabs.refresh words ;
20 TUPLE: interactor < source-editor
21 output history flag mailbox thread waiting token-model word-model popup ;
23 INSTANCE: interactor input-stream
25 : register-self ( interactor -- )
30 : interactor-continuation ( interactor -- continuation )
31 thread>> thread-continuation ;
33 : interactor-busy? ( interactor -- ? )
36 [ thread>> dup [ thread-registered? ] when ]
41 M: interactor manifest>>
42 dup interactor-busy? [ drop f ] [
43 interactor-continuation name>>
44 manifest swap assoc-stack
47 : vocab-exists? ( name -- ? )
48 '[ _ { [ lookup-vocab ] [ find-vocab-root ] } 1|| ] [ drop f ] recover ;
50 GENERIC: (word-at-caret) ( token completion-mode -- obj )
52 M: vocab-completion (word-at-caret)
53 drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
55 M: word-completion (word-at-caret)
57 '[ _ _ search-manifest ] [ drop f ] recover
60 M: char-completion (word-at-caret) 2drop f ;
62 M: path-completion (word-at-caret) 2drop f ;
64 M: color-completion (word-at-caret) 2drop f ;
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 )
78 dup one-word-elt <element-model> >>token-model
79 dup <word-model> >>word-model
80 dup model>> <history> >>history ;
83 [ call-next-method ] [ dup word-model>> add-connection ] bi ;
85 M: interactor ungraft*
86 [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
88 M: interactor model-changed
89 2dup word-model>> eq? [
91 [ 2drop ] [ [ value>> ] dip show-summary ] if
92 ] [ call-next-method ] if ;
94 M: interactor stream-element-type drop +character+ ;
96 GENERIC: (print-input) ( object -- )
98 SYMBOL: listener-input-style
101 { foreground $ text-color }
102 } listener-input-style set-global
104 SYMBOL: listener-word-style
106 { font-name "sans-serif" }
108 { foreground $ text-color }
109 } listener-word-style set-global
111 M: input (print-input)
112 dup presented associate [
113 string>> listener-input-style get-global format
116 M: word (print-input)
117 "Command: " listener-word-style get-global format . ;
119 : print-input ( object interactor -- )
120 output>> [ (print-input) ] with-output-stream* ;
122 : interactor-continue ( obj interactor -- )
123 mailbox>> mailbox-put ;
125 : interactor-finish ( interactor -- )
126 [ history>> history-add ] keep
128 [ clear-editor drop ]
129 [ model>> clear-undo drop ] 2tri ;
131 : interactor-eof ( interactor -- )
132 dup interactor-busy? [
133 f over interactor-continue
136 : evaluate-input ( interactor -- )
137 dup interactor-busy? [ drop ] [
138 [ control-value ] keep interactor-continue
141 : interactor-yield ( interactor -- obj )
142 dup thread>> self eq? [
145 [ flag>> raise-flag ]
146 [ mailbox>> mailbox-get ]
151 : interactor-read ( interactor -- lines )
152 [ interactor-yield ] [ interactor-finish ] bi ;
154 M: interactor stream-readln
155 interactor-read dup [ first ] when ;
157 : (call-listener) ( quot command listener -- )
158 input>> dup interactor-busy? [ 3drop ] [
160 [ nip interactor-continue ]
164 M:: interactor stream-read-unsafe ( n buf interactor -- count )
167 interactor interactor-read dup [ "\n" join ] when
168 n short [ head-slice 0 buf copy ] keep
171 M: interactor stream-read1
172 dup interactor-read {
173 { [ dup not ] [ 2drop f ] }
174 { [ dup empty? ] [ drop stream-read1 ] }
175 { [ dup first empty? ] [ 2drop CHAR: \n ] }
179 M: interactor stream-read-until ( seps stream -- seq sep/f )
182 "\n" join CHAR: \n suffix
183 [ _ member? ] dupd find
184 [ [ head ] when* ] dip dup not
186 ] [ drop ] produce swap [ concat "" prepend-as ] dip ;
188 M: interactor dispose drop ;
190 : go-to-error ( interactor error -- )
191 [ line>> 1 - ] [ column>> ] bi 2array
195 TUPLE: listener-gadget < tool error-summary output scroller input ;
197 { 600 700 } listener-gadget set-tool-dim
199 : listener-streams ( listener -- input output )
200 [ input>> ] [ output>> <pane-stream> ] bi ;
202 : init-input/output ( listener -- listener )
204 [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
205 dup listener-streams >>output drop ;
207 : error-summary. ( -- )
209 H{ { table-gap { 3 3 } } } [
210 [ [ [ icon>> write-image ] with-cell ] each ] with-row
213 { "Press " { $command tool "common" show-error-list } " to view errors." }
217 : <error-summary> ( -- gadget )
218 error-list-model get [ drop error-summary. ] <pane-control>
219 error-summary-background <solid> >>interior ;
221 : init-error-summary ( listener -- listener )
222 <error-summary> >>error-summary
223 dup error-summary>> f track-add ;
225 : add-listener-area ( listener -- listener )
226 dup output>> margins <scroller> >>scroller
227 dup scroller>> white-interior 1 track-add ;
229 : <listener-gadget> ( -- listener )
230 vertical listener-gadget new-track with-lines
236 M: listener-gadget focusable-child*
237 input>> dup popup>> or ;
239 : wait-for-listener ( listener -- )
240 input>> flag>> 5 seconds wait-for-flag-timeout ;
242 : listener-busy? ( listener -- ? )
243 input>> interactor-busy? ;
245 : listener-window* ( -- listener )
247 dup "Listener" open-status-window ;
249 : listener-window ( -- )
250 [ listener-window* drop ] with-ui ;
252 \ listener-window H{ { +nullary+ t } } define-command
254 : (get-listener) ( quot -- listener )
260 [ input>> scroll>caret ]
261 [ input>> request-focus ] tri
263 ] [ listener-window* ] if* ; inline
265 : get-listener ( -- listener )
266 [ listener-gadget? ] (get-listener) ;
268 : show-listener ( -- )
271 \ show-listener H{ { +nullary+ t } } define-command
273 : get-ready-listener ( -- listener )
277 [ listener-busy? not ]
281 GENERIC: listener-input ( obj -- )
283 M: input listener-input string>> listener-input ;
285 M: string listener-input
287 [ set-editor-string ] [ request-focus ] bi ;
289 : call-listener ( quot command -- )
291 '[ _ _ _ dup wait-for-listener (call-listener) ]
292 "Listener call" spawn drop ;
294 M: listener-command invoke-command ( target command -- )
295 [ command-quot ] [ nip ] 2bi call-listener ;
297 M: listener-operation invoke-command ( target command -- )
298 [ operation-quot ] [ nip command>> ] 2bi call-listener ;
300 : eval-listener ( string -- )
301 get-listener input>> [ set-editor-string ] keep
304 : listener-run-files ( seq -- )
306 '[ _ [ run-file ] each ]
311 : com-end ( listener -- )
312 input>> interactor-eof ;
314 : clear-output ( listener -- )
315 output>> pane-clear ;
317 \ clear-output H{ { +listener+ t } } define-command
319 : clear-stack ( listener -- )
320 [ [ clear ] \ clear ] dip (call-listener) ;
322 : use-if-necessary ( word manifest -- )
323 2dup [ vocabulary>> ] dip and [
325 [ vocabulary>> use-vocab ]
326 [ dup name>> associate use-words ] bi
330 M: word accept-completion-hook
331 interactor>> manifest>> use-if-necessary ;
333 M: object accept-completion-hook 2drop ;
335 : quot-action ( interactor -- lines )
336 [ history>> history-add drop ] [ control-value ] [ select-all ] tri
337 parse-lines-interactive ;
339 : do-recall? ( table error -- ? )
340 [ selection>> value>> not ] [ lexer-error? ] bi* and ;
342 : recall-lexer-error ( interactor error -- )
343 over recall-previous go-to-error ;
345 : make-restart-hook-quot ( error interactor -- quot )
348 _ do-recall? [ _ _ recall-lexer-error ] when
351 : frame-debugger ( debugger -- labeled )
352 "Error" debugger-color <framed-labeled> ;
354 :: <debugger-popup> ( error continuation interactor -- popup )
357 error compute-restarts
358 error interactor make-restart-hook-quot
359 <debugger> frame-debugger ;
361 : debugger-popup ( interactor error continuation -- )
362 pick <debugger-popup> one-line-elt swap show-listener-popup ;
364 : try-parse ( lines -- quot/f )
365 [ parse-lines-interactive ] [ nip '[ _ rethrow ] ] recover ;
367 M: interactor stream-read-quot ( stream -- quot/f )
368 dup interactor-yield dup array? [
369 over interactor-finish try-parse
370 [ nip ] [ stream-read-quot ] if*
373 : interactor-operation ( gesture interactor -- ? )
374 [ token-model>> value>> ] keep word-at-caret
375 [ nip ] [ gesture>operation ] 2bi
376 [ invoke-command f ] [ drop t ] if* ;
378 M: interactor handle-gesture
380 { [ over key-gesture? not ] [ call-next-method ] }
381 { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
383 [ dup token-model>> value>> ]
384 [ { [ interactor-operation ] [ call-next-method ] } 2&& ]
389 interactor "interactor" f {
390 { T{ key-down f f "RET" } evaluate-input }
391 { T{ key-down f { C+ } "k" } clear-editor }
394 interactor "completion" f {
395 { T{ key-down f f "TAB" } code-completion-popup }
396 { T{ key-down f { C+ } "p" } recall-previous }
397 { T{ key-down f { C+ } "n" } recall-next }
398 { T{ key-down f { C+ } "r" } history-completion-popup }
401 : introduction. ( -- )
403 H{ { font-size $ default-font-size } } [
404 { $tip-of-the-day } print-element nl
405 { $strong "Press " { $snippet "F1" } " at any time for help." } print-element nl
406 version-info print-element
408 ] with-default-style nl nl ;
410 : listener-thread ( listener -- )
411 dup listener-streams [
412 [ com-browse ] help-hook set
413 '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
418 "The listener has exited. To start it again, click “Restart Listener”." print
419 ] with-input-output+error-streams* ;
421 : start-listener-thread ( listener -- )
424 [ input>> register-self ]
427 ] "Listener" spawn drop ;
429 : restart-listener ( listener -- )
430 ! Returns when listener is ready to receive input.
434 [ input>> clear-editor ]
435 [ start-listener-thread ]
436 [ wait-for-listener ]
439 : com-help ( -- ) "help.home" com-browse ;
441 \ com-help H{ { +nullary+ t } } define-command
443 : com-auto-use ( -- )
446 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
448 listener-gadget "toolbar" f {
449 { f restart-listener }
450 { T{ key-down f { A+ } "u" } com-auto-use }
451 { T{ key-down f { A+ } "k" } clear-output }
452 { T{ key-down f { A+ } "K" } clear-stack }
453 { T{ key-down f { C+ } "d" } com-end }
454 { T{ key-down f f "F1" } com-help }
457 listener-gadget "scrolling"
458 "The listener's scroller can be scrolled from the keyboard."
460 { T{ key-down f { A+ } "UP" } com-scroll-up }
461 { T{ key-down f { A+ } "DOWN" } com-scroll-down }
462 { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
463 { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
466 listener-gadget "multi-touch" f {
467 { up-action refresh-all }
470 M: listener-gadget graft*
471 [ call-next-method ] [ restart-listener ] bi ;
473 M: listener-gadget ungraft*
474 [ com-end ] [ call-next-method ] bi ;
478 :: make-font-style ( family size -- assoc )
480 family font-name pick set-at
481 size font-size pick set-at ;
485 :: set-listener-font ( family size -- )
486 get-listener input>> :> inter
487 family size make-font-style
488 inter output>> make-span-stream :> ostream
489 ostream inter output<<
494 ostream output-stream set ;