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