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