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