bin: Pretty print actual and expected values.

1 files changed, 68 insertions, 5 deletions

diff --git a/bin/run64 b/bin/run64
index 6565acb..ae80e13 100755
--- a/bin/run64
+++ b/bin/run64
@@ -100,6 +100,68 @@ given string in an ANSI escape code."
   (display (color (string-append "== " text)))
   (newline))
 
+(define (pretty-print obj column)
+  "Pretty print OBJ. COLUMN is the current column the cursor is in, starting at 0."
+  (define (print-list-with-opener lst column opener)
+    ;; Open the list.
+    (display opener)
+    (let ((child-column (+ (string-length opener) column)))
+      (chibi:match lst
+        ;; If an empty list, close without doing anything else.
+        (()
+         (display ")"))
+        ((head tail ...)
+         ;; Print first element without any column.
+         (print head child-column)
+         ;; Print the rest of the elements after a newline and column each.
+         (for-each (lambda (element)
+                     (newline)
+                     (display (make-string child-column #\space))
+                     (print element child-column))
+                   tail)
+         ;; Close the list.
+         (display ")")))))
+
+  (define (print obj column)
+    (cond
+     ;; Lists
+     ((list? obj)
+      (print-list-with-opener obj column "("))
+     ;; Vectors
+     ((vector? obj)
+      (print-list-with-opener (vector->list obj) column "#("))
+     ;; Pairs that are not lists
+     ((pair? obj)
+      (if (or (vector? (car obj))
+              (vector? (cdr obj))
+              (list? (car obj))
+              (list? (cdr obj)))
+          ;; Print pairs with lists or vectors on several lines.
+          (let ((child-column (+ (string-length "(")
+                                 column)))
+            (display "(")
+            (print (car obj) child-column)
+            (newline)
+            (display (make-string child-column #\space))
+            (display ".")
+            (newline)
+            (display (make-string child-column #\space))
+            (print (cdr obj) child-column)
+            (display ")"))
+          ;; Print pairs with only atoms on a single line.
+          (begin
+            (display "(")
+            (print (car obj) column)
+            (display " . ")
+            (print (cdr obj) column)
+            (display ")"))))
+     ;; Atoms
+     (else
+      (write obj))))
+
+  (print obj column)
+  (newline))
+
 (define (main args)
   (let ((runner (make-runner)))
     (headline "test session starts" bold)
@@ -158,12 +220,13 @@ given string in an ANSI escape code."
                         ;; actual values.
                         (else
                          (newline)
-                         (display (red "Actual value: "))
-                         (write (assq-ref failure 'actual-value))
-                         (newline)
-                         (display (red "Expected value: "))
-                         (write (assq-ref failure 'expected-value))
+                         (display (red "Actual: "))
+                         (pretty-print (assq-ref failure 'actual-value)
+                                       (string-length "Actual: "))
                          (newline)
+                         (display (red "Expected: "))
+                         (pretty-print (assq-ref failure 'expected-value)
+                                       (string-length "Expected: "))
                          (newline)))))))
                 (test-runner-aux-value runner))
       (newline))