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 locals
   4 source-files.errors colors.constants combinators.short-circuit
   5 compiler.units help.tips concurrency.flags concurrency.mailboxes
   6 continuations destructors documents documents.elements fry hashtables
   7 help help.markup io io.styles kernel lexer listener math models sets
   8 models.delay models.arrow namespaces parser prettyprint quotations
   9 sequences strings threads vocabs vocabs.refresh vocabs.loader
  10 vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
  11 ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors
  12 ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
  13 ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
  14 ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
  15 ui.tools.listener.completion ui.tools.listener.popups
  16 ui.tools.listener.history ui.images ui.tools.error-list
  17 tools.errors.model ;
  18 FROM: source-files.errors => all-errors ;
  19 FROM: namespaces => set ;
  20 IN: ui.tools.listener
  21
  22 ! If waiting is t, we're waiting for user input, and invoking
  23 ! evaluate-input resumes the thread.
  24 TUPLE: interactor < source-editor
  25 output history flag mailbox thread waiting token-model word-model popup ;
  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     '[ _ { [ 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)
  64     2drop f ;
  65
  66 : word-at-caret ( token interactor -- obj )
  67     completion-mode (word-at-caret) ;
  68
  69 : <word-model> ( interactor -- model )
  70     [ token-model>> 1/3 seconds <delay> ]
  71     [ '[ _ word-at-caret ] ] bi
  72     <arrow> ;
  73
  74 : <interactor> ( -- gadget )
  75     interactor new-editor
  76         <flag> >>flag
  77         dup one-word-elt <element-model> >>token-model
  78         dup <word-model> >>word-model
  79         dup model>> <history> >>history ;
  80
  81 M: interactor graft*
  82     [ call-next-method ] [ dup word-model>> add-connection ] bi ;
  83
  84 M: interactor ungraft*
  85     [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
  86
  87 M: interactor model-changed
  88     2dup word-model>> eq? [
  89         dup popup>>
  90         [ 2drop ] [ [ value>> ] dip show-summary ] if
  91     ] [ call-next-method ] if ;
  92
  93 M: interactor stream-element-type drop +character+ ;
  94
  95 GENERIC: (print-input) ( object -- )
  96
  97 M: input (print-input)
  98     dup presented associate
  99     [ string>> H{ { font-style bold } } format ] with-nesting nl ;
 100
 101 M: word (print-input)
 102     "Command: "
 103     [
 104         "sans-serif" font-name set
 105         bold font-style set
 106     ] H{ } make-assoc format . ;
 107
 108 : print-input ( object interactor -- )
 109     output>> [ (print-input) ] with-output-stream* ;
 110
 111 : interactor-continue ( obj interactor -- )
 112     mailbox>> mailbox-put ;
 113
 114 : interactor-finish ( interactor -- )
 115     [ history>> history-add ] keep
 116     [ print-input ]
 117     [ clear-editor drop ]
 118     [ model>> clear-undo drop ] 2tri ;
 119
 120 : interactor-eof ( interactor -- )
 121     dup interactor-busy? [
 122         f over interactor-continue
 123     ] unless drop ;
 124
 125 : evaluate-input ( interactor -- )
 126     dup interactor-busy? [ drop ] [
 127         [ control-value ] keep interactor-continue
 128     ] if ;
 129
 130 : interactor-yield ( interactor -- obj )
 131     dup thread>> self eq? [
 132         {
 133             [ t >>waiting drop ]
 134             [ flag>> raise-flag ]
 135             [ mailbox>> mailbox-get ]
 136             [ f >>waiting drop ]
 137         } cleave
 138     ] [ drop f ] if ;
 139
 140 : interactor-read ( interactor -- lines )
 141     [ interactor-yield ] [ interactor-finish ] bi ;
 142
 143 M: interactor stream-readln
 144     interactor-read dup [ first ] when ;
 145
 146 : (call-listener) ( quot command listener -- )
 147     input>> dup interactor-busy? [ 3drop ] [
 148         [ print-input drop ]
 149         [ nip interactor-continue ]
 150         3bi
 151     ] if ;
 152
 153 M: interactor stream-read
 154     swap [
 155         drop ""
 156     ] [
 157         [ interactor-read dup [ "\n" join ] when ] dip short head
 158     ] if-zero ;
 159
 160 M: interactor stream-read-partial
 161     stream-read ;
 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 dispose drop ;
 172
 173 : go-to-error ( interactor error -- )
 174     [ line>> 1 - ] [ column>> ] bi 2array
 175     over set-caret
 176     mark>caret ;
 177
 178 TUPLE: listener-gadget < tool error-summary output scroller input ;
 179
 180 { 600 700 } listener-gadget set-tool-dim
 181
 182 : find-listener ( gadget -- listener )
 183     [ listener-gadget? ] find-parent ;
 184
 185 : listener-streams ( listener -- input output )
 186     [ input>> ] [ output>> <pane-stream> ] bi ;
 187
 188 : init-input/output ( listener -- listener )
 189     <interactor>
 190     [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
 191     dup listener-streams >>output drop ;
 192
 193 : error-summary. ( -- )
 194     error-counts keys [
 195         H{ { table-gap { 3 3 } } } [
 196             [ [ [ icon>> write-image ] with-cell ] each ] with-row
 197         ] tabular-output
 198         last-element off
 199         { "Press " { $command tool "common" show-error-list } " to view errors." }
 200         print-element
 201     ] unless-empty ;
 202
 203 : <error-summary> ( -- gadget )
 204     error-list-model get [ drop error-summary. ] <pane-control>
 205         COLOR: light-yellow <solid> >>interior ;
 206
 207 : init-error-summary ( listener -- listener )
 208     <error-summary> >>error-summary
 209     dup error-summary>> f track-add ;
 210
 211 : <listener-gadget> ( -- listener )
 212     vertical listener-gadget new-track
 213         add-toolbar
 214         init-input/output
 215         dup output>> <scroller> >>scroller
 216         dup scroller>> 1 track-add
 217         init-error-summary ;
 218
 219 M: listener-gadget focusable-child*
 220     input>> dup popup>> or ;
 221
 222 : wait-for-listener ( listener -- )
 223     #! Wait for the listener to start.
 224     input>> flag>> wait-for-flag ;
 225
 226 : listener-busy? ( listener -- ? )
 227     input>> interactor-busy? ;
 228
 229 : listener-window* ( -- listener )
 230     <listener-gadget>
 231     dup "Listener" open-status-window ;
 232
 233 : listener-window ( -- )
 234     [ listener-window* drop ] with-ui ;
 235
 236 \ listener-window H{ { +nullary+ t } } define-command
 237
 238 : (get-listener) ( quot -- listener )
 239     find-window [
 240         [ raise-window ]
 241         [
 242             gadget-child
 243             [ ]
 244             [ input>> scroll>caret ]
 245             [ input>> request-focus ] tri
 246         ] bi
 247     ] [ listener-window* ] if* ; inline
 248
 249 : get-listener ( -- listener )
 250     [ listener-gadget? ] (get-listener) ;
 251
 252 : show-listener ( -- )
 253     get-listener drop ;
 254
 255 \ show-listener H{ { +nullary+ t } } define-command
 256
 257 : get-ready-listener ( -- listener )
 258     [
 259         {
 260             [ listener-gadget? ]
 261             [ listener-busy? not ]
 262         } 1&&
 263     ] (get-listener) ;
 264
 265 GENERIC: listener-input ( obj -- )
 266
 267 M: input listener-input string>> listener-input ;
 268
 269 M: string listener-input
 270     get-listener input>>
 271     [ set-editor-string ] [ request-focus ] bi ;
 272
 273 : call-listener ( quot command -- )
 274     get-ready-listener
 275     '[ _ _ _ dup wait-for-listener (call-listener) ]
 276     "Listener call" spawn drop ;
 277
 278 M: listener-command invoke-command ( target command -- )
 279     [ command-quot ] [ nip ] 2bi call-listener ;
 280
 281 M: listener-operation invoke-command ( target command -- )
 282     [ operation-quot ] [ nip command>> ] 2bi call-listener ;
 283
 284 : eval-listener ( string -- )
 285     get-listener input>> [ set-editor-string ] keep
 286     evaluate-input ;
 287
 288 : listener-run-files ( seq -- )
 289     [
 290         '[ _ [ run-file ] each ]
 291         \ listener-run-files
 292         call-listener
 293     ] unless-empty ;
 294
 295 : com-end ( listener -- )
 296     input>> interactor-eof ;
 297
 298 : clear-output ( listener -- )
 299     output>> pane-clear ;
 300
 301 \ clear-output H{ { +listener+ t } } define-command
 302
 303 : clear-stack ( listener -- )
 304     [ [ clear ] \ clear ] dip (call-listener) ;
 305
 306 : use-if-necessary ( word manifest -- )
 307     2dup [ vocabulary>> ] dip and [
 308         manifest [
 309             [ vocabulary>> use-vocab ]
 310             [ dup name>> associate use-words ] bi
 311         ] with-variable
 312     ] [ 2drop ] if ;
 313
 314 M: word accept-completion-hook
 315     interactor>> manifest>> use-if-necessary ;
 316
 317 M: object accept-completion-hook 2drop ;
 318
 319 : quot-action ( interactor -- lines )
 320     [ history>> history-add drop ] [ control-value ] [ select-all ] tri
 321     parse-lines-interactive ;
 322
 323 : <debugger-popup> ( error continuation -- popup )
 324     over compute-restarts [ hide-glass ] <debugger> "Error" <labeled-gadget> ;
 325
 326 : debugger-popup ( interactor error continuation -- )
 327     [ one-line-elt ] 2dip <debugger-popup> show-listener-popup ;
 328
 329 : handle-parse-error ( interactor error -- )
 330     dup lexer-error? [ 2dup go-to-error error>> ] when
 331     error-continuation get
 332     debugger-popup ;
 333
 334 : try-parse ( lines interactor -- quot/error/f )
 335     [ drop parse-lines-interactive ] [
 336         2nip
 337         dup lexer-error? [
 338             dup error>> unexpected-eof? [ drop f ] when
 339         ] when
 340     ] recover ;
 341
 342 : handle-interactive ( lines interactor -- quot/f ? )
 343     [ nip ] [ try-parse ] 2bi {
 344         { [ dup quotation? ] [ nip t ] }
 345         { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
 346         [ handle-parse-error f f ]
 347     } cond ;
 348
 349 M: interactor stream-read-quot
 350     [ interactor-yield ] keep {
 351         { [ over not ] [ drop ] }
 352         { [ over callable? ] [ drop ] }
 353         [
 354             [ handle-interactive ] keep swap
 355             [ interactor-finish ] [ nip stream-read-quot ] if
 356         ]
 357     } cond ;
 358
 359 : interactor-operation ( gesture interactor -- ? )
 360     [ token-model>> value>> ] keep word-at-caret
 361     [ nip ] [ gesture>operation ] 2bi
 362     dup [ invoke-command f ] [ 2drop t ] if ;
 363
 364 M: interactor handle-gesture
 365     {
 366         { [ over key-gesture? not ] [ call-next-method ] }
 367         { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
 368         { [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
 369         [ call-next-method ]
 370     } cond ;
 371
 372 interactor "interactor" f {
 373     { T{ key-down f f "RET" } evaluate-input }
 374     { T{ key-down f { C+ } "k" } clear-editor }
 375 } define-command-map
 376
 377 interactor "completion" f {
 378     { T{ key-down f f "TAB" } code-completion-popup }
 379     { T{ key-down f { C+ } "p" } recall-previous }
 380     { T{ key-down f { C+ } "n" } recall-next }
 381     { T{ key-down f { C+ } "r" } history-completion-popup }
 382 } define-command-map
 383
 384 : introduction. ( -- )
 385     tip-of-the-day. nl
 386     { $strong "Press " { $snippet "F1" } " at any time for help." } print-content nl nl ;
 387
 388 : listener-thread ( listener -- )
 389     dup listener-streams [
 390         [ com-browse ] help-hook set
 391         '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
 392         error-summary? off
 393         introduction.
 394         listener
 395         nl
 396         "The listener has exited. To start it again, click “Restart Listener”." print
 397     ] with-streams* ;
 398
 399 : start-listener-thread ( listener -- )
 400     '[
 401         _
 402         [ input>> register-self ]
 403         [ listener-thread ]
 404         bi
 405     ] "Listener" spawn drop ;
 406
 407 : restart-listener ( listener -- )
 408     #! Returns when listener is ready to receive input.
 409     {
 410         [ com-end ]
 411         [ clear-output ]
 412         [ input>> clear-editor ]
 413         [ start-listener-thread ]
 414         [ wait-for-listener ]
 415     } cleave ;
 416
 417 : com-help ( -- ) "help.home" com-browse ;
 418
 419 \ com-help H{ { +nullary+ t } } define-command
 420
 421 : com-auto-use ( -- )
 422     auto-use? [ not ] change ;
 423
 424 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
 425
 426 listener-gadget "toolbar" f {
 427     { f restart-listener }
 428     { T{ key-down f { A+ } "u" } com-auto-use }
 429     { T{ key-down f { A+ } "k" } clear-output }
 430     { T{ key-down f { A+ } "K" } clear-stack }
 431     { T{ key-down f { C+ } "d" } com-end }
 432     { T{ key-down f f "F1" } com-help }
 433 } define-command-map
 434
 435 listener-gadget "scrolling"
 436 "The listener's scroller can be scrolled from the keyboard."
 437 {
 438     { T{ key-down f { A+ } "UP" } com-scroll-up }
 439     { T{ key-down f { A+ } "DOWN" } com-scroll-down }
 440     { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
 441     { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
 442 } define-command-map
 443
 444 listener-gadget "multi-touch" f {
 445     { up-action refresh-all }
 446 } define-command-map
 447
 448 M: listener-gadget graft*
 449     [ call-next-method ] [ restart-listener ] bi ;
 450
 451 M: listener-gadget ungraft*
 452     [ com-end ] [ call-next-method ] bi ;