[Guile-commits] 01/01: Support arrays in truncated-print

[Daniel Llorens]

lloda pushed a commit to branch master
in repository guile.

commit ee2125c63973e5ebef2a04eb60d85e6a2b3ea412
Author: Daniel Llorens <address@hidden>
Date:   Fri Feb 3 12:16:42 2017 +0100

    Support arrays in truncated-print
    
    * module/ice-9/pretty-print.scm (print): Handle general arrays.
    * test-suite/tests/print.test: Test truncated-print with general arrays.
---
 module/ice-9/pretty-print.scm |   21 +++++++++++++++++++--
 test-suite/tests/print.test   |   17 ++++++++++++++++-
 2 files changed, 35 insertions(+), 3 deletions(-)

diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 007061f..22bbb8a 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -397,7 +397,7 @@ sub-expression, via the @var{breadth-first?} keyword 
argument."
          (else
           (lp (cdr fixes))))))
 
-    (define (print x width)
+    (define* (print x width #:key top?)
       (cond
        ((<= width 0)
         (error "expected a positive width" width))
@@ -428,6 +428,23 @@ sub-expression, via the @var{breadth-first?} keyword 
argument."
           (display ")"))
          (else
           (display "#"))))
+       ((and (array? x) (not (string? x)))
+        (let* ((prefix (if top?
+                         (let ((s (format #f "~a"
+                                          (apply make-typed-array (array-type 
x)
+                                                 *unspecified*
+                                                 (make-list (array-rank x) 
0)))))
+                           (substring s 0 (- (string-length s) 2)))
+                         ""))
+               (width-prefix (string-length prefix)))
+          (cond
+           ((>= width (+ 2 width-prefix ellipsis-width))
+            (format #t  "~a(" prefix)
+            (print-sequence x (- width width-prefix 2) (array-length x)
+                            array-cell-ref identity)
+            (display ")"))
+           (else
+            (display "#")))))
        ((pair? x)
         (cond
          ((>= width (+ 4 ellipsis-width))
@@ -446,4 +463,4 @@ sub-expression, via the @var{breadth-first?} keyword 
argument."
 
     (with-output-to-port port
       (lambda ()
-        (print x width)))))
+        (print x width #:top? #t)))))
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
index 6ef0e9f..836fa22 100644
--- a/test-suite/tests/print.test
+++ b/test-suite/tests/print.test
@@ -145,4 +145,19 @@
       (tprint (current-module) 20 "ISO-8859-1"))
 
   (pass-if-equal "#<directory (test-…>"
-      (tprint (current-module) 20 "UTF-8")))
+      (tprint (current-module) 20 "UTF-8"))
+
+  (pass-if-equal "#"
+      (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8"))
+
+  (pass-if-equal "#2s32(…)"
+      (tprint (make-typed-array 's32 0 20 20) 8 "UTF-8"))
+
+  (pass-if-equal "#2s32(# …)"
+      (tprint (make-typed-array 's32 0 20 20) 10 "UTF-8"))
+
+  (pass-if-equal "#2s32((…) …)"
+      (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8"))
+
+  (pass-if-equal "#2s32((0 …) …)"
+      (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8")))