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 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 ;
  12 IN: ui.tools.listener
  13
  14 TUPLE: listener-gadget < track input output ;
  15
  16 : listener-streams ( listener -- input output )
  17     [ input>> ] [ output>> <pane-stream> ] bi ;
  18
  19 : <listener-input> ( listener -- gadget )
  20     output>> <pane-stream> <interactor> ;
  21
  22 : welcome. ( -- )
  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 ;
  26
  27 M: listener-gadget focusable-child*
  28     input>> ;
  29
  30 M: listener-gadget call-tool* ( input listener -- )
  31     [ string>> ] dip input>> set-editor-string ;
  32
  33 M: listener-gadget tool-scroller
  34     output>> find-scroller ;
  35
  36 : wait-for-listener ( listener -- )
  37     #! Wait for the listener to start.
  38     input>> flag>> wait-for-flag ;
  39
  40 : workspace-busy? ( workspace -- ? )
  41     listener>> input>> interactor-busy? ;
  42
  43 : listener-input ( string -- )
  44     get-workspace listener>> input>>
  45     [ set-editor-string ] [ request-focus ] bi ;
  46
  47 : (call-listener) ( quot listener -- )
  48     input>> interactor-call ;
  49
  50 : call-listener ( quot -- )
  51     [ workspace-busy? not ] get-workspace* listener>>
  52     '[ _ _ dup wait-for-listener (call-listener) ]
  53     "Listener call" spawn drop ;
  54
  55 M: listener-command invoke-command ( target command -- )
  56     command-quot call-listener ;
  57
  58 M: listener-operation invoke-command ( target command -- )
  59     [ hook>> call ] keep operation-quot call-listener ;
  60
  61 : eval-listener ( string -- )
  62     get-workspace
  63     listener>> input>> [ set-editor-string ] keep
  64     evaluate-input ;
  65
  66 : listener-run-files ( seq -- )
  67     [
  68         '[ _ [ run-file ] each ] call-listener
  69     ] unless-empty ;
  70
  71 : com-end ( listener -- )
  72     input>> interactor-eof ;
  73
  74 : clear-output ( listener -- )
  75     output>> pane-clear ;
  76
  77 \ clear-output H{ { +listener+ t } } define-command
  78
  79 : clear-stack ( listener -- )
  80     [ clear ] swap (call-listener) ;
  81
  82 GENERIC: word-completion-string ( word -- string )
  83
  84 M: word word-completion-string
  85     name>> ;
  86
  87 M: method-body word-completion-string
  88     "method-generic" word-prop word-completion-string ;
  89
  90 USE: generic.standard.engines.tuple
  91
  92 M: engine-word word-completion-string
  93     "engine-generic" word-prop word-completion-string ;
  94
  95 : use-if-necessary ( word seq -- )
  96     over vocabulary>> over and [
  97         2dup [ assoc-stack ] keep = [ 2drop ] [
  98             [ vocabulary>> vocab-words ] dip push
  99         ] if
 100     ] [ 2drop ] if ;
 101
 102 : insert-word ( word -- )
 103     get-workspace listener>> input>>
 104     [ [ word-completion-string ] dip user-input* drop ]
 105     [ interactor-use use-if-necessary ]
 106     2bi ;
 107
 108 : quot-action ( interactor -- lines )
 109     [ control-value ] keep
 110     [ [ "\n" join ] dip add-interactor-history ]
 111     [ select-all ]
 112     2bi ;
 113
 114 : ui-help-hook ( topic -- )
 115     browser-gadget call-tool ;
 116
 117 : ui-error-hook ( error listener -- )
 118     find-workspace debugger-popup ;
 119
 120 : ui-inspector-hook ( obj listener -- )
 121     find-workspace inspector-gadget
 122     swap show-tool inspect-object ;
 123
 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
 129         welcome.
 130         listener
 131     ] with-streams* ;
 132
 133 : start-listener-thread ( listener -- )
 134     '[
 135         _
 136         [ input>> register-self ]
 137         [ listener-thread ]
 138         bi
 139     ] "Listener" spawn drop ;
 140
 141 : restart-listener ( listener -- )
 142     #! Returns when listener is ready to receive input.
 143     {
 144         [ com-end ]
 145         [ clear-output ]
 146         [ input>> clear-input ]
 147         [ start-listener-thread ]
 148         [ wait-for-listener ]
 149     } cleave ;
 150
 151 : init-listener ( listener -- listener )
 152     <scrolling-pane> >>output
 153     dup <listener-input> >>input ;
 154
 155 : <listener-scroller> ( listener -- scroller )
 156     <frame>
 157         over output>> @top grid-add
 158         swap input>> @center grid-add
 159     <scroller> ;
 160
 161 : <listener-gadget> ( -- gadget )
 162     { 0 1 } listener-gadget new-track
 163         add-toolbar
 164         init-listener
 165         dup <listener-scroller> 1 track-add ;
 166
 167 : listener-help ( -- ) "ui-listener" help-window ;
 168
 169 \ listener-help H{ { +nullary+ t } } define-command
 170
 171 : com-auto-use ( -- )
 172     auto-use? [ not ] change ;
 173
 174 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
 175
 176 listener-gadget "misc" "Miscellaneous commands" {
 177     { T{ key-down f f "F1" } listener-help }
 178 } define-command-map
 179
 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 }
 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 ;