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