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