[Guile-commits] 01/01: Fix rank 0 arrays and nested arrays in truncated-print

[Daniel Llorens]

lloda pushed a commit to branch master
in repository guile.

commit 93cbaef1345d1ba09c584bbeac6acd4580b23d73
Author: Daniel Llorens <address@hidden>
Date:   Tue Feb 7 15:49:11 2017 +0100

    Fix rank 0 arrays and nested arrays in truncated-print
    
    * module/ice-9/pretty-print.scm (print): In the array case, pass
      #:inner? along to (print-sequence), unless we're at the last dimension
      of the array.
      Special case for 0-rank arrays, which cannot be empty and have no
      length.
    * test-suite/tests/print.test: Test some of the cases fixed by this
      patch.
---
 module/ice-9/pretty-print.scm |   35 +++++++++++++++++++++--------------
 test-suite/tests/print.test   |   29 ++++++++++++++++++++++++++++-
 2 files changed, 49 insertions(+), 15 deletions(-)

diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 22bbb8a..d3d7652 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -328,7 +328,7 @@ sub-expression, via the @var{breadth-first?} keyword 
argument."
 
   (let ((ellipsis-width (string-length ellipsis)))
 
-    (define (print-sequence x width len ref next)
+    (define* (print-sequence x width len ref next #:key inner?)
       (let lp ((x x)
                (width width)
                (i 0))
@@ -337,7 +337,7 @@ sub-expression, via the @var{breadth-first?} keyword 
argument."
         (cond
          ((= i len)) ; catches 0-length case
          ((and (= i (1- len)) (or (zero? i) (> width 1)))
-          (print (ref x i) (if (zero? i) width (1- width))))
+          (print (ref x i) (if (zero? i) width (1- width)) #:inner? inner?))
          ((<= width (+ 1 ellipsis-width))
           (display ellipsis))
          (else
@@ -347,7 +347,8 @@ sub-expression, via the @var{breadth-first?} keyword 
argument."
                                 (if breadth-first?
                                     (max 1
                                          (1- (floor (/ width (- len i)))))
-                                    (- width (+ 1 ellipsis-width))))))))
+                                    (- width (+ 1 ellipsis-width)))
+                                #:inner? inner?)))))
             (display str)
             (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
 
@@ -397,7 +398,7 @@ sub-expression, via the @var{breadth-first?} keyword 
argument."
          (else
           (lp (cdr fixes))))))
 
-    (define* (print x width #:key top?)
+    (define* (print x width #:key inner?)
       (cond
        ((<= width 0)
         (error "expected a positive width" width))
@@ -429,19 +430,25 @@ sub-expression, via the @var{breadth-first?} keyword 
argument."
          (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)))
-                         ""))
+        (let* ((type (array-type x))
+               (prefix
+                (if inner?
+                  ""
+                  (if (zero? (array-rank x))
+                    (string-append "#0" (if (eq? #t type) "" (symbol->string 
type)))
+                    (let ((s (format #f "~a"
+                                     (apply make-typed-array type *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)
+            (if (zero? (array-rank x))
+              (print (array-ref x) (- width width-prefix 2))
+              (print-sequence x (- width width-prefix 2) (array-length x)
+                              array-cell-ref identity
+                              #:inner? (< 1 (array-rank x))))
             (display ")"))
            (else
             (display "#")))))
@@ -463,4 +470,4 @@ sub-expression, via the @var{breadth-first?} keyword 
argument."
 
     (with-output-to-port port
       (lambda ()
-        (print x width #:top? #t)))))
+        (print x width)))))
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
index 836fa22..82cc776 100644
--- a/test-suite/tests/print.test
+++ b/test-suite/tests/print.test
@@ -147,6 +147,18 @@
   (pass-if-equal "#<directory (test-…>"
       (tprint (current-module) 20 "UTF-8"))
 
+  (pass-if-equal "#0(#)"
+      (tprint (make-typed-array #t 9.0) 6 "UTF-8"))
+  
+  (pass-if-equal "#0(9.0)"
+      (tprint (make-typed-array #t 9.0) 7 "UTF-8"))
+
+  (pass-if-equal "#0f64(#)"
+      (tprint (make-typed-array 'f64 9.0) 8 "UTF-8"))
+
+  (pass-if-equal "#0f64(9.0)"
+      (tprint (make-typed-array 'f64 9.0) 10 "UTF-8"))
+
   (pass-if-equal "#"
       (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8"))
 
@@ -160,4 +172,19 @@
       (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")))
+      (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8"))
+
+  (pass-if-equal "#2((#(9 9) #(9 9)) (#(9 9) #(9 9)))"
+      (tprint (make-typed-array #t (make-typed-array #t 9 2) 2 2) 40 "UTF-8"))
+
+  (pass-if-equal "#(#2((9 9) (9 9)) #2((9 9) (9 9)))"
+      (tprint (make-vector 2 (make-typed-array #t 9 2 2)) 40 "UTF-8"))
+
+  (pass-if-equal "(#2((9 9) (9 9)) #2((9 9) (9 9)))"
+      (tprint (make-list 2 (make-typed-array #t 9 2 2)) 40 "UTF-8"))
+
+  (pass-if-equal "(#0(9) #0(9))"
+      (tprint (make-list 2 (make-typed-array #t 9)) 20 "UTF-8"))
+
+  (pass-if-equal "(#0(9) #)"
+      (tprint (make-list 2 (make-typed-array #t 9)) 10 "UTF-8")))