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