basis/ui/tools/listener/listener.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: inspector ui.tools.interactor ui.tools.inspector
   4 ui.tools.workspace help.markup io io.styles
   5 kernel models namespaces parser quotations sequences ui.commands
   6 ui.gadgets ui.gadgets.editors ui.gadgets.labelled
   7 ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
   8 ui.gadgets.tracks ui.gestures ui.operations vocabs words
   9 prettyprint listener debugger threads boxes concurrency.flags
  10 math arrays generic accessors combinators assocs ;
  11 IN: ui.tools.listener
  12
  13 TUPLE: listener-gadget < track input output stack ;
  14
  15 : listener-output, ( listener -- listener )
  16     <scrolling-pane> >>output
  17     dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
  18
  19 : listener-streams ( listener -- input output )
  20     [ input>> ] [ output>> <pane-stream> ] bi ;
  21
  22 : <listener-input> ( listener -- gadget )
  23     output>> <pane-stream> <interactor> ;
  24
  25 : listener-input, ( listener -- listener )
  26     dup <listener-input> >>input
  27     dup input>>
  28         { 0 100 } <limited-scroller>
  29         "Input" <labelled-gadget>
  30     f track-add ;
  31
  32 : welcome. ( -- )
  33     "If this is your first time with Factor, please read the " print
  34     "handbook" ($link) "." print nl ;
  35
  36 M: listener-gadget focusable-child*
  37     input>> ;
  38
  39 M: listener-gadget call-tool* ( input listener -- )
  40     >r string>> r> input>> set-editor-string ;
  41
  42 M: listener-gadget tool-scroller
  43     output>> find-scroller ;
  44
  45 : wait-for-listener ( listener -- )
  46     #! Wait for the listener to start.
  47     input>> flag>> wait-for-flag ;
  48
  49 : workspace-busy? ( workspace -- ? )
  50     listener>> input>> interactor-busy? ;
  51
  52 : listener-input ( string -- )
  53     get-workspace listener>> input>> set-editor-string ;
  54
  55 : (call-listener) ( quot listener -- )
  56     input>> interactor-call ;
  57
  58 : call-listener ( quot -- )
  59     [ workspace-busy? not ] get-workspace* listener>>
  60     [ dup wait-for-listener (call-listener) ] 2curry
  61     "Listener call" spawn drop ;
  62
  63 M: listener-command invoke-command ( target command -- )
  64     command-quot call-listener ;
  65
  66 M: listener-operation invoke-command ( target command -- )
  67     [ hook>> call ] keep operation-quot call-listener ;
  68
  69 : eval-listener ( string -- )
  70     get-workspace
  71     listener>> input>> [ set-editor-string ] keep
  72     evaluate-input ;
  73
  74 : listener-run-files ( seq -- )
  75     [
  76         [ [ run-file ] each ] curry call-listener
  77     ] unless-empty ;
  78
  79 : com-end ( listener -- )
  80     input>> interactor-eof ;
  81
  82 : clear-output ( listener -- )
  83     output>> pane-clear ;
  84
  85 \ clear-output H{ { +listener+ t } } define-command
  86
  87 : clear-stack ( listener -- )
  88     [ clear ] swap (call-listener) ;
  89
  90 GENERIC: word-completion-string ( word -- string )
  91
  92 M: word word-completion-string
  93     name>> ;
  94
  95 M: method-body word-completion-string
  96     "method-generic" word-prop word-completion-string ;
  97
  98 USE: generic.standard.engines.tuple
  99
 100 M: engine-word word-completion-string
 101     "engine-generic" word-prop word-completion-string ;
 102
 103 : use-if-necessary ( word seq -- )
 104     over vocabulary>> [
 105         2dup assoc-stack pick = [ 2drop ] [
 106             >r vocabulary>> vocab-words r> push
 107         ] if
 108     ] [ 2drop ] if ;
 109
 110 : insert-word ( word -- )
 111     get-workspace listener>> input>>
 112     [ >r word-completion-string r> user-input ]
 113     [ interactor-use use-if-necessary ]
 114     2bi ;
 115
 116 : quot-action ( interactor -- lines )
 117     dup control-value
 118     dup "\n" join pick add-interactor-history
 119     swap select-all ;
 120
 121 TUPLE: stack-display < track ;
 122
 123 : <stack-display> ( workspace -- gadget )
 124     listener>>
 125     { 0 1 } stack-display new-track
 126     over <toolbar> f track-add
 127     swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
 128     1 track-add ;
 129
 130 M: stack-display tool-scroller
 131     find-workspace listener>> tool-scroller ;
 132
 133 : ui-listener-hook ( listener -- )
 134     >r datastack r> stack>> set-model ;
 135
 136 : ui-error-hook ( error listener -- )
 137     find-workspace debugger-popup ;
 138
 139 : ui-inspector-hook ( obj listener -- )
 140     find-workspace inspector-gadget
 141     swap show-tool inspect-object ;
 142
 143 : listener-thread ( listener -- )
 144     dup listener-streams [
 145         [ [ ui-listener-hook ] curry listener-hook set ]
 146         [ [ ui-error-hook ] curry error-hook set ]
 147         [ [ ui-inspector-hook ] curry inspector-hook set ] tri
 148         welcome.
 149         listener
 150     ] with-streams* ;
 151
 152 : start-listener-thread ( listener -- )
 153     [
 154         [ input>> register-self ] [ listener-thread ] bi
 155     ] curry "Listener" spawn drop ;
 156
 157 : restart-listener ( listener -- )
 158     #! Returns when listener is ready to receive input.
 159     {
 160         [ com-end ]
 161         [ clear-output ]
 162         [ input>> clear-input ]
 163         [ start-listener-thread ]
 164         [ wait-for-listener ]
 165     } cleave ;
 166
 167 : init-listener ( listener -- )
 168     f <model> >>stack drop ;
 169
 170 : <listener-gadget> ( -- gadget )
 171     { 0 1 } listener-gadget new-track
 172         dup init-listener
 173         listener-output,
 174         listener-input, ;
 175
 176 : listener-help ( -- ) "ui-listener" help-window ;
 177
 178 \ listener-help H{ { +nullary+ t } } define-command
 179
 180 listener-gadget "toolbar" f {
 181     { f restart-listener }
 182     { T{ key-down f f "CLEAR" } clear-output }
 183     { T{ key-down f { C+ } "CLEAR" } clear-stack }
 184     { T{ key-down f { C+ } "d" } com-end }
 185     { T{ key-down f f "F1" } listener-help }
 186 } define-command-map
 187
 188 M: listener-gadget handle-gesture ( gesture gadget -- ? )
 189     2dup find-workspace workspace-page handle-gesture
 190     [ call-next-method ] [ 2drop f ] if ;
 191
 192 M: listener-gadget graft*
 193     [ call-next-method ] [ restart-listener ] bi ;
 194
 195 M: listener-gadget ungraft*
 196     [ com-end ] [ call-next-method ] bi ;