(module text-ui mzscheme
(require (lib "include.ss")
(lib "plt-match.ss")
(only (lib "etc.ss") opt-lambda)
(lib "string.ss" "srfi" "13")
(planet "aif.ss" ("schematics" "macro.plt"))
"location.ss"
"test.ss"
"monad.ss"
"hash-monad.ss"
"counter.ss"
"name-collector.ss")
(provide test/text-ui)
(include "../generic/text-ui.ss")
(define (display-exn exn)
(display (exn-message exn))
(newline))
(define (trim-current-directory path)
(let ((cd (path->string (current-directory))))
(aif index (string-contains path cd)
(string-drop path (add1 (string-length cd)))
path)))
(define (display-check-info result)
(cond
((test-failure? result)
(let* ((exn (test-failure-result result))
(stack (exn:test:check-stack exn)))
(for-each
(lambda (info)
(let ((value (check-info-value info)))
(cond
((check-name? info)
(printf "name: ~a\n" value))
((check-location? info)
(printf "location: ~a\n"
(trim-current-directory
(location->string
(check-info-value info)))))
((check-params? info)
(unless (null? value)
(printf "params: ~v\n" value)))
((check-expression? info))
(else
(printf "~a: ~v\n"
(check-info-name info)
value)))))
stack)))
((test-error? result)
(display-exn (test-error-result result)))
(else
(void))))
(define (display-verbose-check-info result)
(cond
((test-failure? result)
(let* ((exn (test-failure-result result))
(stack (exn:test:check-stack exn)))
(for-each
(lambda (info)
(cond
((check-location? info)
(display "location: ")
(display (trim-current-directory
(location->string
(check-info-value info)))))
(else
(display (check-info-name info))
(display ": ")
(write (check-info-value info))))
(newline))
stack)))
((test-error? result)
(display-exn (test-error-result result)))
(else
(void))))
(define (std-test/text-ui display-check-info test)
(foldts (lambda (suite name before after seed)
((push-suite-name! name) seed))
(lambda (suite name before after seed kid-seed)
((pop-suite-name!) kid-seed))
(lambda (case name action seed)
(let ((result (run-test-case name action)))
((sequence* (update-counter! result)
(display-test-case-name result)
(lambda (hash)
(display-result result)
(display-check-info result)
hash))
seed)))
((sequence
(put-initial-counter)
(put-initial-name))
(make-empty-hash))
test))
(define test/text-ui
(opt-lambda (test [mode 'normal])
(monad-value
((compose
(sequence*
(display-counter)
(counter->vector))
(match-lambda
((vector s f e)
(return-hash (+ f e)))))
(case mode
((quiet)
(fold-test-results
(lambda (name seed) seed)
(lambda (result seed)
((update-counter! result) seed))
((put-initial-counter)
(make-empty-hash))
test))
((normal) (std-test/text-ui display-check-info test))
((verbose) (std-test/text-ui display-verbose-check-info test)))))))
)