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