basis/ui/tools/listener/listener.factor

   1 ! Copyright (C) 2005, 2009 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 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 : register-self ( interactor -- )
  27     <mailbox> >>mailbox
  28     self >>thread
  29     drop ;
  30
  31 : interactor-continuation ( interactor -- continuation )
  32     thread>> continuation>> value>> ;
  33
  34 : interactor-busy? ( interactor -- ? )
  35     #! We're busy if there's no thread to resume.
  36     {
  37         [ waiting>> ]
  38         [ thread>> dup [ thread-registered? ] when ]
  39     } 1&& not ;
  40
  41 SLOT: manifest
  42
  43 M: interactor manifest>>
  44     dup interactor-busy? [ drop f ] [
  45         interactor-continuation name>>
  46         manifest swap assoc-stack
  47     ] if ;
  48
  49 : vocab-exists? ( name -- ? )
  50     '[ _ { [ vocab ] [ find-vocab-root ] } 1|| ] [ drop f ] recover ;
  51
  52 GENERIC: (word-at-caret) ( token completion-mode -- obj )
  53
  54 M: vocab-completion (word-at-caret)
  55     drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
  56
  57 M: word-completion (word-at-caret)
  58     manifest>> dup [
  59         '[ _ _ search-manifest ] [ drop f ] recover
  60     ] [ 2drop f ] if ;
  61
  62 M: char-completion (word-at-caret)
  63     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 set
 104         bold font-style set
 105     ] H{ } make-assoc 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
 153     swap dup zero? [
 154         2drop ""
 155     ] [
 156         [ interactor-read dup [ "\n" join ] when ] dip short head
 157     ] if ;
 158
 159 M: interactor stream-read-partial
 160     stream-read ;
 161
 162 M: interactor stream-read1
 163     dup interactor-read {
 164         { [ dup not ] [ 2drop f ] }
 165         { [ dup empty? ] [ drop stream-read1 ] }
 166         { [ dup first empty? ] [ 2drop CHAR: \n ] }
 167         [ nip first first ]
 168     } cond ;
 169
 170 M: interactor dispose drop ;
 171
 172 : go-to-error ( interactor error -- )
 173     [ line>> 1 - ] [ column>> ] bi 2array
 174     over set-caret
 175     mark>caret ;
 176
 177 TUPLE: listener-gadget < tool error-summary output scroller input ;
 178
 179 { 600 700 } listener-gadget set-tool-dim
 180
 181 : find-listener ( gadget -- listener )
 182     [ listener-gadget? ] find-parent ;
 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         { "Press " { $command tool "common" show-error-list } " to view errors." }
 198         print-element
 199     ] unless-empty ;
 200
 201 : <error-summary> ( -- gadget )
 202     error-list-model get [ drop error-summary. ] <pane-control>
 203         COLOR: light-yellow <solid> >>interior ;
 204
 205 : init-error-summary ( listener -- listener )
 206     <error-summary> >>error-summary
 207     dup error-summary>> f track-add ;
 208
 209 : <listener-gadget> ( -- listener )
 210     vertical listener-gadget new-track
 211         add-toolbar
 212         init-input/output
 213         dup output>> <scroller> >>scroller
 214         dup scroller>> 1 track-add
 215         init-error-summary ;
 216
 217 M: listener-gadget focusable-child*
 218     input>> dup popup>> or ;
 219
 220 : wait-for-listener ( listener -- )
 221     #! Wait for the listener to start.
 222     input>> flag>> wait-for-flag ;
 223
 224 : listener-busy? ( listener -- ? )
 225     input>> interactor-busy? ;
 226
 227 : listener-window* ( -- listener )
 228     <listener-gadget>
 229     dup "Listener" open-status-window ;
 230
 231 : listener-window ( -- )
 232     [ listener-window* drop ] with-ui ;
 233
 234 \ listener-window H{ { +nullary+ t } } define-command
 235
 236 : (get-listener) ( quot -- listener )
 237     find-window [
 238         [ raise-window ]
 239         [
 240             gadget-child
 241             [ ]
 242             [ input>> scroll>caret ]
 243             [ input>> request-focus ] tri
 244         ] bi
 245     ] [ listener-window* ] if* ; inline
 246
 247 : get-listener ( -- listener )
 248     [ listener-gadget? ] (get-listener) ;
 249
 250 : show-listener ( -- )
 251     get-listener drop ;
 252
 253 \ show-listener H{ { +nullary+ t } } define-command
 254
 255 : get-ready-listener ( -- listener )
 256     [
 257         {
 258             [ listener-gadget? ]
 259             [ listener-busy? not ]
 260         } 1&&
 261     ] (get-listener) ;
 262
 263 GENERIC: listener-input ( obj -- )
 264
 265 M: input listener-input string>> listener-input ;
 266
 267 M: string listener-input
 268     get-listener input>>
 269     [ set-editor-string ] [ request-focus ] bi ;
 270
 271 : call-listener ( quot command -- )
 272     get-ready-listener
 273     '[ _ _ _ dup wait-for-listener (call-listener) ]
 274     "Listener call" spawn drop ;
 275
 276 M: listener-command invoke-command ( target command -- )
 277     [ command-quot ] [ nip ] 2bi call-listener ;
 278
 279 M: listener-operation invoke-command ( target command -- )
 280     [ operation-quot ] [ nip command>> ] 2bi call-listener ;
 281
 282 : eval-listener ( string -- )
 283     get-listener input>> [ set-editor-string ] keep
 284     evaluate-input ;
 285
 286 : listener-run-files ( seq -- )
 287     [
 288         '[ _ [ run-file ] each ]
 289         \ listener-run-files
 290         call-listener
 291     ] unless-empty ;
 292
 293 : com-end ( listener -- )
 294     input>> interactor-eof ;
 295
 296 : clear-output ( listener -- )
 297     output>> pane-clear ;
 298
 299 \ clear-output H{ { +listener+ t } } define-command
 300
 301 : clear-stack ( listener -- )
 302     [ [ clear ] \ clear ] dip (call-listener) ;
 303
 304 : use-if-necessary ( word manifest -- )
 305     2dup [ vocabulary>> ] dip and [
 306         manifest [
 307             [ vocabulary>> use-vocab ]
 308             [ dup name>> associate use-words ] bi
 309         ] with-variable
 310     ] [ 2drop ] if ;
 311
 312 M: word accept-completion-hook
 313     interactor>> manifest>> use-if-necessary ;
 314
 315 M: object accept-completion-hook 2drop ;
 316
 317 : quot-action ( interactor -- lines )
 318     [ history>> history-add drop ] [ control-value ] [ select-all ] tri
 319     [ parse-lines ] with-compilation-unit ;
 320
 321 : <debugger-popup> ( error continuation -- popup )
 322     over compute-restarts [ hide-glass ] <debugger> "Error" <labeled-gadget> ;
 323
 324 : debugger-popup ( interactor error continuation -- )
 325     [ one-line-elt ] 2dip <debugger-popup> show-listener-popup ;
 326
 327 : handle-parse-error ( interactor error -- )
 328     dup lexer-error? [ 2dup go-to-error error>> ] when
 329     error-continuation get
 330     debugger-popup ;
 331
 332 : try-parse ( lines interactor -- quot/error/f )
 333     [ drop parse-lines-interactive ] [
 334         2nip
 335         dup lexer-error? [
 336             dup error>> unexpected-eof? [ drop f ] when
 337         ] when
 338     ] recover ;
 339
 340 : handle-interactive ( lines interactor -- quot/f ? )
 341     [ nip ] [ try-parse ] 2bi {
 342         { [ dup quotation? ] [ nip t ] }
 343         { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
 344         [ handle-parse-error f f ]
 345     } cond ;
 346
 347 M: interactor stream-read-quot
 348     [ interactor-yield ] keep {
 349         { [ over not ] [ drop ] }
 350         { [ over callable? ] [ drop ] }
 351         [
 352             [ handle-interactive ] keep swap
 353             [ interactor-finish ] [ nip stream-read-quot ] if
 354         ]
 355     } cond ;
 356
 357 : interactor-operation ( gesture interactor -- ? )
 358     [ token-model>> value>> ] keep word-at-caret
 359     [ nip ] [ gesture>operation ] 2bi
 360     dup [ invoke-command f ] [ 2drop t ] if ;
 361
 362 M: interactor handle-gesture
 363     {
 364         { [ over key-gesture? not ] [ call-next-method ] }
 365         { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
 366         { [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
 367         [ call-next-method ]
 368     } cond ;
 369
 370 interactor "interactor" f {
 371     { T{ key-down f f "RET" } evaluate-input }
 372     { T{ key-down f { C+ } "k" } clear-editor }
 373 } define-command-map
 374
 375 interactor "completion" f {
 376     { T{ key-down f f "TAB" } code-completion-popup }
 377     { T{ key-down f { C+ } "p" } recall-previous }
 378     { T{ key-down f { C+ } "n" } recall-next }
 379     { T{ key-down f { C+ } "r" } history-completion-popup }
 380 } define-command-map
 381
 382 : listener-thread ( listener -- )
 383     dup listener-streams [
 384         [ com-browse ] help-hook set
 385         '[ [ _ input>> ] 2dip debugger-popup ] error-hook set
 386         error-summary? off
 387         tip-of-the-day. nl
 388         listener
 389     ] with-streams* ;
 390
 391 : start-listener-thread ( listener -- )
 392     '[
 393         _
 394         [ input>> register-self ]
 395         [ listener-thread ]
 396         bi
 397     ] "Listener" spawn drop ;
 398
 399 : restart-listener ( listener -- )
 400     #! Returns when listener is ready to receive input.
 401     {
 402         [ com-end ]
 403         [ clear-output ]
 404         [ input>> clear-editor ]
 405         [ start-listener-thread ]
 406         [ wait-for-listener ]
 407     } cleave ;
 408
 409 : listener-help ( -- ) "help.home" com-browse ;
 410
 411 \ listener-help H{ { +nullary+ t } } define-command
 412
 413 : com-auto-use ( -- )
 414     auto-use? [ not ] change ;
 415
 416 \ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
 417
 418 listener-gadget "misc" "Miscellaneous commands" {
 419     { T{ key-down f f "F1" } listener-help }
 420 } define-command-map
 421
 422 listener-gadget "toolbar" f {
 423     { f restart-listener }
 424     { T{ key-down f { A+ } "u" } com-auto-use }
 425     { T{ key-down f { A+ } "k" } clear-output }
 426     { T{ key-down f { A+ } "K" } clear-stack }
 427     { T{ key-down f { C+ } "d" } com-end }
 428 } define-command-map
 429
 430 listener-gadget "scrolling"
 431 "The listener's scroller can be scrolled from the keyboard."
 432 {
 433     { T{ key-down f { A+ } "UP" } com-scroll-up }
 434     { T{ key-down f { A+ } "DOWN" } com-scroll-down }
 435     { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
 436     { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
 437 } define-command-map
 438
 439 listener-gadget "multi-touch" f {
 440     { up-action refresh-all }
 441 } define-command-map
 442
 443 M: listener-gadget graft*
 444     [ call-next-method ] [ restart-listener ] bi ;
 445
 446 M: listener-gadget ungraft*
 447     [ com-end ] [ call-next-method ] bi ;