core/ui/text/interactor.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-text
   4 USING: arrays definitions gadgets gadgets-panes
   5 generic hashtables help io kernel namespaces prettyprint styles
   6 threads sequences vectors definitions parser words strings
   7 math listener models errors ;
   8
   9 TUPLE: interactor
  10 history output
  11 continuation quot busy?
  12 use in error-hook ;
  13
  14 C: interactor ( output -- gadget )
  15     [ set-interactor-output ] keep
  16     <editor> over set-gadget-delegate
  17     V{ } clone over set-interactor-history
  18     dup dup set-control-self ;
  19
  20 M: interactor graft*
  21     f over set-interactor-busy? delegate graft* ;
  22
  23 : write-input ( string input -- )
  24     <input> presented associate
  25     [ H{ { font-style bold } } format ] with-nesting ;
  26
  27 : interactor-input. ( string interactor -- )
  28     interactor-output [
  29         dup string? [ dup write-input terpri ] [ short. ] if
  30     ] with-stream* ;
  31
  32 : add-interactor-history ( str interactor -- )
  33     over empty? [ 2drop ] [ interactor-history push-new ] if ;
  34
  35 : interactor-continue ( obj interactor -- )
  36     t over set-interactor-busy?
  37     interactor-continuation schedule-thread-with ;
  38
  39 : interactor-finish ( obj interactor -- )
  40     [ editor-string ] keep
  41     [ interactor-input. ] 2keep
  42     [ add-interactor-history ] keep
  43     dup control-model clear-doc
  44     interactor-continue ;
  45
  46 : interactor-eval ( interactor -- )
  47     [
  48         [ editor-string ] keep dup interactor-quot call
  49     ] in-thread drop ;
  50
  51 : interactor-eof ( interactor -- )
  52     f swap interactor-continuation schedule-thread-with ;
  53
  54 : interactor-commit ( interactor -- )
  55     dup interactor-busy? [ drop ] [ interactor-eval ] if ;
  56
  57 : interactor-yield ( interactor quot -- )
  58     over set-interactor-quot
  59     f over set-interactor-busy?
  60     [ swap set-interactor-continuation stop ] callcc1 nip ;
  61
  62 M: interactor stream-readln
  63     [
  64         interactor-finish
  65     ] interactor-yield ;
  66
  67 : interactor-call ( quot interactor -- )
  68     2dup interactor-input. interactor-continue ;
  69
  70 M: interactor stream-read
  71     swap dup zero?
  72     [ 2drop "" ] [ >r stream-readln r> head ] if ;
  73
  74 : save-in/use ( interactor -- )
  75     use get over set-interactor-use
  76     in get over set-interactor-in
  77     error-hook get swap set-interactor-error-hook ;
  78
  79 : restore-in/use ( interactor -- )
  80     dup interactor-use use set
  81     dup interactor-in in set
  82     interactor-error-hook error-hook set ;
  83
  84 : go-to-error ( interactor error -- )
  85     dup parse-error-line 1- swap parse-error-col 2array
  86     over editor-caret set-model mark>caret ;
  87
  88 : handle-parse-error ( interactor error -- )
  89     dup parse-error? [ 2dup go-to-error delegate ] when
  90     swap interactor-error-hook call ;
  91
  92 : try-parse ( str interactor -- quot/error/f )
  93     [
  94         [
  95             [
  96                 restore-in/use
  97                 1array \ parse with-datastack dup length 1 =
  98                 [ first ] [ drop f ] if
  99             ] keep save-in/use
 100         ] [
 101             2nip
 102         ] recover
 103     ] with-scope ;
 104
 105 : handle-interactive ( str/f interactor -- )
 106     tuck try-parse {
 107         { [ dup quotation? ] [ swap interactor-finish ] }
 108         { [ dup not ] [ drop "\n" swap user-input ] }
 109         { [ t ] [ handle-parse-error ] }
 110     } cond ;
 111
 112 M: interactor parse-interactive
 113     [ save-in/use ] keep
 114     [ [ handle-interactive ] interactor-yield ] keep
 115     restore-in/use ;
 116
 117 interactor "interactor" {
 118     { "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] }
 119     { "Clear input" T{ key-down f { C+ } "k" } [ control-model clear-doc ] }
 120 } define-commands