basis/ui/tools/listener/listener.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs calendar combinators
   4 combinators.short-circuit concurrency.flags
   5 concurrency.mailboxes continuations destructors documents
   6 documents.elements fonts fry hashtables help help.markup
   7 help.tips io io.styles kernel lexer listener literals locals
   8 math models models.arrow models.delay namespaces parser
   9 prettyprint sequences source-files.errors strings system threads
  10 tools.errors.model ui ui.commands ui.gadgets ui.gadgets.editors
  11 ui.gadgets.glass ui.gadgets.labeled ui.gadgets.panes
  12 ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.theme
  13 ui.gadgets.toolbar ui.gadgets.tracks ui.gestures ui.operations
  14 ui.pens.solid ui.tools.browser ui.tools.common ui.tools.debugger
  15 ui.tools.error-list ui.tools.listener.completion
  16 ui.tools.listener.history ui.tools.listener.popups vocabs
  17 vocabs.loader vocabs.parser vocabs.refresh words ;
  18 IN: ui.tools.listener
  19
  20 TUPLE: interactor < source-editor
  21     output history flag mailbox thread waiting token-model word-model popup ;
  22
  23 INSTANCE: interactor input-stream
  24
  25 : register-self ( interactor -- )
  26     <mailbox> >>mailbox
  27     self >>thread
  28     drop ;
  29
  30 : interactor-continuation ( interactor -- continuation )
  31     thread>> thread-continuation ;
  32
  33 : interactor-busy? ( interactor -- ? )
  34     {
  35         [ waiting>> ]
  36         [ thread>> dup [ thread-registered? ] when ]
  37     } 1&& not ;
  38
  39 SLOT: manifest
  40
  41 M: interactor manifest>>
  42     dup interactor-busy? [ drop f ] [
  43         interactor-continuation name>>
  44         manifest swap assoc-stack
  45     ] if ;
  46
  47 : vocab-exists? ( name -- ? )
  48     '[ _ { [ lookup-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     manifest>> [
  57         '[ _ _ search-manifest ] [ drop f ] recover
  58     ] [ drop f ] if* ;
  59
  60 M: char-completion (word-at-caret) 2drop f ;
  61
  62 M: path-completion (word-at-caret) 2drop f ;
  63
  64 M: color-completion (word-at-caret) 2drop f ;
  65
  66 : word-at-caret ( token interactor -- obj )
  67     completion-mode (word-at-caret) ;
  68
  69 : <word-model> ( interactor -- model )
  70     [ token-model>> 1/3 seconds <delay> ]
  71     [ '[ _ word-at-caret ] ] bi
  72     <arrow> ;
  73
  74 : <interactor> ( -- gadget )
  75     interactor new-editor
  76         <flag> >>flag
  77         dup one-word-elt <element-model> >>token-model
  78         dup <word-model> >>word-model
  79         dup model>> <history> >>history ;
  80
  81 M: interactor graft*
  82     [ call-next-method ] [ dup word-model>> add-connection ] bi ;
  83
  84 M: interactor ungraft*
  85     [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
  86
  87 M: interactor model-changed
  88     2dup word-model>> eq? [
  89         dup popup>>
  90         [ 2drop ] [ [ value>> ] dip show-summary ] if
  91     ] [ call-next-method ] if ;
  92
  93 M: interactor stream-element-type drop +character+ ;
  94
  95 GENERIC: (print-input) ( object -- )
  96
  97 M: input (print-input)
  98     dup presented associate
  99     [ string>> H{ { font-style bold } } format ] with-nesting nl ;
 100
 101 M: word (print-input)
 102     "Command: " H{ { font-name "sans-serif" } { font-style bold } }
 103     format . ;
 104
 105 : print-input ( object interactor -- )
 106     output>> [ (print-input) ] with-output-stream* ;
 107
 108 : interactor-continue ( obj interactor -- )
 109     mailbox>> mailbox-put ;
 110
 111 : interactor-finish ( interactor -- )
 112     [ history>> history-add ] keep
 113     [ print-input ]
 114     [ clear-editor drop ]
 115     [ model>> clear-undo drop ] 2tri ;
 116
 117 : interactor-eof ( interactor -- )
 118     dup interactor-busy? [
 119         f over interactor-continue
 120     ] unless drop ;
 121
 122 : evaluate-input ( interactor -- )
 123     dup interactor-busy? [ drop ] [
 124         [ control-value ] keep interactor-continue
 125     ] if ;
 126
 127 : interactor-yield ( interactor -- obj )
 128     dup thread>> self eq? [
 129         {
 130             [ t >>waiting drop ]
 131             [ flag>> raise-flag ]
 132             [ mailbox>> mailbox-get ]
 133             [ f >>waiting drop ]
 134         } cleave
 135     ] [ drop f ] if ;
 136
 137 : interactor-read ( interactor -- lines )
 138     [ interactor-yield ] [ interactor-finish ] bi ;
 139
 140 M: interactor stream-readln
 141     interactor-read dup [ first ] when ;
 142
 143 : (call-listener) ( quot command listener -- )
 144     input>> dup interactor-busy? [ 3drop ] [
 145         [ print-input drop ]
 146         [ nip interactor-continue ]
 147         3bi
 148     ] if ;
 149
 150 M:: interactor stream-read-unsafe ( n buf interactor -- count )
 151     n [ 0 ] [
 152         drop
 153         interactor interactor-read dup [ "\n" join ] when
 154         n short [ head-slice 0 buf copy ] keep
 155     ] if-zero ;
 156
 157 M: interactor stream-read1
 158     dup interactor-read {
 159         { [ dup not ] [ 2drop f ] }
 160         { [ dup empty? ] [ drop stream-read1 ] }
 161         { [ dup first empty? ] [ 2drop CHAR: \n ] }
 162         [ nip first first ]
 163     } cond ;
 164
 165 M: interactor stream-read-until ( seps stream -- seq sep/f )
 166     swap '[
 167         _ interactor-read [
 168             "\n" join CHAR: \n suffix
 169             [ _ member? ] dupd find
 170             [ [ head ] when* ] dip dup not
 171         ] [ f f f ] if*
 172     ] [ drop ] produce swap [ concat "" prepend-as ] dip ;
 173
 174 M: interactor dispose drop ;
 175
 176 : go-to-error ( interactor error -- )
 177     [ line>> 1 - ] [ column>> ] bi 2array
 178     over set-caret
 179     mark>caret ;
 180
 181 TUPLE: listener-gadget < tool error-summary output scroller input ;
 182
 183 { 600 700 } listener-gadget set-tool-dim
 184
 185 : listener-streams ( listener -- input output )
 186     [ input>> ] [ output>> <pane-stream> ] bi ;
 187
 188 : init-input/output ( listener -- listener )
 189     <interactor>
 190     [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
 191     dup listener-streams >>output drop ;
 192
 193 : error-summary. ( -- )
 194     error-counts keys [
 195         H{ { table-gap { 3 3 } } } [
 196             [ [ [ icon>> write-image ] with-cell ] each ] with-row
 197         ] tabular-output
 198         last-element off
 199         { "Press " { $command tool "common" show-error-list } " to view errors." }
 200         print-element
 201     ] unless-empty ;
 202
 203 : <error-summary> ( -- gadget )
 204     error-list-model get [ drop error-summary. ] <pane-control>
 205     error-summary-background <solid> >>interior ;
 206
 207 : init-error-summary ( listener -- listener )
 208     <error-summary> >>error-summary
 209     dup error-summary>> f track-add ;
 210
 211 : add-listener-area ( listener -- listener )
 212     dup output>> margins <scroller> >>scroller
 213     dup scroller>> white-interior 1 track-add ;
 214
 215 : <listener-gadget> ( -- listener )
 216     vertical listener-gadget new-track with-lines
 217     add-toolbar
 218     init-input/output
 219     add-listener-area
 220     init-error-summary ;
 221
 222 M: listener-gadget focusable-child*
 223     input>> dup popup>> or ;
 224
 225 : wait-for-listener ( listener -- )
 226     input>> flag>> 5 seconds wait-for-flag-timeout ;
 227
 228 : listener-busy? ( listener -- ? )
 229     input>> interactor-busy? ;
 230
 231 : listener-window* ( -- listener )
 232     <listener-gadget>
 233     dup "Listener" open-status-window ;
 234
 235 : listener-window ( -- )
 236     [ listener-window* drop ] with-ui ;
 237
 238 \ listener-window H{ { +nullary+ t } } define-command
 239
 240 : (get-listener) ( quot -- listener )
 241     find-window [
 242         [ raise-window ]
 243         [
 244             gadget-child
 245             [ ]
 246             [ input>> scroll>caret ]
 247             [ input>> request-focus ] tri
 248         ] bi
 249     ] [ listener-window* ] if* ; inline
 250
 251 : get-listener ( -- listener )
 252     [ listener-gadget? ] (get-listener) ;
 253
 254 : show-listener ( -- )
 255     get-listener drop ;
 256
 257 \ show-listener H{ { +nullary+ t } } define-command
 258
 259 : get-ready-listener ( -- listener )
 260     [
 261         {
 262             [ listener-gadget? ]
 263             [ listener-busy? not ]
 264         } 1&&
 265     ] (get-listener) ;
 266
 267 GENERIC: listener-input ( obj -- )
 268
 269 M: input listener-input string>> listener-input ;
 270
 271 M: string listener-input
 272     get-listener input>>
 273     [ set-editor-string ] [ request-focus ] bi ;
 274
 275 : call-listener ( quot command -- )
 276     get-ready-listener
 277     '[ _ _ _ dup wait-for-listener (call-listener) ]
 278     "Listener call" spawn drop ;
 279
 280 M: listener-command invoke-command ( target command -- )
 281     [ command-quot ] [ nip ] 2bi call-listener ;
 282
 283 M: listener-operation invoke-command ( target command -- )
 284     [ operation-quot ] [ nip command>> ] 2bi call-listener ;
 285
 286 : eval-listener ( string -- )
 287     get-listener input>> [ set-editor-string ] keep
 288     evaluate-input ;
 289
 290 : listener-run-files ( seq -- )
 291     [
 292         '[ _ [ run-file ] each ]
 293         \ listener-run-files
 294         call-listener
 295     ] unless-empty ;
 296
 297 : com-end ( listener -- )
 298     input>> interactor-eof ;
 299
 300 : clear-output ( listener -- )
 301     output>> pane-clear ;
 302
 303 \ clear-output H{ { +listener+ t } } define-command
 304
 305 : clear-stack ( listener -- )
 306     [ [ clear ] \ clear ] dip (call-listener) ;
 307
 308 : use-if-necessary ( word manifest -- )
 309     2dup [ vocabulary>> ] dip and [
 310         manifest [
 311             [ vocabulary>> use-vocab ]
 312             [ dup name>> associate use-words ] bi
 313         ] with-variable
 314     ] [ 2drop ] if ;
 315
 316 M: word accept-completion-hook
 317     interactor>> manifest>> use-if-necessary ;
 318
 319 M: object accept-completion-hook 2drop ;
 320
 321 : quot-action ( interactor -- lines )
 322     [ history>> history-add drop ] [ control-value ] [ select-all ] tri
 323     parse-lines-interactive ;
 324
 325 : do-recall? ( table error -- ? )
 326     [ selection>> value>> not ] [ lexer-error? ] bi* and ;
 327
 328 : recall-lexer-error ( interactor error -- )
 329     over recall-previous go-to-error ;
 330
 331 : make-restart-hook-quot ( error interactor -- quot )
 332     over '[
 333         dup hide-glass
 334         _ do-recall? [ _ _ recall-lexer-error ] when
 335     ] ;
 336
 337 : frame-debugger ( debugger -- labeled )
 338     "Error" debugger-color <framed-labeled> ;
 339
 340 :: <debugger-popup> ( error continuation interactor -- popup )
 341     error
 342     continuation
 343     error compute-restarts
 344     error interactor make-restart-hook-quot
 345     <debugger> frame-debugger ;
 346
 347 : debugger-popup ( interactor error continuation -- )
 348     pick <debugger-popup> one-line-elt swap show-listener-popup ;
 349
 350 : try-parse ( lines -- quot/f )
 351     [ parse-lines-interactive ] [ nip '[ _ rethrow ] ] recover ;
 352
 353 M: interactor stream-read-quot ( stream -- quot/f )
 354     dup interactor-yield dup array? [
 355         over interactor-finish try-parse
 356         [ nip ] [ stream-read-quot ] if*
 357     ] [ nip ] if ;
 358
 359 : interactor-operation ( gesture interactor -- ? )
 360     [ token-model>> value>> ] keep word-at-caret
 361     [ nip ] [ gesture>operation ] 2bi
 362     [ invoke-command f ] [ drop t ] if* ;
 363
 364 M: interactor handle-gesture
 365     {
 366         { [ over key-gesture? not ] [ call-next-method ] }
 367         { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
 368         {
 369             [ dup token-model>> value>> ]
 370             [ { [ interactor-operation ] [ call-next-method ] } 2&& ]
 371         }
 372         [ call-next-method ]
 373     } cond ;
 374
 375 interactor "interactor" f {
 376     { T{ key-down f f "RET" } evaluate-input }
 377     { T{ key-down f { C+ } "k" } clear-editor }
 378 } define-command-map
 379
 380 interactor "completion" f {
 381     { T{ key-down f f "TAB" } code-completion-popup }
 382     { T{ key-down f { C+ } "p" } recall-previous }
 383     { T{ key-down f { C+ } "n" } recall-next }
 384     { T{ key-down f { C+ } "r" } history-completion-popup }
 385 } define-command-map
 386
 387 : introduction. ( -- )
 388     [
 389         H{ { font-size $ default-font-size } } [
 390             { $tip-of-the-day } print-element nl
 391             { $strong "Press " { $snippet "F1" } " at any time for help." } print-element nl
 392             version-info print-element
 393         ] with-style
 394     ] with-default-style nl nl ;
 395
 396 : listener-thread ( listener -- )
 397     dup listener-streams [
 398         [ com-browse ] help-hook set
 399         '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
 400         error-summary? off
 401         introduction.
 402         listener
 403         nl
 404         "The listener has exited. To start it again, click “Restart Listener”." print
 405     ] with-input-output+error-streams* ;
 406
 407 : start-listener-thread ( listener -- )
 408     '[
 409         _
 410         [ input>> register-self ]
 411         [ listener-thread ]
 412         bi
 413     ] "Listener" spawn drop ;
 414
 415 : restart-listener ( listener -- )
 416     ! Returns when listener is ready to receive input.
 417     {
 418         [ com-end ]
 419         [ clear-output ]
 420         [ input>> clear-editor ]
 421         [ start-listener-thread ]
 422         [ wait-for-listener ]
 423     } cleave ;
 424
 425 : com-help ( -- ) "help.home" com-browse ;
 426
 427 \ com-help H{ { +nullary+ t } } define-command
 428
 429 : com-auto-use ( -- )
 430     auto-use? toggle ;
 431
 432 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
 433
 434 listener-gadget "toolbar" f {
 435     { f restart-listener }
 436     { T{ key-down f { A+ } "u" } com-auto-use }
 437     { T{ key-down f { A+ } "k" } clear-output }
 438     { T{ key-down f { A+ } "K" } clear-stack }
 439     { T{ key-down f { C+ } "d" } com-end }
 440     { T{ key-down f f "F1" } com-help }
 441 } define-command-map
 442
 443 listener-gadget "scrolling"
 444 "The listener's scroller can be scrolled from the keyboard."
 445 {
 446     { T{ key-down f { A+ } "UP" } com-scroll-up }
 447     { T{ key-down f { A+ } "DOWN" } com-scroll-down }
 448     { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
 449     { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
 450 } define-command-map
 451
 452 listener-gadget "multi-touch" f {
 453     { up-action refresh-all }
 454 } define-command-map
 455
 456 M: listener-gadget graft*
 457     [ call-next-method ] [ restart-listener ] bi ;
 458
 459 M: listener-gadget ungraft*
 460     [ com-end ] [ call-next-method ] bi ;
 461
 462 <PRIVATE
 463
 464 :: make-font-style ( family size -- assoc )
 465     H{ } clone
 466         family font-name pick set-at
 467         size font-size pick set-at ;
 468
 469 PRIVATE>
 470
 471 :: set-listener-font ( family size -- )
 472     get-listener input>> :> inter
 473     family size make-font-style
 474     inter output>> make-span-stream :> ostream
 475     ostream inter output<<
 476     inter font>> clone
 477         family >>name
 478         size >>size
 479     inter font<<
 480     ostream output-stream set ;