From 7e48927eafab1fd0b24f6823e5f3169a5a7b9dfd Mon Sep 17 00:00:00 2001 From: slava Date: Tue, 28 Nov 2006 05:35:43 +0000 Subject: [PATCH] Listener overhaul --- doc/handbook/tools.facts | 2 +- doc/handbook/ui/tools.facts | 2 +- library/tools/listener.factor | 51 ++++++++++------- library/tools/listener.facts | 10 +--- library/ui/text/interactor.factor | 91 +++++++++++++++++++------------ library/ui/tools/listener.factor | 4 +- 6 files changed, 92 insertions(+), 68 deletions(-) diff --git a/doc/handbook/tools.facts b/doc/handbook/tools.facts index e55a02ab9b..bdc2065512 100644 --- a/doc/handbook/tools.facts +++ b/doc/handbook/tools.facts @@ -36,7 +36,7 @@ $terpri "The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:" { $subsection listener-hook } "Finally, the multi-line expression reading word can be used independently of the rest of the listener:" -{ $subsection read-multiline } ; +{ $subsection parse-interactive } ; ARTICLE: "sources" "Source files" "The simplest way to distribute a piece of Factor code is in the form of a source file. Source files can be loaded in the listener:" diff --git a/doc/handbook/ui/tools.facts b/doc/handbook/ui/tools.facts index 239e73dc3e..90d85129c1 100644 --- a/doc/handbook/ui/tools.facts +++ b/doc/handbook/ui/tools.facts @@ -37,7 +37,7 @@ ARTICLE: "ui-listener" "UI listener" { $heading "Editing commands" } "The text editing commands are standard and are documented in the " { $link editor } " class." { $heading "Implementation" } -"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ; +"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), and an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ; ARTICLE: "ui-browser" "UI definition browser" { $commands browser "toolbar" } diff --git a/library/tools/listener.factor b/library/tools/listener.factor index c4a59453b8..a3ec53d4da 100644 --- a/library/tools/listener.factor +++ b/library/tools/listener.factor @@ -2,50 +2,59 @@ ! See http://factorcode.org/license.txt for BSD license. IN: listener USING: errors hashtables io kernel math memory namespaces -parser sequences strings styles vectors words ; +parser sequences strings styles vectors words generic ; SYMBOL: quit-flag + SYMBOL: listener-hook -: bye ( -- ) quit-flag on ; +GENERIC: parse-interactive ( stream -- quot/f ) -: (read-multiline) ( quot depth -- newquot ? ) +TUPLE: interactive-stream ; + +C: interactive-stream ( stream -- stream ) + [ set-delegate ] keep ; + +: (parse-interactive) ( quot depth -- quot/f ) >r readln dup [ (parse) depth r> dup >r <= [ - r> drop t + >quotation r> drop ] [ - r> (read-multiline) + r> (parse-interactive) ] if ] [ - r> 2drop f + r> 3drop f ] if ; -: read-multiline ( -- quot ? ) - [ - f depth (read-multiline) >r >quotation r> in get - ] with-parser in set ; +M: interactive-stream parse-interactive + delegate [ + [ f depth (parse-interactive) in get ] with-parser + ] with-stream* in set ; + +M: duplex-stream parse-interactive + duplex-stream-in parse-interactive ; + +: bye ( -- ) quit-flag on ; : prompt. ( -- ) in get H{ { background { 1 0.7 0.7 1 } } } format bl flush ; : listen ( -- ) - prompt. [ - listener-hook get call - read-multiline [ call ] [ drop bye ] if - ] try ; + [ stdio get parse-interactive [ call ] [ bye ] if* ] try ; -: listener ( -- ) - quit-flag get [ quit-flag off ] [ listen listener ] if ; +: (listener) ( -- ) + quit-flag get + [ quit-flag off ] + [ prompt. listener-hook get call listen (listener) ] if ; : print-banner ( -- ) "Factor " write version write " on " write os write "/" write cpu print ; +: listener ( -- ) + print-banner use [ clone ] change (listener) ; + IN: shells : tty ( -- ) - [ - use [ clone ] change - print-banner - listener - ] with-scope ; + stdio get [ listener ] with-stream* ; diff --git a/library/tools/listener.facts b/library/tools/listener.facts index 4f2bbb3c80..7e70e749b0 100644 --- a/library/tools/listener.facts +++ b/library/tools/listener.facts @@ -7,13 +7,9 @@ HELP: quit-flag HELP: listener-hook { $var-description "Variable holding a quotation called by the listener before reading each line of input. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ; -HELP: (read-multiline) -{ $values { "quot" "the quotation being parsed" } { "depth" "the initial parsing stack depth" } { "newquot" "the quotation being parsed, after another line of input" } { "?" "a flag indicating end of input" } } -{ $description "Internal word used to read multiline expressions." } ; - -HELP: read-multiline -{ $values { "quot" "a parsed quotation" } { "?" "a flag indicating end of file" } } -{ $description "Reads a Factor expression from the default stream, possibly spanning more than line. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ; +HELP: parse-interactive +{ $values { "stream" "an input stream" } { "quot" "a parsed quotation, or " { $link f } " indicating end of file" } } +{ $description "Reads a Factor expression from the stream, possibly spanning more than line. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ; HELP: listen { $description "Prompts for an expression on the default stream and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." } diff --git a/library/ui/text/interactor.factor b/library/ui/text/interactor.factor index 27502bc2da..67eae75343 100644 --- a/library/ui/text/interactor.factor +++ b/library/ui/text/interactor.factor @@ -4,9 +4,12 @@ IN: gadgets-text USING: arrays definitions gadgets gadgets-panes generic hashtables help io kernel namespaces prettyprint styles threads sequences vectors definitions parser words strings -math ; +math listener ; -TUPLE: interactor history output continuation queue busy? ; +TUPLE: interactor +history output +continuation quot busy? +use in ; C: interactor ( output -- gadget ) [ set-interactor-output ] keep @@ -17,52 +20,68 @@ C: interactor ( output -- gadget ) M: interactor graft* f over set-interactor-busy? delegate graft* ; -: (interactor-eval) ( string interactor -- ) - dup interactor-busy? [ - 2drop - ] [ - t over set-interactor-busy? - swap "\n" split >vector - over set-interactor-queue - interactor-continuation schedule-thread - ] if ; - -SYMBOL: structured-input - -: interactor-call ( quot gadget -- ) - dup interactor-output [ - "Command: " write over short. - ] with-stream* - >r structured-input set-global - "\"structured-input\" \"gadgets-text\" lookup get-global call" - r> (interactor-eval) ; - : interactor-input. ( string interactor -- ) - interactor-output [ dup print-input ] with-stream* ; + interactor-output [ + dup string? [ + dup print-input + ] [ + 5 line-limit set . + ] if + ] with-stream* ; -: interactor-eval ( string interactor -- ) - dup control-model clear-doc - over empty? [ 2dup interactor-history push-new ] unless +: interactor-finish ( obj interactor -- ) 2dup interactor-input. - (interactor-eval) ; + dup control-model clear-doc + interactor-continuation schedule-thread-with ; + +: interactor-eval ( interactor -- ) + [ editor-text ] keep dup interactor-quot call ; + +: interactor-eof ( interactor -- ) + f swap dup interactor-quot call ; : interactor-commit ( interactor -- ) - dup interactor-busy? [ - drop - ] [ - [ editor-text ] keep interactor-eval - ] if ; + dup interactor-busy? [ drop ] [ interactor-eval ] if ; + +: interactor-yield ( interactor quot -- ) + over set-interactor-quot + f over set-interactor-busy? + [ swap set-interactor-continuation stop ] callcc1 ; M: interactor stream-readln - dup interactor-queue empty? [ - f over set-interactor-busy? - [ over set-interactor-continuation stop ] callcc0 - ] when interactor-queue pop ; + [ + over empty? [ 2dup interactor-history push-new ] unless + interactor-finish + ] interactor-yield nip ; + +: interactor-call ( quot interactor -- ) + 2dup interactor-input. + interactor-continuation schedule-thread-with ; M: interactor stream-read swap dup zero? [ 2drop "" ] [ >r stream-readln r> head ] if ; +: try-parse ( str -- quot ? ) + [ + 1array \ parse with-datastack + dup length 1 = [ first t ] [ drop f f ] if + ] with-scope ; + +: handle-interactive ( str/f interactor -- ) + over [ + >r try-parse [ + r> interactor-finish + ] [ + "\n" r> user-input drop + ] if + ] [ + interactor-finish + ] if ; + +M: interactor parse-interactive + [ handle-interactive ] interactor-yield nip ; + interactor "interactor" { { "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] } { "Clear input" T{ key-down f { C+ } "k" } [ control-model clear-doc ] } diff --git a/library/ui/tools/listener.factor b/library/ui/tools/listener.factor index cd3536bdf7..44e3b34a2a 100644 --- a/library/ui/tools/listener.factor +++ b/library/ui/tools/listener.factor @@ -40,7 +40,7 @@ TUPLE: listener-gadget input output stack use ; [ ui-listener-hook ] curry listener-hook set find-messages batch-errors set welcome. - tty + listener ] with-stream* ; : start-listener ( listener -- ) @@ -104,7 +104,7 @@ M: listener-gadget tool-help ] if ; : listener-eof ( listener -- ) - listener-gadget-input f swap interactor-eval ; + listener-gadget-input interactor-eof ; : clear-listener-output ( listener -- ) [ listener-gadget-output [ pane-clear ] curry ] keep