Fix indentation of test runner output

Fix standard test runner so that its output is properly indented and
lines are properly terminated.

Refactor standard test runner so that it is possible to plug in another
runner with different output.

lib/chibi/test.scm

@@ -23,6 +23,20 @@
             args)
   (newline (current-error-port)))
 
+(define (exception-message exc)
+  (let* ((s (parameterize
+               ((current-output-port (open-output-string)))
+             (print-exception exc (current-output-port))
+             (get-output-string (current-output-port))))
+         (n (- (string-length s) 1)))
+    (let loop ((i 0))
+      (if (>= (+ i 2) n)
+          (substring s 0 n)
+          (if (and (char=? (string-ref s i) #\:)
+                   (char=? (string-ref s (+ i 1)) #\space))
+              (substring s (+ i 2) n)
+              (loop (+ i 1)))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; string utilities
 
@@ -242,66 +256,43 @@
 
 ;;> Begin testing a new group until the closing \scheme{(test-end)}.
 
-(define (test-begin . o)
+(define test-begin
-  (let* ((name (if (pair? o) (car o) ""))
+  (case-lambda
-         (parent (current-test-group))
+   (()
-         (group (make-test-group name parent)))
+    (test-begin ""))
-    ;; include a newline if we are directly nested in a parent with no
+   ((name)
-    ;; tests yet
+    (let* ((parent (current-test-group))
-    (when (and parent
+           (group (make-test-group name parent)))
-               (zero? (test-group-ref parent 'subgroups-count 0))
+      ((current-test-group-reporter) group parent)
-               (not (test-group-ref parent 'verbose)))
+      (current-test-group group)))))
-      (newline))
-    ;; header
-    (cond
-     ((test-group-ref group 'skip-group?)
-      (display (make-string (or (test-group-indent-width group) 0) #\space))
-      (display (strikethrough (bold (string-append name ":"))))
-      (display " SKIP"))
-     ((test-group-ref group 'verbose)
-      (display
-       (test-header-line
-        (string-append "testing " name)
-        (or (test-group-indent-width group) 0))))
-     (else
-      (display
-       (string-append
-        (make-string (or (test-group-indent-width group) 0)
-                     #\space)
-        (bold (string-append name ": "))))))
-    ;; set the current test group
-    (current-test-group group)))
 
 ;;> Ends testing group introduced with \scheme{(test-begin)}, and
 ;;> summarizes the results.  The \var{name} is optional, but if
 ;;> present should match the corresponding \scheme{test-begin} name,
 ;;> or a warning is printed.
 
-(define (test-end . o)
+(define test-end
-  (let ((name (and (pair? o) (car o))))
+  (case-lambda
-    (cond
+   (()
-     ((current-test-group)
+    (test-end #f))
-      => (lambda (group)
+   ((name)
-           (when (and name (not (equal? name (test-group-name group))))
+    (let ((group (current-test-group)))
-             (warning "mismatched test-end:" name (test-group-name group)))
+      (when group
-           (let ((parent (test-group-ref group 'parent)))
+        (when (and name (not (equal? name (test-group-name group))))
-             (when (and (test-group-ref group 'skip-group?)
+          (warning "mismatched test-end:" name (test-group-name group)))
-                        (zero? (test-group-ref group 'subgroups-count 0)))
+        ((current-test-group-reporter) group)
-               (newline))
+        (let ((parent (test-group-ref group 'parent)))
-             ;; only report if there's something to say
+          (when parent
-             ((current-test-group-reporter) group)
+            (test-group-inc! parent 'subgroups-count)
-             (when parent
+            (cond
-               (test-group-inc! parent 'subgroups-count)
+             ((test-group-ref group 'skip-group?)
-               (cond
+              (test-group-inc! parent 'subgroups-skip))
-                ((test-group-ref group 'skip-group?)
+             ((and (zero? (test-group-ref group 'FAIL 0))
-                 (test-group-inc! parent 'subgroups-skip))
+                   (zero? (test-group-ref group 'ERROR 0))
-                ((and (zero? (test-group-ref group 'FAIL 0))
+                   (= (test-group-ref group 'subgroups-pass 0)
-                      (zero? (test-group-ref group 'ERROR 0))
+                      (test-group-ref group 'subgroups-count 0)))
-                      (= (test-group-ref group 'subgroups-pass 0)
+              (test-group-inc! parent 'subgroups-pass))))
-                         (test-group-ref group 'subgroups-count 0)))
+          (current-test-group parent)))))))
-                 (test-group-inc! parent 'subgroups-pass))))
-             (current-test-group parent)
-             group))))))
 
 ;;> Exits with a failure status if any tests have failed,
 ;;> and a successful status otherwise.
@@ -324,28 +315,30 @@
 
 ;;> \section{Accessors}
 
-;; (name (prop value) ...)
+;; (name (prop . value) ...)
-(define (make-test-group name . o)
+(define (make-test-group name parent)
-  (let ((parent (and (pair? o) (car o)))
+  (let* ((g (list name))
-        (group (list name (cons 'start-time (current-second)))))
+         (! (lambda (k v) (test-group-set! g k v))))
-    (test-group-set! group 'parent parent)
+    (! 'start-time (current-second))
-    (test-group-set! group 'verbose
+    (! 'parent parent)
-                     (if parent
+    (! 'verbose
-                         (test-group-ref parent 'verbose)
+       (if parent
-                         (current-test-verbosity)))
+           (test-group-ref parent 'verbose)
-    (test-group-set! group 'level
+           (current-test-verbosity)))
-                     (if parent
+    (! 'level
-                         (+ 1 (test-group-ref parent 'level 0))
+       (if parent
-                         0))
+           (+ 1 (test-group-ref parent 'level 0))
-    (test-group-set!
+           0))
-     group
+    (! 'skip-group?
-     'skip-group?
+       (and (or (and parent
-     (and (or (and parent (test-group-ref parent 'skip-group?))
+                     (test-group-ref parent 'skip-group?))
-              (any (lambda (f) (f group)) (current-test-group-removers))
+                (any (lambda (f) (f g))
-              (and (null? (current-test-group-removers))
+                     (current-test-group-removers))
-                   (pair? (current-test-group-filters))))
+                (and (null? (current-test-group-removers))
-          (not (any (lambda (f) (f group)) (current-test-group-filters)))))
+                     (pair? (current-test-group-filters))))
-    group))
+            (not (any (lambda (f) (f g))
+                      (current-test-group-filters)))))
+    g))
 
 ;;> Returns the name of a test group info object.
 
@@ -490,23 +483,36 @@
          (set-cdr! info (cons (cons 'gen-name name) (cdr info))))
      name)))
 
-(define (test-print-name info . indent)
+(define (test-print-name info indent)
-  (let ((width (- (current-column-width)
+  (let* ((width (- (current-column-width) indent))
-                  (or (and (pair? indent) (car indent)) 0)))
+         (name (test-get-name! info))
-        (name (test-get-name! info)))
+         (diff (- width 9 (string-length name))))
-    (display name)
+    (display
+     (if (positive? diff)
+         name
+         (string-append
+          (substring name 0 (+ (string-length name) diff -1))
+          (string (integer->char #x2026)))))
     (display " ")
-    (let ((diff (- width 9 (string-length name))))
+    (if (positive? diff)
-      (cond
+        (display (make-string diff (integer->char #x2024))))
-       ((positive? diff)
-        (display (make-string diff #\.)))))
     (display " ")
     (flush-output-port)))
 
 (define (test-group-indent-width group)
   (let ((level (max 0 (+ 1 (- (test-group-ref group 'level 0)
                               (test-first-indentation))))))
-    (* 4 (min level (test-max-indentation)))))
+    (* (current-group-indent) (min level (test-max-indentation)))))
+
+(define indent-string
+  (let ((first? #t))
+    (lambda (indent)
+      (string-append
+       (if first?
+           (begin
+             (set! first? #f) "")
+           "\n")
+       (make-string indent #\space)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -521,39 +527,34 @@
         info)))
 
 (define (test-default-applier expect expr info)
-  (let* ((group (current-test-group))
+  ((current-test-reporter) #f info)
-         (indent (and group (test-group-indent-width group))))
+  (let ((expect-val
-    (cond
+         (guard
-     ((or (not group) (test-group-ref group 'verbose))
+             (exn
-      (if (and indent (positive? indent))
+              (else
-          (display (make-string indent #\space)))
+               (warning "bad expect value")
-      (test-print-name info indent)))
+               (print-exception exn (current-error-port))
-    (let ((expect-val
+               #f))
-           (guard
+           (expect))))
-               (exn
+    (guard
-                (else
+        (exn
-                 (warning "bad expect value")
+         (else
-                 (print-exception exn (current-error-port))
+          ((current-test-reporter)
-                 #f))
+           (if (assq-ref info 'expect-error) 'PASS 'ERROR)
-             (expect))))
+           (append `((exception . ,exn)) info))))
-      (guard
+      (let ((res (expr)))
-          (exn
+        (let ((status
-           (else
+               (if (and (not (assq-ref info 'expect-error))
-            ((current-test-reporter)
+                        (if (assq-ref info 'assertion)
-             (if (assq-ref info 'expect-error) 'PASS 'ERROR)
+                            res
-             (append `((exception . ,exn)) info))))
+                            ((current-test-comparator) expect-val res)))
-        (let ((res (expr)))
+                   'PASS
-          (let ((status
+                   'FAIL))
-                 (if (and (not (assq-ref info 'expect-error))
+              (info `((result . ,res) (expected . ,expect-val) ,@info)))
-                          (if (assq-ref info 'assertion)
+          ((current-test-reporter) status info))))))
-                              res
-                              ((current-test-comparator) expect-val res)))
-                     'PASS
-                     'FAIL))
-                (info `((result . ,res) (expected . ,expect-val) ,@info)))
-            ((current-test-reporter) status info)))))))
 
 (define (test-default-skipper info)
+  ((current-test-reporter) #f info)
   ((current-test-reporter) 'SKIP info))
 
 (define (test-status-color status)
@@ -588,21 +589,22 @@
 (define (test-print-explanation indent status info)
   (cond
    ((eq? status 'ERROR)
-    (display indent)
     (cond ((assq 'exception info)
-           => (lambda (e)
+           => (lambda (exc)
-                (print-exception (cdr e) (current-output-port))))))
+                (display indent)
+                (display "Exception: ")
+                (display (exception-message (cdr exc)))))))
    ((and (eq? status 'FAIL) (assq-ref info 'assertion))
     (display indent)
-    (display "assertion failed\n"))
+    (display "assertion failed"))
    ((and (eq? status 'FAIL) (assq-ref info 'expect-error))
     (display indent)
     (display "expected an error but got ")
-    (write (assq-ref info 'result)) (newline))
+    (write (assq-ref info 'result)))
    ((eq? status 'FAIL)
     (display indent)
-    (display-expected/actual (assq-ref info 'expected) (assq-ref info 'result))
+    (display-expected/actual
-    (newline)))
+     (assq-ref info 'expected) (assq-ref info 'result))))
   ;; print variables
   (cond
    ((and (memq status '(FAIL ERROR)) (assq-ref info 'var-names))
@@ -612,11 +614,11 @@
                     (pair? values)
                     (= (length names) (length values)))
                (let ((indent2
-                      (string-append indent (make-string 2 #\space))))
+                      (string-append indent (string #\space #\space))))
                  (for-each
                   (lambda (name value)
-                    (display indent2) (write name) (display ": ")
+                    (display indent2)
-                    (write value) (newline))
+                    (write name) (display ": ") (write value))
                   names values))))))))
 
 (define (test-print-source indent status info)
@@ -625,11 +627,11 @@
      (cond
       ((assq-ref info 'line-number)
        => (lambda (line)
-            (display "    on line ")
+            (display indent)
+            (display "on line ")
             (write line)
             (cond ((assq-ref info 'file-name)
-                   => (lambda (file) (display " of file ") (write file))))
+                   => (lambda (file) (display " of file ") (write file)))))))
-            (newline))))
      (cond
       ((assq-ref info 'source)
        => (lambda (s)
@@ -637,15 +639,15 @@
              ((or (assq-ref info 'name)
                   (> (string-length (write-to-string s))
                      (current-column-width)))
-              (display (write-to-string s))
+              (display indent)
-              (newline))))))
+              (display (write-to-string s)))))))
      (cond
       ((assq-ref info 'values)
        => (lambda (v)
             (for-each
              (lambda (v)
-               (display "    ") (display (car v))
+               (display indent) (display (car v))
-               (display ": ") (write (cdr v)) (newline))
+               (display ": ") (write (cdr v)))
              v)))))))
 
 (define (test-print-failure indent status info)
@@ -654,21 +656,44 @@
   ;; display line, source and values info
   (test-print-source indent status info))
 
-(define (test-header-line str . indent)
+(define (test-group-line group open?)
-  (let* ((header (string-append
+  (let* ((name (test-group-name group))
-                  (make-string (if (pair? indent) (car indent) 0) #\space)
+         (spaces (test-group-indent-width group))
-                  "-- " str " "))
+         (indent (indent-string spaces)))
-         (len (string-length header)))
+    (if (test-group-ref group 'verbose)
-    (string-append (bold header)
+        (let ((text (string-append
-                   (make-string (max 0 (- (current-column-width) len)) #\-))))
+                     (if open? "" "done ")
+                     (if (test-group-ref group 'skip-group?)
+                         "skipping "
+                         "testing ")
+                     name)))
+          (string-append
+           indent
+           "-- "
+           (bold text)
+           " "
+           (make-string
+            (max 0 (- (current-column-width)
+                      (string-length text) spaces 4))
+            #\-)))
+        (string-append
+         indent
+         (bold (string-append name ": "))))))
 
-(define (test-default-handler status info)
+(define (start-test info)
+  (let ((group (current-test-group)))
+    (when (or (not group) (test-group-ref group 'verbose))
+      (let ((indent (and group (test-group-indent-width group))))
+        (when (and indent (positive? indent))
+          (display (indent-string indent)))
+        (test-print-name info (or indent 4))))))
+(define (stop-test status info)
   (define indent
-    (make-string
+    (indent-string
-     (+ 4 (cond ((current-test-group)
+     (+ (current-group-indent)
-                 => (lambda (group) (or (test-group-indent-width group) 0)))
+        (cond ((current-test-group)
-                (else 0)))
+               => test-group-indent-width)
-     #\space))
+              (else 0)))))
   ;; update group info
   (cond
    ((current-test-group)
@@ -678,15 +703,16 @@
          (test-group-inc! group status)
          ;; maybe wrap long status lines
          (let ((width (max (- (current-column-width)
-                              (or (test-group-indent-width group) 0))
+                              (test-group-indent-width group))
-                           4))
+                           (current-group-indent)))
                (column
-                (+ (string-length (or (test-group-name group) ""))
+                (+ (string-length (test-group-name group))
-                   (or (test-group-ref group 'count) 0)
+                   (test-group-ref group 'count 0)
                    1)))
            (if (and (zero? (modulo column width))
                     (not (test-group-ref group 'verbose)))
-               (display (string-append "\n" (string-copy indent 4))))))))
+               (display
+                (string-copy indent (current-group-indent))))))))
   ;; update global failure count for exit status
   (cond
    ((or (eq? status 'FAIL) (eq? status 'ERROR))
@@ -699,7 +725,6 @@
     (if (not (eq? status 'ERROR)) (display " ")) ; pad
     (display (test-status-message status))
     (display "]")
-    (newline)
     (test-print-failure indent status info))
    ((eq? status 'SKIP))
    (else
@@ -712,8 +737,12 @@
            => (lambda (group) (test-group-set! group 'trailing #t))))))
   (flush-output-port)
   status)
+(define (test-default-reporter status info)
+  (if (symbol? status)
+      (stop-test status info)
+      (start-test info)))
 
-(define (test-default-group-reporter group)
+(define (close-group group)
   (define (plural word n)
     (if (= n 1) word (string-append word "s")))
   (define (percent n d)
@@ -722,30 +751,25 @@
   (let* ((end-time (current-second))
          (start-time (test-group-ref group 'start-time))
          (duration (- end-time start-time))
-         (base-count (or (test-group-ref group 'count) 0))
+         (base-count (test-group-ref group 'count 0))
-         (base-pass (or (test-group-ref group 'PASS) 0))
+         (base-pass (test-group-ref group 'PASS 0))
-         (base-fail (or (test-group-ref group 'FAIL) 0))
+         (base-fail (test-group-ref group 'FAIL 0))
-         (base-err (or (test-group-ref group 'ERROR) 0))
+         (base-err (test-group-ref group 'ERROR 0))
-         (skip (or (test-group-ref group 'SKIP) 0))
+         (skip (test-group-ref group 'SKIP 0))
-         (pass (+ base-pass (or (test-group-ref group 'total-pass) 0)))
+         (pass (+ base-pass (test-group-ref group 'total-pass 0)))
-         (fail (+ base-fail (or (test-group-ref group 'total-fail) 0)))
+         (fail (+ base-fail (test-group-ref group 'total-fail 0)))
-         (err (+ base-err (or (test-group-ref group 'total-error) 0)))
+         (err (+ base-err (test-group-ref group 'total-error 0)))
          (count (+ pass fail err))
-         (subgroups-count (or (test-group-ref group 'subgroups-count) 0))
+         (subgroups-count (test-group-ref group 'subgroups-count 0))
-         (subgroups-skip (or (test-group-ref group 'subgroups-skip) 0))
+         (subgroups-skip (test-group-ref group 'subgroups-skip 0))
          (subgroups-run (- subgroups-count subgroups-skip))
-         (subgroups-pass (or (test-group-ref group 'subgroups-pass) 0))
+         (subgroups-pass (test-group-ref group 'subgroups-pass 0))
-         (indent (make-string (or (test-group-indent-width group) 0) #\space)))
+         (indent (indent-string (test-group-indent-width group))))
-    (if (and (not (test-group-ref group 'verbose))
+    (when (or (positive? count) (positive? subgroups-count))
-             (test-group-ref group 'trailing))
-        (newline))
-    (cond
-     ((or (positive? count) (positive? subgroups-count))
       (if (not (= base-count (+ base-pass base-fail base-err)))
           (warning "inconsistent count:"
                    base-count base-pass base-fail base-err))
-      (cond
+      (when (positive? count)
-       ((positive? count)
         (display indent)
         (display
          ((if (= pass count) green (lambda (x) x))
@@ -760,34 +784,31 @@
            ((zero? skip) "")
            (else (string-append " (" (number->string skip)
                                 (plural " test" skip) " skipped)")))
-          ".\n"))))
+          ".")))
-      (cond ((positive? fail)
+      (when (positive? fail)
-             (display indent)
+        (display indent)
-             (display
+        (display
-              (red
+         (red
-               (string-append
+          (string-append
-                (number->string fail) (plural " failure" fail)
+           (number->string fail) (plural " failure" fail)
-                (percent fail count) ".\n")))))
+           (percent fail count) "."))))
-      (cond ((positive? err)
+      (when (positive? err)
-             (display indent)
+        (display indent)
-             (display
+        (display
-              ((lambda (x) (underline (red x)))
+         ((lambda (x) (underline (red x)))
-               (string-append
+          (string-append
-                (number->string err) (plural " error" err)
+           (number->string err) (plural " error" err)
-                (percent err count) ".\n")))))
+           (percent err count) "."))))
-      (cond
+      (unless (test-group-ref group 'verbose)
-       ((not (test-group-ref group 'verbose))
         (for-each
          (lambda (failure)
            (display indent)
            (display (red
                      (string-append (display-to-string (cadr failure)) ": ")))
            (display (test-get-name! (car (cddr failure))))
-           (newline)
            (apply test-print-failure failure))
-         (reverse (or (test-group-ref group 'failures) '())))))
+         (reverse (or (test-group-ref group 'failures) '()))))
-      (cond
+      (when (positive? subgroups-run)
-       ((positive? subgroups-run)
         (display indent)
         (display
          ((if (= subgroups-pass subgroups-run)
@@ -797,21 +818,23 @@
            (number->string subgroups-run)
            (percent subgroups-pass subgroups-run))))
         (display (plural " subgroup" subgroups-pass))
-        (display " passed.\n")))))
+        (display " passed.")))
-    (cond
+    (when (test-group-ref group 'verbose)
-     ((test-group-ref group 'verbose)
+      (display (test-group-line group #f)))
-      (display
-       (test-header-line
-        (string-append "done testing " (or (test-group-name group) ""))
-        (or (test-group-indent-width group) 0)))
-      (newline)))
     (cond
      ((test-group-ref group 'parent)
       => (lambda (parent)
            (test-group-set! parent 'trailing #f)
            (test-group-inc! parent 'total-pass pass)
            (test-group-inc! parent 'total-fail fail)
-           (test-group-inc! parent 'total-error err))))))
+           (test-group-inc! parent 'total-error err)))
+     (else
+      (when (zero? (test-group-ref group 'level))
+        (newline))))))
+(define test-default-group-reporter
+  (case-lambda
+   ((group)        (close-group group))
+   ((group parent) (display (test-group-line group 'open)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; parameters
@@ -858,7 +881,7 @@
 ;;> alist.  Reports the result of the test and updates bookkeeping in
 ;;> the current test group for reporting.
 
-(define current-test-reporter (make-parameter test-default-handler))
+(define current-test-reporter (make-parameter test-default-reporter))
 
 ;;> Takes one argument, a test group, and prints a summary of the test
 ;;> results for that group.
@@ -987,3 +1010,14 @@
               => string->number)
              (else #f))
        78)))
+
+;;> Parameter controlling the indent in spaces for a group in test
+;;> output, can be set from the environment variable TEST_GROUP_INDENT,
+;;> otherwise defaults to 4.
+
+(define current-group-indent
+  (make-parameter
+   (or (cond ((get-environment-variable "TEST_GROUP_INDENT")
+              => string->number)
+             (else #f))
+       4)))

lib/chibi/test.sld

@@ -16,8 +16,9 @@
    current-test-epsilon current-test-comparator
    current-test-filters current-test-removers
    current-test-group-filters current-test-group-removers
-   current-column-width)
+   current-column-width current-group-indent)
   (import (scheme base)
+          (scheme case-lambda)
           (scheme write)
           (scheme complex)
           (scheme process-context)