[functional-tests] Improve formatting of failures.

This commit is contained in:
Joe Thornber 2017-08-21 10:10:15 +01:00
parent 80f9d082d5
commit 8603a802ed

View File

@ -35,6 +35,7 @@
(fmt fmt) (fmt fmt)
(list-utils) (list-utils)
(thin-xml) (thin-xml)
(utils)
(srfi s8 receive) (srfi s8 receive)
(only (srfi s1 lists) drop-while)) (only (srfi s1 lists) drop-while))
@ -165,13 +166,18 @@
(vector-sort-by string<? fmt-keys (hashtable-keys scenarios)))) (vector-sort-by string<? fmt-keys (hashtable-keys scenarios))))
(define (fmt-scenarios keys fn) (define (fmt-scenarios keys fn)
(define (flush)
(flush-output-port (current-output-port)))
(define (describe prev-keys keys) (define (describe prev-keys keys)
(fmt #t (fmt #t
(cat (fmt-keys prev-keys keys) (cat (fmt-keys prev-keys keys)
(pad-char #\. (dsp #\space)
(space-to 40) (pad-char #\. (space-to 38))
(fn keys)) (dsp #\space)))
nl))) (flush)
(fmt #t (cat (fn keys) nl))
(flush))
(for-each describe (cons '() (reverse (cdr (reverse keys)))) keys)) (for-each describe (cons '() (reverse (cdr (reverse keys)))) keys))
@ -202,12 +208,49 @@
(display "pass") (display "pass")
(newline))) (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) (define (run-scenarios ss)
(fmt-scenarios ss (let ((pass 0)
(lambda (keys) (fail 0)
(let ((s (hashtable-ref scenarios keys #f))) (fail-keys '()))
((scenario-thunk s))
(dsp "pass"))))) (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))))
;;----------------------------------------------- ;;-----------------------------------------------