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