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