From 8603a802ed0a21c8a8385d6aa02793f6abf00291 Mon Sep 17 00:00:00 2001
From: Joe Thornber <ejt@redhat.com>
Date: Mon, 21 Aug 2017 10:10:15 +0100
Subject: [PATCH] [functional-tests] Improve formatting of failures.

---
 functional-tests/functional-tests.scm | 61 +++++++++++++++++++++++----
 1 file changed, 52 insertions(+), 9 deletions(-)

diff --git a/functional-tests/functional-tests.scm b/functional-tests/functional-tests.scm
index 34a1c48..5e04c2e 100644
--- a/functional-tests/functional-tests.scm
+++ b/functional-tests/functional-tests.scm
@@ -35,6 +35,7 @@
     (fmt fmt)
     (list-utils)
     (thin-xml)
+    (utils)
     (srfi s8 receive)
     (only (srfi s1 lists) drop-while))
 
@@ -165,13 +166,18 @@
       (vector-sort-by string<? fmt-keys (hashtable-keys scenarios))))
 
   (define (fmt-scenarios keys fn)
+    (define (flush)
+      (flush-output-port (current-output-port)))
+
     (define (describe prev-keys keys)
       (fmt #t
            (cat (fmt-keys prev-keys keys)
-                (pad-char #\.
-                          (space-to 40)
-                          (fn keys))
-                nl)))
+                (dsp #\space)
+                (pad-char #\. (space-to 38))
+                (dsp #\space)))
+      (flush)
+      (fmt #t (cat (fn keys) nl))
+      (flush))
 
     (for-each describe (cons '() (reverse (cdr (reverse keys)))) keys))
 
@@ -202,12 +208,49 @@
      (display "pass")
      (newline)))
 
+  ;; Returns #f if an error was raised, otherwise #t (the values from thunk are
+  ;; discarded).
+  (define (try thunk)
+    (call/cc
+      (lambda (k)
+        (with-exception-handler
+          (lambda (x)
+            (if (error? x)
+                (k #f)
+                (raise x)))
+            (lambda ()
+              (thunk)
+              #t)))))
+
   (define (run-scenarios ss)
-    (fmt-scenarios ss
-                   (lambda (keys)
-                     (let ((s (hashtable-ref scenarios keys #f)))
-                      ((scenario-thunk s))
-                      (dsp "pass")))))
+    (let ((pass 0)
+          (fail 0)
+          (fail-keys '()))
+
+      (fmt-scenarios ss
+                     (lambda (keys)
+                       (let ((s (hashtable-ref scenarios keys #f)))
+                        (if (try (scenario-thunk s))
+                            (begin (inc! pass)
+                                   (dsp "pass"))
+                            (begin (inc! fail)
+                                   (set! fail-keys (cons keys fail-keys))
+                                   (dsp "FAIL"))))))
+      (fmt #t nl (dsp "There were failures:") nl)
+      (fmt-scenarios fail-keys
+                     (lambda (_)
+                       (dsp "FAIL")))
+      (fmt #t (cat nl
+                   (num pass)
+                   (dsp "/")
+                   (num (+ pass fail))
+                   (dsp " tests passed")
+                   (if (zero? fail)
+                       (dsp #\.)
+                       (cat (dsp ", ")
+                            (num fail)
+                            (dsp " failures.")))
+                   nl))))
 
   ;;-----------------------------------------------