basis/ui/tools/listener/listener.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs calendar combinators locals
   4 colors.constants combinators.short-circuit compiler.units
   5 help.tips concurrency.flags concurrency.mailboxes continuations
   6 destructors documents documents.elements fry hashtables help
   7 help.markup io io.styles kernel lexer listener math models
   8 models.delay models.arrow namespaces parser prettyprint quotations
   9 sequences strings threads tools.vocabs vocabs vocabs.loader
  10 vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
  11 ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors
  12 ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
  13 ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
  14 ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
  15 ui.tools.listener.completion ui.tools.listener.popups
  16 ui.tools.listener.history ;
  17 IN: ui.tools.listener
  18
  19 ! If waiting is t, we're waiting for user input, and invoking
  20 ! evaluate-input resumes the thread.
  21 TUPLE: interactor < source-editor
  22 output history flag mailbox thread waiting token-model word-model popup ;
  23
  24 : register-self ( interactor -- )
  25     <mailbox> >>mailbox
  26     self >>thread
  27     drop ;
  28
  29 : interactor-continuation ( interactor -- continuation )
  30     thread>> continuation>> value>> ;
  31
  32 : interactor-busy? ( interactor -- ? )
  33     #! We're busy if there's no thread to resume.
  34     [ waiting>> ]
  35     [ thread>> dup [ thread-registered? ] when ]
  36     bi and not ;
  37
  38 SLOT: vocabs
  39
  40 M: interactor vocabs>>
  41     dup interactor-busy? [ drop f ] [
  42         use swap
  43         interactor-continuation name>>
  44         assoc-stack
  45     ] if ;
  46
  47 : vocab-exists? ( name -- ? )
  48     '[ _ { [ vocab ] [ find-vocab-root ] } 1|| ] [ drop f ] recover ;
  49
  50 GENERIC: (word-at-caret) ( token completion-mode -- obj )
  51
  52 M: vocab-completion (word-at-caret)
  53     drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
  54
  55 M: word-completion (word-at-caret)
  56     vocabs>> assoc-stack ;
  57
  58 M: char-completion (word-at-caret)
  59     2drop f ;
  60
  61 : word-at-caret ( token interactor -- obj )
  62     completion-mode (word-at-caret) ;
  63
  64 : <word-model> ( interactor -- model )
  65     [ token-model>> 1/3 seconds <delay> ]
  66     [ '[ _ word-at-caret ] ] bi
  67     <arrow> ;
  68
  69 : <interactor> ( -- gadget )
  70     interactor new-editor
  71         <flag> >>flag
  72         dup one-word-elt <element-model> >>token-model
  73         dup <word-model> >>word-model
  74         dup model>> <history> >>history ;
  75
  76 M: interactor graft*
  77     [ call-next-method ] [ dup word-model>> add-connection ] bi ;
  78
  79 M: interactor ungraft*
  80     [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
  81
  82 M: interactor model-changed
  83     2dup word-model>> eq? [
  84         dup popup>>
  85         [ 2drop ] [ [ value>> ] dip show-summary ] if
  86     ] [ call-next-method ] if ;
  87
  88 M: interactor stream-element-type drop +character+ ;
  89
  90 GENERIC: (print-input) ( object -- )
  91
  92 M: input (print-input)
  93     dup presented associate
  94     [ string>> H{ { font-style bold } } format ] with-nesting nl ;
  95
  96 M: word (print-input)
  97     "Command: "
  98     [
  99         "sans-serif" font-name set
 100         bold font-style set
 101     ] H{ } make-assoc format . ;
 102
 103 : print-input ( object interactor -- )
 104     output>> [ (print-input) ] with-output-stream* ;
 105
 106 : interactor-continue ( obj interactor -- )
 107     mailbox>> mailbox-put ;
 108
 109 : interactor-finish ( interactor -- )
 110     [ history>> history-add ] keep
 111     [ print-input ]
 112     [ clear-editor drop ]
 113     [ model>> clear-undo drop ] 2tri ;
 114
 115 : interactor-eof ( interactor -- )
 116     dup interactor-busy? [
 117         f over interactor-continue
 118     ] unless drop ;
 119
 120 : evaluate-input ( interactor -- )
 121     dup interactor-busy? [ drop ] [
 122         [ control-value ] keep interactor-continue
 123     ] if ;
 124
 125 : interactor-yield ( interactor -- obj )
 126     dup thread>> self eq? [
 127         {
 128             [ t >>waiting drop ]
 129             [ flag>> raise-flag ]
 130             [ mailbox>> mailbox-get ]
 131             [ f >>waiting drop ]
 132         } cleave
 133     ] [ drop f ] if ;
 134
 135 : interactor-read ( interactor -- lines )
 136     [ interactor-yield ] [ interactor-finish ] bi ;
 137
 138 M: interactor stream-readln
 139     interactor-read dup [ first ] when ;
 140
 141 : (call-listener) ( quot command listener -- )
 142     input>> dup interactor-busy? [ 3drop ] [
 143         [ print-input drop ]
 144         [ nip interactor-continue ]
 145         3bi
 146     ] if ;
 147
 148 M: interactor stream-read
 149     swap dup zero? [
 150         2drop ""
 151     ] [
 152         [ interactor-read dup [ "\n" join ] when ] dip short head
 153     ] if ;
 154
 155 M: interactor stream-read-partial
 156     stream-read ;
 157
 158 M: interactor stream-read1
 159     dup interactor-read {
 160         { [ dup not ] [ 2drop f ] }
 161         { [ dup empty? ] [ drop stream-read1 ] }
 162         { [ dup first empty? ] [ 2drop CHAR: \n ] }
 163         [ nip first first ]
 164     } cond ;
 165
 166 M: interactor dispose drop ;
 167
 168 : go-to-error ( interactor error -- )
 169     [ line>> 1- ] [ column>> ] bi 2array
 170     over set-caret
 171     mark>caret ;
 172
 173 TUPLE: listener-gadget < tool input output scroller ;
 174
 175 { 600 700 } listener-gadget set-tool-dim
 176
 177 : find-listener ( gadget -- listener )
 178     [ listener-gadget? ] find-parent ;
 179
 180 : listener-streams ( listener -- input output )
 181     [ input>> ] [ output>> <pane-stream> ] bi ;
 182
 183 : init-listener ( listener -- listener )
 184     <interactor>
 185     [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
 186     dup listener-streams >>output drop ;
 187
 188 : <listener-gadget> ( -- gadget )
 189     vertical listener-gadget new-track
 190         add-toolbar
 191         init-listener
 192         dup output>> <scroller> >>scroller
 193         dup scroller>> 1 track-add ;
 194
 195 M: listener-gadget focusable-child*
 196     input>> dup popup>> or ;
 197
 198 : wait-for-listener ( listener -- )
 199     #! Wait for the listener to start.
 200     input>> flag>> wait-for-flag ;
 201
 202 : listener-busy? ( listener -- ? )
 203     input>> interactor-busy? ;
 204
 205 : listener-window* ( -- listener )
 206     <listener-gadget>
 207     dup "Listener" open-status-window ;
 208
 209 : listener-window ( -- )
 210     [ listener-window* drop ] with-ui ;
 211
 212 \ listener-window H{ { +nullary+ t } } define-command
 213
 214 : (get-listener) ( quot -- listener )
 215     find-window [
 216         [ raise-window ]
 217         [
 218             gadget-child
 219             [ ]
 220             [ input>> scroll>caret ]
 221             [ input>> request-focus ] tri
 222         ] bi
 223     ] [ listener-window* ] if* ; inline
 224
 225 : get-listener ( -- listener )
 226     [ listener-gadget? ] (get-listener) ;
 227
 228 : show-listener ( -- )
 229     get-listener drop ;
 230
 231 \ show-listener H{ { +nullary+ t } } define-command
 232
 233 : get-ready-listener ( -- listener )
 234     [
 235         {
 236             [ listener-gadget? ]
 237             [ listener-busy? not ]
 238         } 1&&
 239     ] (get-listener) ;
 240
 241 GENERIC: listener-input ( obj -- )
 242
 243 M: input listener-input string>> listener-input ;
 244
 245 M: string listener-input
 246     get-listener input>>
 247     [ set-editor-string ] [ request-focus ] bi ;
 248
 249 : call-listener ( quot command -- )
 250     get-ready-listener
 251     '[ _ _ _ dup wait-for-listener (call-listener) ]
 252     "Listener call" spawn drop ;
 253
 254 M: listener-command invoke-command ( target command -- )
 255     [ command-quot ] [ nip ] 2bi call-listener ;
 256
 257 M: listener-operation invoke-command ( target command -- )
 258     [ operation-quot ] [ nip command>> ] 2bi call-listener ;
 259
 260 : eval-listener ( string -- )
 261     get-listener input>> [ set-editor-string ] keep
 262     evaluate-input ;
 263
 264 : listener-run-files ( seq -- )
 265     [
 266         [ \ listener-run-files ] dip
 267         '[ _ [ run-file ] each ] call-listener
 268     ] unless-empty ;
 269
 270 : com-end ( listener -- )
 271     input>> interactor-eof ;
 272
 273 : clear-output ( listener -- )
 274     output>> pane-clear ;
 275
 276 \ clear-output H{ { +listener+ t } } define-command
 277
 278 : clear-stack ( listener -- )
 279     [ [ clear ] \ clear ] dip (call-listener) ;
 280
 281 : use-if-necessary ( word seq -- )
 282     2dup [ vocabulary>> ] dip and [
 283         2dup [ assoc-stack ] keep = [ 2drop ] [
 284             [ vocabulary>> vocab-words ] dip push
 285         ] if
 286     ] [ 2drop ] if ;
 287
 288 M: word accept-completion-hook
 289     interactor>> vocabs>> use-if-necessary ;
 290
 291 M: object accept-completion-hook 2drop ;
 292
 293 : quot-action ( interactor -- lines )
 294     [ history>> history-add drop ] [ control-value ] [ select-all ] tri
 295     [ parse-lines ] with-compilation-unit ;
 296
 297 : <debugger-popup> ( error continuation -- popup )
 298     over compute-restarts [ hide-glass ] <debugger> "Error" <labeled-gadget> ;
 299
 300 : debugger-popup ( interactor error continuation -- )
 301     [ one-line-elt ] 2dip <debugger-popup> show-listener-popup ;
 302
 303 : handle-parse-error ( interactor error -- )
 304     dup lexer-error? [ 2dup go-to-error error>> ] when
 305     error-continuation get
 306     debugger-popup ;
 307
 308 : try-parse ( lines interactor -- quot/error/f )
 309     [ drop parse-lines-interactive ] [
 310         2nip
 311         dup lexer-error? [
 312             dup error>> unexpected-eof? [ drop f ] when
 313         ] when
 314     ] recover ;
 315
 316 : handle-interactive ( lines interactor -- quot/f ? )
 317     [ nip ] [ try-parse ] 2bi {
 318         { [ dup quotation? ] [ nip t ] }
 319         { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
 320         [ handle-parse-error f f ]
 321     } cond ;
 322
 323 M: interactor stream-read-quot
 324     [ interactor-yield ] keep {
 325         { [ over not ] [ drop ] }
 326         { [ over callable? ] [ drop ] }
 327         [
 328             [ handle-interactive ] keep swap
 329             [ interactor-finish ] [ nip stream-read-quot ] if
 330         ]
 331     } cond ;
 332
 333 : interactor-operation ( gesture interactor -- ? )
 334     [ token-model>> value>> ] keep word-at-caret
 335     [ nip ] [ gesture>operation ] 2bi
 336     dup [ invoke-command f ] [ 2drop t ] if ;
 337
 338 M: interactor handle-gesture
 339     {
 340         { [ over key-gesture? not ] [ call-next-method ] }
 341         { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
 342         { [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
 343         [ call-next-method ]
 344     } cond ;
 345
 346 interactor "interactor" f {
 347     { T{ key-down f f "RET" } evaluate-input }
 348     { T{ key-down f { C+ } "k" } clear-editor }
 349 } define-command-map
 350
 351 interactor "completion" f {
 352     { T{ key-down f f "TAB" } code-completion-popup }
 353     { T{ key-down f { C+ } "p" } recall-previous }
 354     { T{ key-down f { C+ } "n" } recall-next }
 355     { T{ key-down f { C+ } "r" } history-completion-popup }
 356 } define-command-map
 357
 358 : listener-thread ( listener -- )
 359     dup listener-streams [
 360         [ com-browse ] help-hook set
 361         '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
 362         tip-of-the-day. nl
 363         listener
 364     ] with-streams* ;
 365
 366 : start-listener-thread ( listener -- )
 367     '[
 368         _
 369         [ input>> register-self ]
 370         [ listener-thread ]
 371         bi
 372     ] "Listener" spawn drop ;
 373
 374 : restart-listener ( listener -- )
 375     #! Returns when listener is ready to receive input.
 376     {
 377         [ com-end ]
 378         [ clear-output ]
 379         [ input>> clear-editor ]
 380         [ start-listener-thread ]
 381         [ wait-for-listener ]
 382     } cleave ;
 383
 384 : listener-help ( -- ) "help.home" com-browse ;
 385
 386 \ listener-help H{ { +nullary+ t } } define-command
 387
 388 : com-auto-use ( -- )
 389     auto-use? [ not ] change ;
 390
 391 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
 392
 393 listener-gadget "misc" "Miscellaneous commands" {
 394     { T{ key-down f f "F1" } listener-help }
 395 } define-command-map
 396
 397 listener-gadget "toolbar" f {
 398     { f restart-listener }
 399     { T{ key-down f { A+ } "u" } com-auto-use }
 400     { T{ key-down f { A+ } "k" } clear-output }
 401     { T{ key-down f { A+ } "K" } clear-stack }
 402     { T{ key-down f { C+ } "d" } com-end }
 403 } define-command-map
 404
 405 listener-gadget "scrolling"
 406 "The listener's scroller can be scrolled from the keyboard."
 407 {
 408     { T{ key-down f { A+ } "UP" } com-scroll-up }
 409     { T{ key-down f { A+ } "DOWN" } com-scroll-down }
 410     { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
 411     { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
 412 } define-command-map
 413
 414 listener-gadget "multi-touch" f {
 415     { up-action refresh-all }
 416 } define-command-map
 417
 418 M: listener-gadget graft*
 419     [ call-next-method ] [ restart-listener ] bi ;
 420
 421 M: listener-gadget ungraft*
 422     [ com-end ] [ call-next-method ] bi ;