add truncated-print to (ice-9 pretty-print)

* module/ice-9/pretty-print.scm (pretty-print): Rework so "port" is the
  kwarg, and "port*" is the optional arg. #:port is still the keyword.

  (truncated-print): Add a printer that will ensure that the output
  stays within a certain width. It could use genwrite but it doesn't
  because it seems nice to allow breadth-first allocation of screen
  space, and it's also nice to balance some delimiters (e.g. #< and >).

module/ice-9/pretty-print.scm

@@ -17,7 +17,8 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 ;;;; 
 (define-module (ice-9 pretty-print)
-  #:export (pretty-print))
+  #:export (pretty-print
+            truncated-print))
 
 
 ;; From SLIB.
@@ -250,9 +251,9 @@
 
   (rev-string-append l 0))
 
-(define* (pretty-print obj #:optional port
+(define* (pretty-print obj #:optional port*
                        #:key 
-                       (port* (or port (current-output-port)) #:port)
+                       (port (or port* (current-output-port)))
                        (width 79)
                        (display? #f)
                        (per-line-prefix ""))
@@ -268,4 +269,139 @@ port directly after OBJ, like (pretty-print OBJ PORT)."
   (generic-write obj display?
 		 (- width (string-length per-line-prefix))
 		 per-line-prefix
-		 (lambda (s) (display s port*) #t)))
+		 (lambda (s) (display s port) #t)))
+
+;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
+;; genwrite.scm.
+(define* (truncated-print x #:optional port*
+                          #:key
+                          (port (or port* (current-output-port)))
+                          (width 79)
+                          (display? #f)
+                          (breadth-first? #f))
+  "Print @var{obj}, truncating the output, if necessary, to make it fit
+into @var{width} characters. By default, @var{x} will be printed using
+@code{write}, though that behavior can be overriden via the
+@var{display?} keyword argument.
+
+The default behaviour is to print depth-first, meaning that the entire
+remaining width will be available to each sub-expressoin of @var{x} --
+e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
+\"ration\" the available width, trying to allocate it equally to each
+sub-expression, via the @var{breadth-first?} keyword argument."
+
+  (define (print-sequence x width len ref next)
+    (let lp ((x x)
+             (width width)
+             (i 0))
+      (if (> i 0)
+          (display #\space))
+      (cond
+       ((= i len)) ; catches 0-length case
+       ((= i (1- len))
+        (print (ref x i) (if (zero? i) width (1- width))))
+       ((<= width 4)
+        (display "..."))
+       (else
+        (let ((str (with-output-to-string
+                     (lambda ()
+                       (print (ref x i)
+                              (if breadth-first?
+                                  (max 1
+                                       (1- (floor (/ width (- len i)))))
+                                  (- width 4)))))))
+          (display str)
+          (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
+
+  (define (print-tree x width)
+    ;; width is >= the width of # . #, which is 5
+    (let lp ((x x)
+             (width width))
+      (cond
+       ((or (not (pair? x)) (<= width 4))
+        (display ". ")
+        (print x (- width 2)))
+       (else
+        ;; width >= 5
+        (let ((str (with-output-to-string
+                     (lambda ()
+                       (print (car x)
+                              (if breadth-first?
+                                  (floor (/ (- width 3) 2))
+                                  (- width 4)))))))
+          (display str)
+          (display " ")
+          (lp (cdr x) (- width 1 (string-length str))))))))
+
+  (define (truncate-string str width)
+    ;; width is < (string-length str)
+    (let lp ((fixes '(("#<" . ">")
+                      ("#(" . ")")
+                      ("(" . ")")
+                      ("\"" . "\""))))
+      (cond
+       ((null? fixes)
+        "#")
+       ((and (string-prefix? (caar fixes) str)
+             (string-suffix? (cdar fixes) str)
+             (>= (string-length str)
+                 width
+                 (+ (string-length (caar fixes))
+                    (string-length (cdar fixes))
+                    3)))
+        (format #f "~a~a...~a"
+                (caar fixes)
+                (substring str (string-length (caar fixes))
+                           (- width (string-length (cdar fixes)) 3))
+                (cdar fixes)))
+       (else
+        (lp (cdr fixes))))))
+
+  (define (print x width)
+    (cond
+     ((<= width 0)
+      (error "expected a positive width" width))
+     ((list? x)
+      (cond
+       ((>= width 5)
+        (display "(")
+        (print-sequence x (- width 2) (length x) (lambda (x i) (car x)) cdr)
+        (display ")"))
+       (else
+        (display "#"))))
+     ((vector? x)
+      (cond
+       ((>= width 6)
+        (display "#(")
+        (print-sequence x (- width 3) (vector-length x) vector-ref identity)
+        (display ")"))
+       (else
+        (display "#"))))
+     ((uniform-vector? x)
+      (cond
+       ((>= width 9)
+        (format #t  "#~a(" (uniform-vector-element-type x))
+        (print-sequence x (- width 6) (uniform-vector-length x)
+                        uniform-vector-ref identity)
+        (display ")"))
+       (else
+        (display "#"))))
+     ((pair? x)
+      (cond
+       ((>= width 7)
+        (display "(")
+        (print-tree x (- width 2))
+        (display ")"))
+       (else
+        (display "#"))))
+     (else
+      (let* ((str (with-output-to-string
+                    (lambda () (if display? (display x) (write x)))))
+             (len (string-length str)))
+        (display (if (<= (string-length str) width)
+                     str
+                     (truncate-string str width)))))))
+
+  (with-output-to-port port
+    (lambda ()
+      (print x width))))