From cda7cb06ad3c23b093e9627315221bcfbbb61d18 Mon Sep 17 00:00:00 2001
From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Mon, 6 Jul 2015 09:52:28 -0700
Subject: [PATCH] Fancy unparsing of streams.

---
 src/runtime/runtime.pkg |  1 +
 src/runtime/unpars.scm  | 32 ++++++++++++++++++++++++++++++++
 2 files changed, 33 insertions(+)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 55cabe5ce..656e729d4 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4911,6 +4911,7 @@ USA.
 	  *unparse-abbreviate-quotations?*
 	  *unparse-compound-procedure-names?*
 	  *unparse-primitives-by-name?*
+	  *unparse-streams?*
 	  *unparse-uninterned-symbols-by-name?*
 	  *unparse-with-datum?*
 	  *unparse-with-maximum-readability?*
diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 261515c86..7db55082f 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -44,6 +44,7 @@ USA.
   (set! *unparse-compound-procedure-names?* (make-fluid #t))
   (set! *unparse-with-datum?* (make-fluid #f))
   (set! *unparse-abbreviate-quotations?* (make-fluid #f))
+  (set! *unparse-streams?* (make-fluid #t))
   (set! system-global-unparser-table (make-system-global-unparser-table))
   (set! *unparser-table* (make-fluid system-global-unparser-table))
   (set! *default-unparser-state* (make-fluid #f))
@@ -71,6 +72,7 @@ USA.
 (define *unparse-compound-procedure-names?*)
 (define *unparse-with-datum?*)
 (define *unparse-abbreviate-quotations?*)
+(define *unparse-streams?*)
 (define system-global-unparser-table)
 (define *unparser-table*)
 (define *default-unparser-state*)
@@ -550,6 +552,8 @@ USA.
          => (lambda (prefix) (unparse-list/prefix-pair prefix pair)))
         ((unparse-list/unparser pair)
          => (lambda (method) (invoke-user-method method pair)))
+        ((and (fluid *unparse-streams?*) (stream-pair? pair))
+         (unparse-list/stream-pair pair))
         (else
          (unparse-list pair))))
 
@@ -616,6 +620,34 @@ USA.
          ((UNQUOTE-SPLICING) ",@")
          (else #f))))
 
+(define (unparse-list/stream-pair stream-pair)
+  (limit-unparse-depth
+   (lambda ()
+     (*unparse-char #\{)
+     (*unparse-object (safe-car stream-pair))
+     (unparse-stream-tail (safe-cdr stream-pair) 2)
+     (*unparse-char #\}))))
+
+(define (unparse-stream-tail tail n)
+  (cond ((not (promise? tail))
+         (*unparse-string " . ")
+         (*unparse-object tail))
+        ((not (promise-forced? tail))
+         (*unparse-string " ..."))
+        (else (let ((value (promise-value tail)))
+                (cond ((empty-stream? value))
+                      ((stream-pair? value)
+                       (*unparse-char #\space)
+                       (*unparse-object (safe-car value))
+                       (if (let ((limit (fluid *unparser-list-breadth-limit*)))
+                             (and limit
+                                  (>= n limit)))
+                           (*unparse-string " ...")
+                           (unparse-stream-tail (safe-cdr value) (+ n 1))))
+                      (else
+                       (*unparse-string " . ")
+                       (*unparse-object value)))))))
+
 (define (safe-car pair)
   (map-reference-trap (lambda () (car pair))))
 
-- 
2.25.1