1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: inspector help help.markup io io.styles kernel models
4 namespaces parser quotations sequences vocabs words prettyprint
5 listener debugger threads boxes concurrency.flags math arrays
6 generic accessors combinators assocs fry ui.commands ui.gadgets
7 ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
8 ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
9 ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
10 ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
11 ui.tools.interactor ui.tools.inspector ui.tools.workspace ;
14 TUPLE: listener-gadget < track input output ;
16 : listener-streams ( listener -- input output )
17 [ input>> ] [ output>> <pane-stream> ] bi ;
19 : <listener-input> ( listener -- gadget )
20 output>> <pane-stream> <interactor> ;
23 "If this is your first time with Factor, please read the " print
24 "handbook" ($link) ". To see a list of keyboard shortcuts," print
25 "press F1." print nl ;
27 M: listener-gadget focusable-child*
30 M: listener-gadget call-tool* ( input listener -- )
31 [ string>> ] dip input>> set-editor-string ;
33 M: listener-gadget tool-scroller
34 output>> find-scroller ;
36 : wait-for-listener ( listener -- )
37 #! Wait for the listener to start.
38 input>> flag>> wait-for-flag ;
40 : workspace-busy? ( workspace -- ? )
41 listener>> input>> interactor-busy? ;
43 : listener-input ( string -- )
44 get-workspace listener>> input>>
45 [ set-editor-string ] [ request-focus ] bi ;
47 : (call-listener) ( quot listener -- )
48 input>> interactor-call ;
50 : call-listener ( quot -- )
51 [ workspace-busy? not ] get-workspace* listener>>
52 '[ _ _ dup wait-for-listener (call-listener) ]
53 "Listener call" spawn drop ;
55 M: listener-command invoke-command ( target command -- )
56 command-quot call-listener ;
58 M: listener-operation invoke-command ( target command -- )
59 [ hook>> call ] keep operation-quot call-listener ;
61 : eval-listener ( string -- )
63 listener>> input>> [ set-editor-string ] keep
66 : listener-run-files ( seq -- )
68 '[ _ [ run-file ] each ] call-listener
71 : com-end ( listener -- )
72 input>> interactor-eof ;
74 : clear-output ( listener -- )
77 \ clear-output H{ { +listener+ t } } define-command
79 : clear-stack ( listener -- )
80 [ clear ] swap (call-listener) ;
82 GENERIC: word-completion-string ( word -- string )
84 M: word word-completion-string
87 M: method-body word-completion-string
88 "method-generic" word-prop word-completion-string ;
90 USE: generic.standard.engines.tuple
92 M: engine-word word-completion-string
93 "engine-generic" word-prop word-completion-string ;
95 : use-if-necessary ( word seq -- )
96 over vocabulary>> over and [
97 2dup [ assoc-stack ] keep = [ 2drop ] [
98 [ vocabulary>> vocab-words ] dip push
102 : insert-word ( word -- )
103 get-workspace listener>> input>>
104 [ [ word-completion-string ] dip user-input* drop ]
105 [ interactor-use use-if-necessary ]
108 : quot-action ( interactor -- lines )
109 [ control-value ] keep
110 [ [ "\n" join ] dip add-interactor-history ]
114 : ui-help-hook ( topic -- )
115 browser-gadget call-tool ;
117 : ui-error-hook ( error listener -- )
118 find-workspace debugger-popup ;
120 : ui-inspector-hook ( obj listener -- )
121 find-workspace inspector-gadget
122 swap show-tool inspect-object ;
124 : listener-thread ( listener -- )
125 dup listener-streams [
126 [ ui-help-hook ] help-hook set
127 [ '[ _ ui-error-hook ] error-hook set ]
128 [ '[ _ ui-inspector-hook ] inspector-hook set ] bi
133 : start-listener-thread ( listener -- )
136 [ input>> register-self ]
139 ] "Listener" spawn drop ;
141 : restart-listener ( listener -- )
142 #! Returns when listener is ready to receive input.
146 [ input>> clear-input ]
147 [ start-listener-thread ]
148 [ wait-for-listener ]
151 : init-listener ( listener -- listener )
152 <scrolling-pane> >>output
153 dup <listener-input> >>input ;
155 : <listener-scroller> ( listener -- scroller )
157 over output>> @top grid-add
158 swap input>> @center grid-add
161 : <listener-gadget> ( -- gadget )
162 { 0 1 } listener-gadget new-track
165 dup <listener-scroller> 1 track-add ;
167 : listener-help ( -- ) "ui-listener" help-window ;
169 \ listener-help H{ { +nullary+ t } } define-command
171 : com-auto-use ( -- )
172 auto-use? [ not ] change ;
174 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
176 listener-gadget "misc" "Miscellaneous commands" {
177 { T{ key-down f f "F1" } listener-help }
180 listener-gadget "toolbar" f {
181 { f restart-listener }
182 { T{ key-down f { A+ } "u" } com-auto-use }
183 { T{ key-down f { A+ } "k" } clear-output }
184 { T{ key-down f { A+ } "K" } clear-stack }
185 { T{ key-down f { C+ } "d" } com-end }
188 M: listener-gadget handle-gesture ( gesture gadget -- ? )
189 2dup find-workspace workspace-page handle-gesture
190 [ call-next-method ] [ 2drop f ] if ;
192 M: listener-gadget graft*
193 [ call-next-method ] [ restart-listener ] bi ;
195 M: listener-gadget ungraft*
196 [ com-end ] [ call-next-method ] bi ;