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