Clean up interactor gadget

db4
Slava Pestov 2007-12-30 21:15:59 -05:00
parent 64b06f059a
commit 18eb8e2bd3
6 changed files with 57 additions and 60 deletions
extra/ui
gadgets/editors
tools

View File

@ -14,10 +14,11 @@ SYMBOL: listener-hook
GENERIC: stream-read-quot ( stream -- quot/f )
: parse-lines-interactive ( lines -- quot/f )
[ parse-lines in get ] with-compilation-unit in set ;
: read-quot-step ( lines -- quot/f )
[
[ parse-lines in get ] with-compilation-unit in set
] catch {
[ parse-lines-interactive ] catch {
{ [ dup delegate unexpected-eof? ] [ 2drop f ] }
{ [ dup not ] [ drop ] }
{ [ t ] [ rethrow ] }

View File

@ -301,9 +301,6 @@ SYMBOL: lexer-factory
: parse-lines ( lines -- quot )
lexer-factory get call (parse-lines) ;
: parse ( str -- quot )
[ string-lines parse-lines ] with-compilation-unit ;
! Parsing word utilities
: parse-effect ( -- effect )
")" parse-tokens { "--" } split1 dup [

View File

@ -62,10 +62,13 @@ M: editor ungraft*
: editor-mark* ( editor -- loc ) editor-mark model-value ;
: set-caret ( loc editor -- )
[ gadget-model validate-loc ] keep
editor-caret set-model ;
: change-caret ( editor quot -- )
over >r >r dup editor-caret* swap gadget-model r> call r>
[ gadget-model validate-loc ] keep
editor-caret set-model ; inline
set-caret ; inline
: mark>caret ( editor -- )
dup editor-caret* swap editor-mark set-model ;

View File

@ -11,20 +11,9 @@ IN: ui.tools.interactor
TUPLE: interactor
history output
continuation quot busy?
vars
use
help ;
: interactor-use ( interactor -- seq )
use swap interactor-vars at ;
: word-at-loc ( loc interactor -- word )
over [
[ gadget-model T{ one-word-elt } elt-string ] keep
interactor-use assoc-stack
] [
2drop f
] if ;
: init-caret-help ( interactor -- )
dup editor-caret 100 <delay> swap set-interactor-help ;
@ -47,6 +36,14 @@ M: interactor ungraft*
dup dup interactor-help remove-connection
delegate ungraft* ;
: word-at-loc ( loc interactor -- word )
over [
[ gadget-model T{ one-word-elt } elt-string ] keep
interactor-use assoc-stack
] [
2drop f
] if ;
M: interactor model-changed
2dup interactor-help eq? [
swap model-value over word-at-loc swap show-summary
@ -70,34 +67,36 @@ M: interactor model-changed
t over set-interactor-busy?
interactor-continuation schedule-thread-with ;
: interactor-finish ( obj interactor -- )
: interactor-finish ( interactor -- )
[ editor-string ] keep
[ interactor-input. ] 2keep
[ add-interactor-history ] keep
dup gadget-model clear-doc
interactor-continue ;
: interactor-eval ( interactor -- )
[
[ editor-string ] keep dup interactor-quot call
] in-thread drop ;
gadget-model clear-doc ;
: interactor-eof ( interactor -- )
f swap interactor-continue ;
dup interactor-busy? [
f over interactor-continue
] unless drop ;
: evaluate-input ( interactor -- )
dup interactor-busy? [ drop ] [ interactor-eval ] if ;
dup interactor-busy? [
[
[ control-value ] keep interactor-continue
] in-thread
] unless drop ;
: interactor-yield ( interactor quot -- obj )
over set-interactor-quot
: interactor-yield ( interactor -- obj )
f over set-interactor-busy?
[ set-interactor-continuation stop ] curry callcc1 ;
M: interactor stream-readln
[ interactor-finish ] interactor-yield ;
[ interactor-yield ] keep interactor-finish first ;
: interactor-call ( quot interactor -- )
2dup interactor-input. interactor-continue ;
dup interactor-busy? [
2dup interactor-input.
2dup interactor-continue
] unless 2drop ;
M: interactor stream-read
swap dup zero? [
@ -109,44 +108,41 @@ M: interactor stream-read
M: interactor stream-read-partial
stream-read ;
: save-vars ( interactor -- )
{ use in stdio lexer-factory } [ dup get ] H{ } map>assoc
swap set-interactor-vars ;
: restore-vars ( interactor -- )
namespace swap interactor-vars update ;
: save-use ( interactor -- )
use get swap set-interactor-use ;
: go-to-error ( interactor error -- )
dup parse-error-line 1- swap parse-error-col 2array
over [ gadget-model validate-loc ] keep
editor-caret set-model
over set-caret
mark>caret ;
: handle-parse-error ( interactor error -- )
dup parse-error? [ 2dup go-to-error delegate ] when
swap find-workspace debugger-popup ;
: try-parse ( str interactor -- quot/error/f )
: try-parse ( lines interactor -- quot/error/f )
[
[
[ restore-vars parse ] keep save-vars
] [
>r f swap set-interactor-busy? drop r>
dup delegate unexpected-eof? [ drop f ] when
] recover
] with-scope ;
>r parse-lines-interactive r> save-use
] [
>r f swap set-interactor-busy? drop r>
dup delegate unexpected-eof? [ drop f ] when
] recover ;
: handle-interactive ( str/f interactor -- )
: handle-interactive ( lines interactor -- quot/f ? )
tuck try-parse {
{ [ dup quotation? ] [ swap interactor-finish ] }
{ [ dup not ] [ drop "\n" swap user-input ] }
{ [ t ] [ handle-parse-error ] }
{ [ dup quotation? ] [ nip t ] }
{ [ dup not ] [ drop "\n" swap user-input f f ] }
{ [ t ] [ handle-parse-error f f ] }
} cond ;
M: interactor stream-read-quot
[ save-vars ] keep
[ [ handle-interactive ] interactor-yield ] keep
restore-vars ;
[ save-use ] keep
[ interactor-yield ] keep over quotation? [
drop
] [
[ handle-interactive ] keep swap
[ interactor-finish ] [ nip stream-read-quot ] if
] if ;
M: interactor pref-dim*
0 over line-height 4 * 2array swap delegate pref-dim* vmax ;

View File

@ -96,8 +96,8 @@ M: listener-operation invoke-command ( target command -- )
get-listener [ word-completion-string ] keep
listener-gadget-input user-input ;
: quot-action ( interactor -- quot )
dup editor-string swap
: quot-action ( interactor -- lines )
dup control-value swap
2dup add-interactor-history
select-all ;

View File

@ -196,5 +196,5 @@ interactor
"These commands operate on the entire contents of the input area."
[ ]
[ quot-action ]
[ parse ]
[ [ parse-lines ] with-compilation-unit ]
define-operation-map