Listener overhaul

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:"

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" }

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 <interactive-stream> [ listener ] with-stream* ;

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." }

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 <reversed> >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 ] }

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