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