basis/ui/tools/interactor/interactor.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs combinators continuations documents
   4 hashtables io io.styles kernel math math.order math.vectors
   5 models models.delay namespaces parser lexer prettyprint
   6 quotations sequences strings threads listener classes.tuple
   7 ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
   8 ui.gadgets.presentations ui.gadgets.worlds ui.gestures
   9 definitions calendar concurrency.flags concurrency.mailboxes
  10 ui.tools.workspace accessors sets destructors fry vocabs.parser ;
  11 IN: ui.tools.interactor
  12
  13 ! If waiting is t, we're waiting for user input, and invoking
  14 ! evaluate-input resumes the thread.
  15 TUPLE: interactor < source-editor
  16 output history flag mailbox thread waiting help ;
  17
  18 : register-self ( interactor -- )
  19     <mailbox> >>mailbox
  20     self >>thread
  21     drop ;
  22
  23 : interactor-continuation ( interactor -- continuation )
  24     thread>> continuation>> value>> ;
  25
  26 : interactor-busy? ( interactor -- ? )
  27     #! We're busy if there's no thread to resume.
  28     [ waiting>> ]
  29     [ thread>> dup [ thread-registered? ] when ]
  30     bi and not ;
  31
  32 : interactor-use ( interactor -- seq )
  33     dup interactor-busy? [ drop f ] [
  34         use swap
  35         interactor-continuation name>>
  36         assoc-stack
  37     ] if ;
  38
  39 : <help-model> ( interactor -- model ) caret>> 1/3 seconds <delay> ;
  40
  41 : <interactor> ( output -- gadget )
  42     interactor new-editor
  43         V{ } clone >>history
  44         <flag> >>flag
  45         dup <help-model> >>help
  46         swap >>output ;
  47
  48 M: interactor graft*
  49     [ call-next-method ] [ dup help>> add-connection ] bi ;
  50
  51 M: interactor ungraft*
  52     [ dup help>> remove-connection ] [ call-next-method ] bi ;
  53
  54 : word-at-loc ( loc interactor -- word )
  55     over [
  56         [ model>> T{ one-word-elt } elt-string ] keep
  57         interactor-use assoc-stack
  58     ] [
  59         2drop f
  60     ] if ;
  61
  62 M: interactor model-changed
  63     2dup help>> eq? [
  64         swap value>> over word-at-loc swap show-summary
  65     ] [
  66         call-next-method
  67     ] if ;
  68
  69 : write-input ( string input -- )
  70     <input> presented associate
  71     [ H{ { font-style bold } } format ] with-nesting ;
  72
  73 : interactor-input. ( string interactor -- )
  74     output>> [
  75         dup string? [ dup write-input nl ] [ short. ] if
  76     ] with-output-stream* ;
  77
  78 : add-interactor-history ( str interactor -- )
  79     over empty? [ 2drop ] [ history>> adjoin ] if ;
  80
  81 : interactor-continue ( obj interactor -- )
  82     mailbox>> mailbox-put ;
  83
  84 : interactor-finish ( interactor -- )
  85     [ editor-string ] keep
  86     [ interactor-input. ] 2keep
  87     [ add-interactor-history ] keep
  88     clear-editor ;
  89
  90 : interactor-eof ( interactor -- )
  91     dup interactor-busy? [
  92         f over interactor-continue
  93     ] unless drop ;
  94
  95 : evaluate-input ( interactor -- )
  96     dup interactor-busy? [
  97         dup control-value over interactor-continue
  98     ] unless drop ;
  99
 100 : interactor-yield ( interactor -- obj )
 101     dup thread>> self eq? [
 102         {
 103             [ t >>waiting drop ]
 104             [ flag>> raise-flag ]
 105             [ mailbox>> mailbox-get ]
 106             [ f >>waiting drop ]
 107         } cleave
 108     ] [ drop f ] if ;
 109
 110 : interactor-read ( interactor -- lines )
 111     [ interactor-yield ] [ interactor-finish ] bi ;
 112
 113 M: interactor stream-readln
 114     interactor-read dup [ first ] when ;
 115
 116 : interactor-call ( quot interactor -- )
 117     dup interactor-busy? [
 118         2dup interactor-input.
 119         2dup interactor-continue
 120     ] unless 2drop ;
 121
 122 M: interactor stream-read
 123     swap dup zero? [
 124         2drop ""
 125     ] [
 126         [ interactor-read dup [ "\n" join ] when ] dip short head
 127     ] if ;
 128
 129 M: interactor stream-read-partial
 130     stream-read ;
 131
 132 M: interactor stream-read1
 133     dup interactor-read {
 134         { [ dup not ] [ 2drop f ] }
 135         { [ dup empty? ] [ drop stream-read1 ] }
 136         { [ dup first empty? ] [ 2drop CHAR: \n ] }
 137         [ nip first first ]
 138     } cond ;
 139
 140 M: interactor dispose drop ;
 141
 142 : go-to-error ( interactor error -- )
 143     [ line>> 1- ] [ column>> ] bi 2array
 144     over set-caret
 145     mark>caret ;
 146
 147 : handle-parse-error ( interactor error -- )
 148     dup lexer-error? [ 2dup go-to-error error>> ] when
 149     swap find-workspace debugger-popup ;
 150
 151 : try-parse ( lines interactor -- quot/error/f )
 152     [
 153         drop parse-lines-interactive
 154     ] [
 155         2nip
 156         dup lexer-error? [
 157             dup error>> unexpected-eof? [ drop f ] when
 158         ] when
 159     ] recover ;
 160
 161 : handle-interactive ( lines interactor -- quot/f ? )
 162     tuck try-parse {
 163         { [ dup quotation? ] [ nip t ] }
 164         { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
 165         [ handle-parse-error f f ]
 166     } cond ;
 167
 168 M: interactor stream-read-quot
 169     [ interactor-yield ] keep {
 170         { [ over not ] [ drop ] }
 171         { [ over callable? ] [ drop ] }
 172         [
 173             [ handle-interactive ] keep swap
 174             [ interactor-finish ] [ nip stream-read-quot ] if
 175         ]
 176     } cond ;
 177
 178 interactor "interactor" f {
 179     { T{ key-down f f "RET" } evaluate-input }
 180     { T{ key-down f { C+ } "k" } clear-editor }
 181 } define-command-map