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
   5 math.vectors models namespaces parser prettyprint quotations
   6 sequences strings threads listener
   7 classes.tuple ui.commands ui.gadgets ui.gadgets.editors
   8 ui.gadgets.presentations ui.gadgets.worlds ui.gestures
   9 definitions boxes calendar concurrency.flags ui.tools.workspace
  10 accessors math.order ;
  11 IN: ui.tools.interactor
  12
  13 TUPLE: interactor history output flag thread help ;
  14
  15 : interactor-continuation ( interactor -- continuation )
  16     interactor-thread box-value
  17     thread-continuation box-value ;
  18
  19 : interactor-busy? ( interactor -- ? )
  20     interactor-thread box-full? not ;
  21
  22 : interactor-use ( interactor -- seq )
  23     dup interactor-busy? [ drop f ] [
  24         use swap
  25         interactor-continuation continuation-name
  26         assoc-stack
  27     ] if ;
  28
  29 : init-caret-help ( interactor -- )
  30     dup editor-caret 1/3 seconds <delay>
  31     swap set-interactor-help ;
  32
  33 : init-interactor-history ( interactor -- )
  34     V{ } clone swap set-interactor-history ;
  35
  36 : init-interactor-state ( interactor -- )
  37     <flag> over set-interactor-flag
  38     <box> swap set-interactor-thread ;
  39
  40 : <interactor> ( output -- gadget )
  41     <source-editor>
  42     interactor construct-editor
  43     tuck set-interactor-output
  44     dup init-interactor-history
  45     dup init-interactor-state
  46     dup init-caret-help ;
  47
  48 M: interactor graft*
  49     dup delegate graft*
  50     dup interactor-help add-connection ;
  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 interactor-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     interactor-output [
  73         dup string? [ dup write-input nl ] [ short. ] if
  74     ] with-output-stream* ;
  75
  76 : add-interactor-history ( str interactor -- )
  77     over empty? [ 2drop ] [ interactor-history push-new ] if ;
  78
  79 : interactor-continue ( obj interactor -- )
  80     interactor-thread box> 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     [
 103         [ interactor-thread >box ] keep
 104         interactor-flag raise-flag
 105     ] curry "input" suspend ;
 106
 107 M: interactor stream-readln
 108     [ interactor-yield ] keep interactor-finish
 109     dup [ first ] when ;
 110
 111 : interactor-call ( quot interactor -- )
 112     dup interactor-busy? [
 113         2dup interactor-input.
 114         2dup interactor-continue
 115     ] unless 2drop ;
 116
 117 M: interactor stream-read
 118     swap dup zero? [
 119         2drop ""
 120     ] [
 121         >r stream-readln dup length r> min head
 122     ] if ;
 123
 124 M: interactor stream-read-partial
 125     stream-read ;
 126
 127 : go-to-error ( interactor error -- )
 128     [ line>> 1- ] [ column>> ] bi 2array
 129     over set-caret
 130     mark>caret ;
 131
 132 : handle-parse-error ( interactor error -- )
 133     dup parse-error? [ 2dup go-to-error error>> ] when
 134     swap find-workspace debugger-popup ;
 135
 136 : try-parse ( lines interactor -- quot/error/f )
 137     [
 138         drop parse-lines-interactive
 139     ] [
 140         2nip
 141         dup parse-error? [
 142             dup error>> unexpected-eof? [ drop f ] when
 143         ] when
 144     ] recover ;
 145
 146 : handle-interactive ( lines interactor -- quot/f ? )
 147     tuck try-parse {
 148         { [ dup quotation? ] [ nip t ] }
 149         { [ dup not ] [ drop "\n" swap user-input f f ] }
 150         [ handle-parse-error f f ]
 151     } cond ;
 152
 153 M: interactor stream-read-quot
 154     [ interactor-yield ] keep {
 155         { [ over not ] [ drop ] }
 156         { [ over callable? ] [ drop ] }
 157         [
 158             [ handle-interactive ] keep swap
 159             [ interactor-finish ] [ nip stream-read-quot ] if
 160         ]
 161     } cond ;
 162
 163 M: interactor pref-dim*
 164     0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
 165
 166 interactor "interactor" f {
 167     { T{ key-down f f "RET" } evaluate-input }
 168     { T{ key-down f { C+ } "k" } clear-input }
 169 } define-command-map