(module si-text-ui mzscheme
(require
(lib "plt-match.ss")
(planet "test.ss" ("schematics" "schemeunit.plt" 2 1))
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 1))
(planet "plt/monad.ss" ("schematics" "schemeunit.plt" 2 1))
(planet "plt/hash-monad.ss" ("schematics" "schemeunit.plt" 2 1))
(planet "plt/name-collector.ss" ("schematics" "schemeunit.plt" 2 1))
(file "database.ss")
(file "counter.ss")
(file "base.ss"))
(provide test/si-text-ui)
(define (save-results name)
(define (write-results successes failures errors bugs)
(lambda (monad)
(with-database
(name->database-name name)
(lambda (db)
(write-sample
db
(create-sample name successes failures errors bugs))))
monad))
(compose
(counter->vector)
(match-lambda
((vector s f e b)
(write-results s f e b)))))
(define (si-display-summary+return monad)
(monad-value
((compose
(sequence*
(display-counter)
(counter->vector))
(match-lambda
((vector s f e b)
(return-hash (+ f e)))))
monad)))
(define (test/si-text-ui name test)
((sequence*
(lambda (monad)
(foldts (lambda (suite name before after seed)
(before)
((push-suite-name! name) seed))
(lambda (suite name before after seed kid-seed)
(after)
((pop-suite-name!) kid-seed))
(lambda (case name action seed)
(let ((result (run-test-case name action)))
((sequence* (update-counter! case result)
(display-test-case-name result)
(lambda (hash)
(display-result result)
(display-check-info result)
hash))
seed)))
((sequence
(put-initial-counter)
(put-initial-name))
monad)
test))
(save-results name)
si-display-summary+return)
(make-empty-hash)))
)