diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 6f94d92d93..eb912c47c9 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -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 ] } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 4503d2f2e0..2d3f4b9cb2 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -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 [ diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 2d447db1e9..5636800c1e 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -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 ; diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index a420bf278f..fe8c85d04b 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -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 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 ; diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index 4b030844c0..88901b4664 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -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 ; diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index 8ac7ec710a..6860b79ffc 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -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