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 ;
  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 : clear-input ( interactor -- )
  85     #! The with-datastack is a kludge to make it infer. Stupid.
  86     model>> 1array [ clear-doc ] with-datastack drop ;
  87
  88 : interactor-finish ( interactor -- )
  89     [ editor-string ] keep
  90     [ interactor-input. ] 2keep
  91     [ add-interactor-history ] keep
  92     clear-input ;
  93
  94 : interactor-eof ( interactor -- )
  95     dup interactor-busy? [
  96         f over interactor-continue
  97     ] unless drop ;
  98
  99 : evaluate-input ( interactor -- )
 100     dup interactor-busy? [
 101         dup control-value over interactor-continue
 102     ] unless drop ;
 103
 104 : interactor-yield ( interactor -- obj )
 105     dup thread>> self eq? [
 106         {
 107             [ t >>waiting drop ]
 108             [ flag>> raise-flag ]
 109             [ mailbox>> mailbox-get ]
 110             [ f >>waiting drop ]
 111         } cleave
 112     ] [ drop f ] if ;
 113
 114 : interactor-read ( interactor -- lines )
 115     [ interactor-yield ] [ interactor-finish ] bi ;
 116
 117 M: interactor stream-readln
 118     interactor-read dup [ first ] when ;
 119
 120 : interactor-call ( quot interactor -- )
 121     dup interactor-busy? [
 122         2dup interactor-input.
 123         2dup interactor-continue
 124     ] unless 2drop ;
 125
 126 M: interactor stream-read
 127     swap dup zero? [
 128         2drop ""
 129     ] [
 130         [ interactor-read dup [ "\n" join ] when ] dip short head
 131     ] if ;
 132
 133 M: interactor stream-read-partial
 134     stream-read ;
 135
 136 M: interactor stream-read1
 137     dup interactor-read {
 138         { [ dup not ] [ 2drop f ] }
 139         { [ dup empty? ] [ drop stream-read1 ] }
 140         { [ dup first empty? ] [ 2drop CHAR: \n ] }
 141         [ nip first first ]
 142     } cond ;
 143
 144 M: interactor dispose drop ;
 145
 146 : go-to-error ( interactor error -- )
 147     [ line>> 1- ] [ column>> ] bi 2array
 148     over set-caret
 149     mark>caret ;
 150
 151 : handle-parse-error ( interactor error -- )
 152     dup lexer-error? [ 2dup go-to-error error>> ] when
 153     swap find-workspace debugger-popup ;
 154
 155 : try-parse ( lines interactor -- quot/error/f )
 156     [
 157         drop parse-lines-interactive
 158     ] [
 159         2nip
 160         dup lexer-error? [
 161             dup error>> unexpected-eof? [ drop f ] when
 162         ] when
 163     ] recover ;
 164
 165 : handle-interactive ( lines interactor -- quot/f ? )
 166     tuck try-parse {
 167         { [ dup quotation? ] [ nip t ] }
 168         { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
 169         [ handle-parse-error f f ]
 170     } cond ;
 171
 172 M: interactor stream-read-quot
 173     [ interactor-yield ] keep {
 174         { [ over not ] [ drop ] }
 175         { [ over callable? ] [ drop ] }
 176         [
 177             [ handle-interactive ] keep swap
 178             [ interactor-finish ] [ nip stream-read-quot ] if
 179         ]
 180     } cond ;
 181
 182 interactor "interactor" f {
 183     { T{ key-down f f "RET" } evaluate-input }
 184     { T{ key-down f { C+ } "k" } clear-input }
 185 } define-command-map