Clean up interactor gadget
parent
64b06f059a
commit
18eb8e2bd3
core
listener
parser
extra/ui
gadgets/editors
tools
|
@ -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 ] }
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue