persistent port for asynchronous evaluation output

using ideas and code from Christine Lemmer-Webber, see #25 for discussion.

1 files changed, 25 insertions, 3 deletions

diff --git a/src/geiser/evaluation.scm b/src/geiser/evaluation.scm
index ed2fb39..7038d3a 100644
--- a/src/geiser/evaluation.scm
+++ b/src/geiser/evaluation.scm
@@ -27,6 +27,7 @@
      #:use-module (system base pmatch)
      #:use-module (system vm program)
      #:use-module (ice-9 pretty-print)
+     #:use-module (ice-9 textual-ports)
      #:use-module (system vm loader)))
   (else
    (define-module (geiser evaluation)
@@ -44,7 +45,8 @@
      #:use-module (system base message)
      #:use-module (system base pmatch)
      #:use-module (system vm program)
-     #:use-module (ice-9 pretty-print))))
+     #:use-module (ice-9 pretty-print)
+     #:use-module (ice-9 textual-ports))))
 
 
 (define compile-opts '())
@@ -69,16 +71,36 @@
 
 (ge:set-warnings 'none)
 
+(define context-port #f)
+
+(define switcher-port
+  (make-soft-port (vector (lambda (c) (put-char c context-port))
+                          (lambda (s) (display s context-port))
+                          (lambda () (force-output context-port))
+                          (lambda () (close-port context-port))
+                          (lambda () 0))
+                  "w"))
+
+(define (call-with-switcher-output long-port thunk)
+  (let ((current (current-output-port)))
+    (parameterize ((current-output-port switcher-port))
+      (dynamic-wind
+        (lambda () (set! context-port current))
+        thunk
+        (lambda () (set! context-port long-port))))))
+
 (define (call-with-result thunk)
   (letrec* ((result #f)
+            (long-port (current-output-port))
+            (run-thunk (lambda () (call-with-switcher-output long-port thunk)))
             (output
              (with-output-to-string
                (lambda ()
                  (with-fluids ((*current-warning-port* (current-output-port))
                                (*current-warning-prefix* ""))
                    (with-error-to-port (current-output-port)
-                     (lambda () (set! result
-                                  (map object->string (thunk))))))))))
+                     (lambda ()
+                       (set! result (map object->string (run-thunk))))))))))
     (write `((result ,@result) (output . ,output)))
     (newline)))