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