(module counter mzscheme
(require
(planet "test.ss" ("schematics" "schemeunit.plt" 2))
(planet "plt/monad.ss" ("schematics" "schemeunit.plt" 2))
(planet "plt/hash-monad.ss" ("schematics" "schemeunit.plt" 2))
"test.ss")
(provide display-counter
update-counter!
put-initial-counter
counter->vector)
(define key (gensym))
(define-struct counter (successes failures errors bugs))
(define (display-counter)
(compose
(get key)
(lambda (counter)
(let ((s (counter-successes counter))
(f (counter-failures counter))
(e (counter-errors counter))
(b (counter-bugs counter)))
(display s) (display " success(es) ")
(display f) (display " failure(s) ")
(display e) (display " error(s) ")
(display b) (display " bug(s) ")
(display (+ s f e)) (display " test(s) run")
(newline)
(return-hash (void))))))
(define (counter->vector)
(compose
(get key)
(lambda (counter)
(return-hash
(vector (counter-successes counter)
(counter-failures counter)
(counter-errors counter)
(counter-bugs counter))))))
(define (update-counter! case result)
(define (add-success! counter)
(set-counter-successes! counter
(add1 (counter-successes counter))))
(define (add-failure! counter)
(set-counter-failures! counter
(add1 (counter-failures counter))))
(define (add-error! counter)
(set-counter-errors! counter
(add1 (counter-errors counter))))
(define (add-bug! counter)
(set-counter-bugs! counter
(add1 (counter-bugs counter))))
(compose
(get key)
(lambda (counter)
(cond
((test-error? result)
(add-error! counter))
((test-failure? result)
(add-failure! counter))
(else
(add-success! counter)))
(when (bug-test-case? case)
(add-bug! counter))
(put key counter))))
(define (put-initial-counter)
(put key (make-counter 0 0 0 0)))
)