1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See https://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 hashtables help help.markup help.tips
7 io io.styles kernel lexer listener literals math math.vectors
8 models models.arrow models.delay namespaces parser prettyprint
9 sequences source-files.errors splitting strings system threads
10 ui ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.glass
11 ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
12 ui.gadgets.status-bar ui.gadgets.toolbar ui.gadgets.tracks
13 ui.gestures ui.operations ui.pens.solid ui.theme
14 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 GENERIC: (word-at-caret) ( token completion-mode -- obj )
49 M: object (word-at-caret) 2drop f ;
51 M: vocab-completion (word-at-caret)
53 [ dup vocab-exists? [ >vocab-link ] [ drop f ] if ]
56 M: word-completion (word-at-caret)
58 '[ _ _ search-manifest ] [ drop f ] recover
61 M: vocab-word-completion (word-at-caret)
62 vocab-name>> lookup-word ;
64 : word-at-caret ( token interactor -- obj )
65 completion-mode (word-at-caret) ;
67 : <word-model> ( interactor -- model )
68 [ token-model>> 1/3 seconds <delay> ]
69 [ '[ _ word-at-caret ] ] bi
72 : <interactor> ( -- gadget )
75 dup one-word-elt <element-model> >>token-model
76 dup <word-model> >>word-model
77 dup model>> <history> >>history ;
80 [ call-next-method ] [ dup word-model>> add-connection ] bi ;
82 M: interactor ungraft*
83 [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
85 M: interactor model-changed
86 2dup word-model>> eq? [
88 [ 2drop ] [ [ value>> ] dip show-summary ] if
89 ] [ call-next-method ] if ;
91 M: interactor stream-element-type drop +character+ ;
93 GENERIC: (print-input) ( object -- )
95 SYMBOL: listener-input-style
98 { foreground $ text-color }
99 } listener-input-style set-global
101 SYMBOL: listener-word-style
103 { font-name "sans-serif" }
105 { foreground $ text-color }
106 } listener-word-style set-global
108 M: input (print-input)
109 dup presented associate [
110 string>> listener-input-style get-global format
113 M: word (print-input)
114 "Command: " listener-word-style get-global format . ;
116 : print-input ( object interactor -- )
117 output>> [ (print-input) ] with-output-stream* ;
119 : interactor-continue ( obj interactor -- )
120 [ mailbox>> mailbox-put ] [ scroll>bottom ] bi ;
122 : interactor-finish ( interactor -- )
123 [ history>> history-add ] keep
125 [ clear-editor drop ]
126 [ model>> clear-undo drop ] 2tri ;
128 : interactor-eof ( interactor -- )
129 dup interactor-busy? [
130 f over interactor-continue
133 : evaluate-input ( interactor -- )
134 dup interactor-busy? [ scroll>bottom ] [
135 [ control-value ] keep interactor-continue
138 : interactor-yield ( interactor -- obj )
139 dup thread>> self eq? [
142 [ flag>> raise-flag ]
143 [ mailbox>> mailbox-get ]
148 : interactor-read ( interactor -- lines )
149 [ interactor-yield ] [ interactor-finish ] bi ;
151 M: interactor stream-readln
152 interactor-read ?first ;
154 : (call-listener) ( quot command listener -- )
155 input>> dup interactor-busy? [ 3drop ] [
157 [ nip interactor-continue ]
161 M:: interactor stream-read-unsafe ( n buf interactor -- count )
164 interactor interactor-read dup [ join-lines ] when
165 n index-or-length [ head-slice 0 buf copy ] keep
168 M: interactor stream-read1
169 dup interactor-read {
170 { [ dup not ] [ 2drop f ] }
171 { [ dup empty? ] [ drop stream-read1 ] }
172 { [ dup first empty? ] [ 2drop CHAR: \n ] }
176 M: interactor stream-read-until
179 join-lines CHAR: \n suffix
180 [ _ member? ] dupd find
181 [ [ head ] when* ] dip dup not
183 ] [ drop ] produce swap [ concat "" prepend-as ] dip ;
185 M: interactor dispose drop ;
187 : go-to-error ( interactor error -- )
188 [ line>> 1 - ] [ column>> ] bi 2array
192 TUPLE: listener-gadget < tool error-summary output scroller input ;
194 listener-gadget default-font-size { 50 58 } n*v set-tool-dim
196 : listener-streams ( listener -- input output )
197 [ input>> ] [ output>> <pane-stream> H{ } clone <style-stream> ] bi ;
199 : init-input/output ( listener -- listener )
201 [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
202 dup listener-streams >>output drop ;
204 : error-summary. ( -- )
206 H{ { table-gap { 3 3 } } } [
207 [ [ [ icon>> write-image ] with-cell ] each ] with-row
210 { "Press " { $command tool "common" show-error-list } " to view errors." }
214 : <error-summary> ( -- gadget )
215 error-list-model get [ drop error-summary. ] <pane-control>
216 error-summary-background <solid> >>interior ;
218 : init-error-summary ( listener -- listener )
219 <error-summary> >>error-summary
220 dup error-summary>> f track-add ;
222 : add-listener-area ( listener -- listener )
223 dup output>> margins <scroller> >>scroller
224 dup scroller>> white-interior 1 track-add ;
226 : <listener-gadget> ( -- listener )
227 vertical listener-gadget new-track with-lines
233 M: listener-gadget focusable-child*
234 input>> dup popup>> or ;
236 : wait-for-listener ( listener -- )
237 input>> flag>> 5 seconds wait-for-flag-timeout ;
239 : listener-busy? ( listener -- ? )
240 input>> interactor-busy? ;
242 : listener-window* ( -- listener )
244 dup "Listener" open-status-window ;
246 : listener-window ( -- )
247 [ listener-window* drop ] with-ui ;
249 \ listener-window H{ { +nullary+ t } } define-command
251 : (get-listener) ( quot -- listener )
257 [ input>> scroll>caret ]
258 [ input>> request-focus ] tri
260 ] [ listener-window* ] if* ; inline
262 : get-listener ( -- listener )
263 [ listener-gadget? ] (get-listener) ;
265 : show-listener ( -- )
268 \ show-listener H{ { +nullary+ t } } define-command
270 : get-ready-listener ( -- listener )
274 [ listener-busy? not ]
278 GENERIC: listener-input ( obj -- )
280 M: input listener-input string>> listener-input ;
282 M: string listener-input
284 [ set-editor-string ] [ request-focus ] bi ;
286 : call-listener ( quot command -- )
287 get-ready-listener '[
288 _ _ _ dup wait-for-listener
289 [ (call-listener) ] with-ctrl-break
290 ] "Listener call" spawn drop ;
292 M: listener-command invoke-command
293 [ command-quot ] [ nip ] 2bi call-listener ;
295 M: listener-operation invoke-command
296 [ operation-quot ] [ nip command>> ] 2bi call-listener ;
298 : eval-listener ( string -- )
299 get-listener input>> [ set-editor-string ] keep
302 : listener-run-files ( seq -- )
304 '[ _ [ run-file ] each ]
309 : com-end ( listener -- )
310 input>> interactor-eof ;
312 : clear-output ( listener -- )
313 output>> clear-pane ;
315 \ clear-output H{ { +listener+ t } } define-command
317 : clear-stack ( listener -- )
318 [ [ clear ] \ clear ] dip (call-listener) ;
320 : use-if-necessary ( word manifest -- )
321 [ [ vocabulary>> ] keep ] dip pick over and [
324 [ name>> 1array add-words-from ] 2bi
328 M: word accept-completion-hook
329 interactor>> manifest>> use-if-necessary ;
331 M: object accept-completion-hook 2drop ;
333 : quot-action ( interactor -- lines )
334 [ history>> history-add drop ] [ control-value ] [ select-all ] tri
335 parse-lines-interactive ;
337 : do-recall? ( table error -- ? )
338 [ selection>> value>> not ] [ lexer-error? ] bi* and ;
340 : recall-lexer-error ( interactor error -- )
341 over recall-previous go-to-error ;
343 : make-restart-hook-quot ( error interactor -- quot )
346 _ do-recall? [ _ _ recall-lexer-error ] when
349 : frame-debugger ( debugger -- labeled )
350 "Error" debugger-color <framed-labeled-gadget> ;
352 :: <debugger-popup> ( error continuation interactor -- popup )
355 error compute-restarts
356 error interactor make-restart-hook-quot
357 <debugger> frame-debugger ;
359 : debugger-popup ( interactor error continuation -- )
360 pick <debugger-popup> one-line-elt swap show-listener-popup ;
362 : try-parse ( lines -- quot/f )
363 [ parse-lines-interactive ] [ nip '[ _ rethrow ] ] recover ;
365 M: interactor stream-read-quot
366 dup interactor-yield dup array? [
367 over interactor-finish try-parse
368 [ ] [ stream-read-quot ] ?if-old
371 : interactor-operation ( gesture interactor -- ? )
372 [ token-model>> value>> ] keep word-at-caret
373 [ nip ] [ gesture>operation ] 2bi
374 [ invoke-command f ] [ drop t ] if* ;
376 M: interactor handle-gesture
378 { [ over key-gesture? not ] [ call-next-method ] }
379 { [ dup popup>> ] [ ?check-popup { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
381 [ dup token-model>> value>> ]
382 [ { [ interactor-operation ] [ call-next-method ] } 2&& ]
387 : delete-next-character/eof ( interactor -- )
388 dup model>> doc-string empty?
389 [ interactor-eof ] [ delete-next-character ] if ;
391 interactor "interactor" f {
392 { T{ key-down f f "RET" } evaluate-input }
393 { T{ key-down f { C+ } "d" } delete-next-character/eof }
396 interactor "completion" f {
397 { T{ key-down f f "TAB" } code-completion-popup }
398 { T{ key-down f { C+ } "p" } recall-previous }
399 { T{ key-down f { C+ } "n" } recall-next }
400 { T{ key-down f { C+ } "r" } history-completion-popup }
401 { T{ key-down f { C+ } "s" } history-completion-popup }
404 : introduction. ( -- )
406 H{ { font-size $ default-font-size } } [
407 { $tip-of-the-day } print-element nl
408 { $strong "Press " { $snippet "F1" } " at any time for help." } print-element nl
409 version-info print-element
411 ] with-default-style nl nl ;
413 : listener-thread ( listener -- )
414 dup input>> dup output>> [
415 [ com-browse ] help-hook set
416 '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
421 "The listener has exited. To start it again, click “Restart Listener”." print
422 ] with-input-output+error-streams* ;
424 : start-listener-thread ( listener -- )
427 [ input>> register-self ]
430 ] "Listener" spawn drop ;
432 : restart-listener ( listener -- )
433 ! Returns when listener is ready to receive input.
437 [ input>> clear-editor ]
438 [ start-listener-thread ]
439 [ wait-for-listener ]
442 : com-help ( -- ) "help.home" com-browse ;
444 \ com-help H{ { +nullary+ t } } define-command
446 : com-auto-use ( -- )
449 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
451 : com-file-drop ( -- files )
452 dropped-files get-global ;
454 \ com-file-drop H{ { +nullary+ t } { +listener+ t } } define-command
456 listener-gadget "toolbar" f {
457 { f restart-listener }
458 { T{ key-down f ${ os macosx? M+ A+ ? } "u" } com-auto-use }
459 { T{ key-down f ${ os macosx? M+ A+ ? } "k" } clear-output }
460 { T{ key-down f ${ os macosx? M+ A+ ? } "K" } clear-stack }
461 { T{ key-down f f "F1" } com-help }
464 listener-gadget "scrolling"
465 "The listener's scroller can be scrolled from the keyboard."
467 { T{ key-down f ${ os macosx? M+ A+ ? } "UP" } com-scroll-up }
468 { T{ key-down f ${ os macosx? M+ A+ ? } "DOWN" } com-scroll-down }
469 { T{ key-down f ${ os macosx? M+ A+ ? } "PAGE_UP" } com-page-up }
470 { T{ key-down f ${ os macosx? M+ A+ ? } "PAGE_DOWN" } com-page-down }
473 listener-gadget "multi-touch" f {
474 { up-action refresh-all }
477 listener-gadget "touchbar" f {
481 { f show-error-list }
484 listener-gadget "file-drop" "Files can be drag-and-dropped onto the listener."
486 { T{ file-drop f f } com-file-drop }
489 M: listener-gadget graft*
490 [ call-next-method ] [ restart-listener ] bi ;
492 M: listener-gadget ungraft*
493 [ com-end ] [ call-next-method ] bi ;
495 :: set-listener-font ( family size -- )
496 get-listener input>> :> interactor
497 interactor output>> :> output
502 ] change-font f >>line-height drop
503 family font-name output style>> set-at
504 size font-size output style>> set-at ;
508 :: adjust-listener-font-size ( listener delta -- )
509 listener input>> :> interactor
510 interactor output>> :> output
512 [ clone [ delta + ] change-size ] change-font
514 font>> size>> font-size output style>> set-at ;
518 : com-font-size-plus ( listener -- )
519 2 adjust-listener-font-size ;
521 : com-font-size-minus ( listener -- )
522 -2 adjust-listener-font-size ;
524 : com-font-size-normal ( listener -- )
525 default-font-size over input>> font>> size>> -
526 adjust-listener-font-size ;
528 listener-gadget "fonts" f {
529 { T{ key-down f ${ os macosx? M+ C+ ? } "+" } com-font-size-plus }
530 { T{ key-down f ${ os macosx? M+ C+ ? } "=" } com-font-size-plus }
531 { T{ key-down f ${ os macosx? M+ C+ ? } "_" } com-font-size-minus }
532 { T{ key-down f ${ os macosx? M+ C+ ? } "-" } com-font-size-minus }
533 { T{ key-down f ${ os macosx? M+ C+ ? } "0" } com-font-size-normal }