#lang scheme/base
(require scheme/match
scheme/pretty
srfi/13
srfi/26)
(require "base.ss"
"counter.ss"
"format.ss"
"location.ss"
"result.ss"
"test.ss"
"monad.ss"
"hash-monad.ss"
"name-collector.ss"
"text-ui-util.ss")
(provide run-tests
display-context
display-exn
display-summary+return
display-ticker
display-result)
(define (display-ticker result)
(cond
((test-error? result)
(display "!"))
((test-failure? result)
(display "-"))
(else
(display "."))))
(define (display-test-preamble result)
(lambda (hash)
(if (test-success? result)
hash
(begin
(display-delimiter)
hash))))
(define (display-test-postamble result)
(lambda (hash)
(if (test-success? result)
hash
(begin
(display-delimiter)
hash))))
(define (display-result result)
(cond
((test-error? result)
(display-test-name (test-result-test-case-name result))
(display-error)
(newline))
((test-failure? result)
(display-test-name (test-result-test-case-name result))
(display-failure)
(newline))
(else
(void))))
(define (strip-redundant-params stack)
(define (binary-check-this-frame? stack)
(let loop ([stack stack])
(cond
[(null? stack) #f]
[(check-name? (car stack)) #f]
[(check-actual? (car stack)) #t]
[else (loop (cdr stack))])))
(let loop ([stack stack])
(cond
[(null? stack) null]
[(check-params? (car stack))
(if (binary-check-this-frame? stack)
(loop (cdr stack))
(cons (car stack) (loop (cdr stack))))]
[else (cons (car stack) (loop (cdr stack)))])))
(define (display-context result [verbose? #f])
(cond
[(test-failure? result)
(let* ([exn (test-failure-result result)]
[stack (exn:test:check-stack exn)])
(for-each
(lambda (info)
(cond
[(check-name? info)
(display-check-info info)]
[(check-location? info)
(display-check-info-name-value
'location
(trim-current-directory
(location->string
(check-info-value info)))
display)]
[(check-params? info)
(display-check-info-name-value
'params
(check-info-value info)
(lambda (v) (map pretty-print v)))]
[(check-actual? info)
(display-check-info-name-value
'actual
(check-info-value info)
pretty-print)]
[(check-expected? info)
(display-check-info-name-value
'expected
(check-info-value info)
pretty-print)]
[(and (check-expression? info)
(not verbose?))
(void)]
[else
(display-check-info info)]))
(if verbose?
stack
(strip-redundant-params 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-context test)
(begin0 (fold-test-results
(lambda (result seed)
((sequence* (update-counter! result)
(display-test-preamble result)
(display-test-case-name result)
(lambda (hash)
(display-result result)
(display-context result)
hash)
(display-test-postamble result))
seed))
((sequence
(put-initial-counter)
(put-initial-name))
(make-empty-hash))
test
#:fdown (lambda (name seed) ((push-suite-name! name) seed))
#:fup (lambda (name kid-seed) ((pop-suite-name!) kid-seed)))))
(define (display-summary+return monad)
(monad-value
((compose
(sequence*
(display-counter)
(counter->vector))
(match-lambda
((vector s f e)
(return-hash (+ f e)))))
monad)))
(define (run-tests 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 (result seed)
((update-counter! result) seed))
((put-initial-counter)
(make-empty-hash))
test))
((normal) (std-test/text-ui display-context test))
((verbose) (std-test/text-ui
(cut display-context <> #t)
test))))))