1 ! Copyright (C) 2003, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors colors combinators.short-circuit
4 compiler.units continuations debugger fry io io.styles kernel lexer
5 locals math math.parser namespaces parser parser.notes prettyprint
6 sequences sets source-files.errors system vocabs vocabs.loader
10 GENERIC: stream-read-quot ( stream -- quot/f )
11 GENERIC#: prompt. 1 ( stream prompt -- )
14 manifest get current-vocab>> [ name>> "IN: " prepend ] [ "" ] if*
15 auto-use? get [ " auto-use" append ] when ;
19 { background T{ rgba f 1 0.7 0.7 1 } }
20 { foreground COLOR: black }
21 } prompt-style set-global
24 nip prompt-style get-global format bl flush ;
26 SYMBOL: handle-ctrl-break
28 : maybe-enable-ctrl-break ( -- )
29 handle-ctrl-break get-global [ enable-ctrl-break ] when ;
31 : with-ctrl-break ( quot -- )
32 maybe-enable-ctrl-break
33 ! Always call disable-ctrl-break, no matter what handle-ctrl-break
34 ! says: it might've been changed just now by the user in the Listener.
35 ! It's a no-op if it's not enabled.
36 [ disable-ctrl-break ] finally ; inline
38 : parse-lines-interactive ( lines -- quot/f )
39 [ [ parse-lines ] with-ctrl-break ] with-compilation-unit ;
41 : read-quot-step ( lines -- quot/f )
42 '[ _ parse-lines-interactive ]
43 [ error>> unexpected-eof? ] ignore-error/f ;
45 : read-quot-loop ( stream accum -- quot/f )
46 over stream-readln dup [
48 dup read-quot-step dup
49 [ 2nip ] [ drop read-quot-loop ] if
54 M: object stream-read-quot
55 V{ } clone read-quot-loop ;
57 : read-quot ( -- quot/f ) input-stream get stream-read-quot ;
61 : show-var ( var -- ) visible-vars [ swap suffix ] change ;
63 : show-vars ( seq -- ) visible-vars [ swap union ] change ;
65 : hide-var ( var -- ) visible-vars [ remove ] change ;
67 : hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
69 : hide-all-vars ( -- ) visible-vars off ;
73 : call-error-hook ( error -- )
74 error-continuation get error-hook get
75 call( continuation error -- ) ;
77 [ drop print-error-and-restarts ] error-hook set-global
79 SYMBOL: display-stacks?
81 t display-stacks? set-global
83 SYMBOL: max-stack-items
85 10 max-stack-items set-global
87 SYMBOL: error-summary?
89 t error-summary? set-global
93 : title. ( string -- )
94 H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
96 : visible-vars. ( -- )
98 nl "--- Watched variables:" title.
99 standard-table-style [
102 [ [ short. ] with-cell ]
103 [ [ get short. ] with-cell ]
110 : trimmed-stack. ( seq -- )
111 dup length max-stack-items get > [
112 max-stack-items get cut*
114 [ length number>string "(" " more items)" surround ] keep
119 : datastack. ( datastack -- )
120 display-stacks? get [
121 [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
124 :: listener-step ( datastack -- datastack' )
125 error-summary? get [ error-summary ] when
128 input-stream get prompt prompt.
132 '[ [ datastack _ with-datastack ] with-ctrl-break ]
133 [ call-error-hook datastack ]
138 [ call-error-hook datastack ]
143 : (listener) ( datastack -- )
144 listener-step (listener) ;
148 SYMBOL: interactive-vocabs
192 "tools.profiler.sampling"
202 } interactive-vocabs set-global
204 : loaded-vocab? ( vocab-spec -- ? )
206 [ find-vocab-root not ]
207 [ source-loaded?>> +done+ eq? ]
210 : use-loaded-vocabs ( vocabs -- )
213 dup loaded-vocab? [ use-vocab ] [ drop ] if
217 : with-interactive-vocabs ( quot -- )
219 "scratchpad" set-current-vocab
220 interactive-vocabs get use-loaded-vocabs
222 ] with-manifest ; inline
227 [ { } (listener) ] with-return
228 ] with-interactive-vocabs ;
230 : listener-main ( -- )
231 "q" get [ version-info print flush ] unless listener ;