1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs calendar colors.constants
4 combinators combinators.short-circuit concurrency.flags
5 concurrency.mailboxes continuations destructors documents
6 documents.elements fry hashtables help help.markup help.tips io
7 io.styles kernel lexer listener locals make math models
8 models.arrow models.delay namespaces parser prettyprint
9 quotations sequences source-files.errors strings system threads
10 tools.errors.model ui ui.commands ui.gadgets ui.gadgets.buttons
11 ui.gadgets.editors ui.gadgets.glass ui.gadgets.labeled ui.gadgets.lines
12 ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar
13 ui.gadgets.tracks ui.gadgets.toolbar
14 ui.gestures ui.operations ui.pens.solid
15 ui.tools.browser ui.tools.common ui.tools.debugger
16 ui.tools.error-list ui.tools.listener.completion
17 ui.tools.listener.history ui.tools.listener.popups vocabs
18 vocabs.loader vocabs.parser vocabs.refresh words ;
21 ! If waiting is t, we're waiting for user input, and invoking
22 ! evaluate-input resumes the thread.
23 TUPLE: interactor < source-editor
24 output history flag mailbox thread waiting token-model word-model popup ;
26 INSTANCE: interactor input-stream
28 : register-self ( interactor -- )
33 : interactor-continuation ( interactor -- continuation )
34 thread>> thread-continuation ;
36 : interactor-busy? ( interactor -- ? )
37 #! We're busy if there's no thread to resume.
40 [ thread>> dup [ thread-registered? ] when ]
45 M: interactor manifest>>
46 dup interactor-busy? [ drop f ] [
47 interactor-continuation name>>
48 manifest swap assoc-stack
51 : vocab-exists? ( name -- ? )
52 '[ _ { [ lookup-vocab ] [ find-vocab-root ] } 1|| ] [ drop f ] recover ;
54 GENERIC: (word-at-caret) ( token completion-mode -- obj )
56 M: vocab-completion (word-at-caret)
57 drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
59 M: word-completion (word-at-caret)
61 '[ _ _ search-manifest ] [ drop f ] recover
64 M: char-completion (word-at-caret) 2drop f ;
66 M: path-completion (word-at-caret) 2drop f ;
68 M: color-completion (word-at-caret) 2drop f ;
70 : word-at-caret ( token interactor -- obj )
71 completion-mode (word-at-caret) ;
73 : <word-model> ( interactor -- model )
74 [ token-model>> 1/3 seconds <delay> ]
75 [ '[ _ word-at-caret ] ] bi
78 : <interactor> ( -- gadget )
81 dup one-word-elt <element-model> >>token-model
82 dup <word-model> >>word-model
83 dup model>> <history> >>history ;
86 [ call-next-method ] [ dup word-model>> add-connection ] bi ;
88 M: interactor ungraft*
89 [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
91 M: interactor model-changed
92 2dup word-model>> eq? [
94 [ 2drop ] [ [ value>> ] dip show-summary ] if
95 ] [ call-next-method ] if ;
97 M: interactor stream-element-type drop +character+ ;
99 GENERIC: (print-input) ( object -- )
101 M: input (print-input)
102 dup presented associate
103 [ string>> H{ { font-style bold } } format ] with-nesting nl ;
105 M: word (print-input)
108 "sans-serif" font-name ,,
110 ] H{ } make format . ;
112 : print-input ( object interactor -- )
113 output>> [ (print-input) ] with-output-stream* ;
115 : interactor-continue ( obj interactor -- )
116 mailbox>> mailbox-put ;
118 : interactor-finish ( interactor -- )
119 [ history>> history-add ] keep
121 [ clear-editor drop ]
122 [ model>> clear-undo drop ] 2tri ;
124 : interactor-eof ( interactor -- )
125 dup interactor-busy? [
126 f over interactor-continue
129 : evaluate-input ( interactor -- )
130 dup interactor-busy? [ drop ] [
131 [ control-value ] keep interactor-continue
134 : interactor-yield ( interactor -- obj )
135 dup thread>> self eq? [
138 [ flag>> raise-flag ]
139 [ mailbox>> mailbox-get ]
144 : interactor-read ( interactor -- lines )
145 [ interactor-yield ] [ interactor-finish ] bi ;
147 M: interactor stream-readln
148 interactor-read dup [ first ] when ;
150 : (call-listener) ( quot command listener -- )
151 input>> dup interactor-busy? [ 3drop ] [
153 [ nip interactor-continue ]
157 M:: interactor stream-read-unsafe ( n buf interactor -- count )
160 interactor interactor-read dup [ "\n" join ] when
161 n short [ head-slice 0 buf copy ] keep
164 M: interactor stream-read1
165 dup interactor-read {
166 { [ dup not ] [ 2drop f ] }
167 { [ dup empty? ] [ drop stream-read1 ] }
168 { [ dup first empty? ] [ 2drop CHAR: \n ] }
172 M: interactor stream-read-until ( seps stream -- seq sep/f )
175 "\n" join CHAR: \n suffix
176 [ _ member? ] dupd find
177 [ [ head ] when* ] dip dup not
179 ] [ drop ] produce swap [ concat "" prepend-as ] dip ;
181 M: interactor dispose drop ;
183 : go-to-error ( interactor error -- )
184 [ line>> 1 - ] [ column>> ] bi 2array
188 TUPLE: listener-gadget < tool error-summary output scroller input ;
190 { 600 700 } listener-gadget set-tool-dim
192 : find-listener ( gadget -- listener )
193 [ listener-gadget? ] find-parent ;
195 : listener-streams ( listener -- input output )
196 [ input>> ] [ output>> <pane-stream> ] bi ;
198 : init-input/output ( listener -- listener )
200 [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
201 dup listener-streams >>output drop ;
203 : error-summary. ( -- )
205 H{ { table-gap { 3 3 } } } [
206 [ [ [ icon>> write-image ] with-cell ] each ] with-row
209 { "Press " { $command tool "common" show-error-list } " to view errors." }
213 : <error-summary> ( -- gadget )
214 error-list-model get [ drop error-summary. ] <pane-control>
215 COLOR: light-yellow <solid> >>interior ;
217 : init-error-summary ( listener -- listener )
218 <error-summary> >>error-summary
219 dup error-summary>> f track-add ;
221 : add-listener-area ( listener -- listener )
222 dup output>> margins <scroller> >>scroller
223 dup scroller>> white-interior 1 track-add ;
225 : <listener-gadget> ( -- listener )
226 vertical listener-gadget new-track with-lines
232 M: listener-gadget focusable-child*
233 input>> dup popup>> or ;
235 : wait-for-listener ( listener -- )
236 #! Wait for the listener to start.
237 input>> flag>> wait-for-flag ;
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 -- )
288 '[ _ _ _ dup wait-for-listener (call-listener) ]
289 "Listener call" spawn drop ;
291 M: listener-command invoke-command ( target command -- )
292 [ command-quot ] [ nip ] 2bi call-listener ;
294 M: listener-operation invoke-command ( target command -- )
295 [ operation-quot ] [ nip command>> ] 2bi call-listener ;
297 : eval-listener ( string -- )
298 get-listener input>> [ set-editor-string ] keep
301 : listener-run-files ( seq -- )
303 '[ _ [ run-file ] each ]
308 : com-end ( listener -- )
309 input>> interactor-eof ;
311 : clear-output ( listener -- )
312 output>> pane-clear ;
314 \ clear-output H{ { +listener+ t } } define-command
316 : clear-stack ( listener -- )
317 [ [ clear ] \ clear ] dip (call-listener) ;
319 : use-if-necessary ( word manifest -- )
320 2dup [ vocabulary>> ] dip and [
322 [ vocabulary>> use-vocab ]
323 [ dup name>> associate use-words ] bi
327 M: word accept-completion-hook
328 interactor>> manifest>> use-if-necessary ;
330 M: object accept-completion-hook 2drop ;
332 : quot-action ( interactor -- lines )
333 [ history>> history-add drop ] [ control-value ] [ select-all ] tri
334 parse-lines-interactive ;
336 : <debugger-popup> ( error continuation -- popup )
337 over compute-restarts [ hide-glass ] <debugger> "Error" <framed-labeled-gadget> ;
339 : debugger-popup ( interactor error continuation -- )
340 [ one-line-elt ] 2dip <debugger-popup> show-listener-popup ;
342 : handle-parse-error ( interactor error -- )
343 dup lexer-error? [ 2dup go-to-error error>> ] when
344 error-continuation get
347 : try-parse ( lines interactor -- quot/error/f )
348 [ drop parse-lines-interactive ] [
351 dup error>> unexpected-eof? [ drop f ] when
355 : handle-interactive ( lines interactor -- quot/f ? )
356 [ nip ] [ try-parse ] 2bi {
357 { [ dup quotation? ] [ nip t ] }
358 { [ dup not ] [ drop insert-newline f f ] }
359 [ handle-parse-error f f ]
362 M: interactor stream-read-quot
363 [ interactor-yield ] keep {
364 { [ over not ] [ drop ] }
365 { [ over callable? ] [ drop ] }
367 [ handle-interactive ] keep swap
368 [ interactor-finish ] [ nip stream-read-quot ] if
372 : interactor-operation ( gesture interactor -- ? )
373 [ token-model>> value>> ] keep word-at-caret
374 [ nip ] [ gesture>operation ] 2bi
375 [ invoke-command f ] [ drop t ] if* ;
377 M: interactor handle-gesture
379 { [ over key-gesture? not ] [ call-next-method ] }
380 { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
381 { [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
385 interactor "interactor" f {
386 { T{ key-down f f "RET" } evaluate-input }
387 { T{ key-down f { C+ } "k" } clear-editor }
390 interactor "completion" f {
391 { T{ key-down f f "TAB" } code-completion-popup }
392 { T{ key-down f { C+ } "p" } recall-previous }
393 { T{ key-down f { C+ } "n" } recall-next }
394 { T{ key-down f { C+ } "r" } history-completion-popup }
397 : introduction. ( -- )
399 { $strong "Press " { $snippet "F1" } " at any time for help." } print-content nl
400 version-info print-content nl nl ;
402 : listener-thread ( listener -- )
403 dup listener-streams [
404 [ com-browse ] help-hook set
405 '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
410 "The listener has exited. To start it again, click “Restart Listener”." print
411 ] with-input-output+error-streams* ;
413 : start-listener-thread ( listener -- )
416 [ input>> register-self ]
419 ] "Listener" spawn drop ;
421 : restart-listener ( listener -- )
422 #! Returns when listener is ready to receive input.
426 [ input>> clear-editor ]
427 [ start-listener-thread ]
428 [ wait-for-listener ]
431 : com-help ( -- ) "help.home" com-browse ;
433 \ com-help H{ { +nullary+ t } } define-command
435 : com-auto-use ( -- )
438 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
440 listener-gadget "toolbar" f {
441 { f restart-listener }
442 { T{ key-down f { A+ } "u" } com-auto-use }
443 { T{ key-down f { A+ } "k" } clear-output }
444 { T{ key-down f { A+ } "K" } clear-stack }
445 { T{ key-down f { C+ } "d" } com-end }
446 { T{ key-down f f "F1" } com-help }
449 listener-gadget "scrolling"
450 "The listener's scroller can be scrolled from the keyboard."
452 { T{ key-down f { A+ } "UP" } com-scroll-up }
453 { T{ key-down f { A+ } "DOWN" } com-scroll-down }
454 { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
455 { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
458 listener-gadget "multi-touch" f {
459 { up-action refresh-all }
462 M: listener-gadget graft*
463 [ call-next-method ] [ restart-listener ] bi ;
465 M: listener-gadget ungraft*
466 [ com-end ] [ call-next-method ] bi ;
470 :: make-font-style ( family size -- assoc )
472 family font-name pick set-at
473 size font-size pick set-at ;
477 :: set-listener-font ( family size -- )
478 get-listener input>> :> inter
479 family size make-font-style
480 inter output>> make-span-stream :> ostream
481 ostream inter output<<
486 ostream output-stream set ;