(module text-ui mzscheme
(require (lib "include.ss")
(lib "plt-match.ss")
(lib "pretty.ss")
(only (lib "etc.ss") opt-lambda)
(lib "string.ss" "srfi" "13")
(lib "cut.ss" "srfi" "26")
"location.ss"
"test.ss"
"monad.ss"
"hash-monad.ss"
"counter.ss"
"name-collector.ss"
"text-ui-util.ss")
(provide test/text-ui
display-check-info
display-exn
display-summary+return
display-ticker
display-result)
(include "../generic/text-ui.ss")
(define (display-exn exn)
(let ([op (open-output-string)])
(parameterize ([current-error-port op])
((error-display-handler)
(exn-message exn)
exn))
(display (get-output-string op))
(newline)))
(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-check-info
(opt-lambda (result [verbose? #f])
(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)
(display "params:\n")
(map pretty-print value))]
[(check-actual? info)
(display "actual: ")
(pretty-print (check-info-value info))]
[(check-expected? info)
(display "expected: ")
(pretty-print (check-info-value info))]
[(and (check-expression? info)
(not verbose?))
(void)]
[else
(printf "~a: ~v\n"
(check-info-name info)
value)])))
(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-check-info test)
(fold-test-results
(lambda (result seed)
((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
#: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 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 (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
(cut display-check-info <> #t)
test)))))))
)