(module text-ui mzscheme
(require (lib "string.ss")
(lib "match.ss")
"schemeunit.ss"
"assert-base.ss"
"assert.ss"
"assert-util.ss")
(provide test/text-ui)
(define-struct count (successes failures errors))
(define (add-success! count)
(set-count-successes! count (add1 (count-successes count))))
(define (add-failure! count)
(set-count-failures! count (add1 (count-failures count))))
(define (add-error! count)
(set-count-errors! count (add1 (count-errors count))))
(define (print-success names result)
(void))
(define (print-common-info result)
(let* ((stack (exn:test:assertion-stack result))
(locrep (get-assertion-location-representative stack))
(spacer (make-string 2 #\space)))
(if locrep (printf "~a~n" (syntax->location-string locrep)))
(let loop ((stack stack))
(match stack
(() 'done)
((first . rest)
(if (eq? locrep first)
(loop rest)
(begin
(display spacer)
(printf "~a: ~s~n"
(assertion-info-name first)
(assertion-info-value first))
(loop rest))))))))
(define (print-separator length)
(printf "~a~n" (make-string length #\-)))
(define (print-names names)
(printf "~a" (car names))
(for-each
(lambda (name)
(printf " < ~a" name))
(cdr names))
(newline))
(define (print-failure names result)
(newline)
(print-names names)
(printf "Has a FAILURE:~n")
(print-common-info result)
(newline))
(define (print-error names result)
(newline)
(print-names names)
(printf "Has an ERROR~n")
(cond [(exn? result)
(printf " type: ~a~n" (object-name result))
(printf " message: ~e~n" (exn-message result))]
[else
(printf " an error occurred which was not an exception: ~e~n"
result)])
(newline))
(define print-summary
(match-lambda
[($ count successes failures errors)
(printf "~a success(es) ~a error(s) ~a failure(s)~n"
successes
errors
failures)]))
(define (print-result result names)
(match result
[($ test-failure case result)
(print-failure names result)]
[($ test-error case result)
(print-error names result)]
[($ test-success case result)
(print-success names result)]))
(define (update-count! count result)
(match result
[($ test-failure case result)
(add-failure! count)]
[($ test-error case result)
(add-error! count)]
[($ test-success case result)
(print-success case result)]))
(define (test/text-ui test)
(define seed
(vector (make-count 0 0 0) null))
(define (add-name seed name)
(vector (get-count seed)
(cons name (get-names seed))))
(define (remove-name seed)
(vector (get-count seed)
(cdr (get-names seed))))
(define (get-names seed)
(vector-ref seed 1))
(define (get-count seed)
(vector-ref seed 0))
(define (fdown name setup teardown seed)
(setup)
(add-name seed name))
(define (fup name setup teardown seed kid-seed)
(teardown)
(remove-name kid-seed))
(define (fhere name action setup teardown seed)
(let ((result
(run-test-case name action setup teardown)))
(print-result result (cons name (get-names seed)))
(update-count! (get-count seed) result)
seed))
(print-summary
(get-count (foldts fdown fup fhere seed test))))
)