94 lines
3.8 KiB
Scheme
94 lines
3.8 KiB
Scheme
(module test mzscheme
|
|
(require mzlib/pretty)
|
|
(provide test test-list test-err test-results)
|
|
|
|
(define show-tests? #t)
|
|
|
|
(define test-count (box 0))
|
|
(define failure-count (box 0))
|
|
(define (test-results)
|
|
(cond
|
|
[(= 0 (unbox failure-count))
|
|
(fprintf (current-error-port) "All ~a tests passed." (unbox test-count))]
|
|
[else
|
|
(fprintf (current-error-port) "~a tests failed, ~a tests total"
|
|
(unbox failure-count)
|
|
(unbox test-count))]))
|
|
|
|
(define-syntax (test-err stx)
|
|
(syntax-case stx ()
|
|
[(_ actual pred)
|
|
(with-syntax ([line (syntax-line (syntax actual))])
|
|
(syntax
|
|
(with-handlers ([pred (lambda (x) (void))])
|
|
(when show-tests? (printf "> running test ~s\n" line))
|
|
(set-box! test-count (+ (unbox test-count) 1))
|
|
(fprintf (current-error-port)
|
|
"test ~a ~s:\n expected error, got ~a\n\n"
|
|
line
|
|
'actual
|
|
(flatten-list (call-with-values (lambda () actual) list)))
|
|
(set-box! failure-count (+ (unbox failure-count) 1)))))]))
|
|
|
|
(define-syntax (test stx)
|
|
(syntax-case stx ()
|
|
[(_ actual expecteds ...) (syntax (test/pred equal? actual expecteds ...))]))
|
|
|
|
(define-syntax (test/pred stx)
|
|
(syntax-case stx ()
|
|
[(_ equal? actual expecteds ...)
|
|
(with-syntax ([line (syntax-line (syntax actual))])
|
|
(syntax
|
|
(begin
|
|
(when show-tests? (printf "> running test ~s\n" line))
|
|
(let ([actual-xs (call-with-values (lambda () actual) list)]
|
|
[expect-xs (list expecteds ...)])
|
|
(set-box! test-count (+ (unbox test-count) 1))
|
|
(unless (equal? actual-xs expect-xs)
|
|
(set-box! failure-count (+ (unbox failure-count) 1))
|
|
(fprintf (current-error-port) "test ~a ~s:\ngot:\n" line 'actual)
|
|
(for-each (lambda (x) (pretty-print x (current-error-port))) actual-xs)
|
|
(fprintf (current-error-port) "expected:\n")
|
|
(for-each (lambda (x) (pretty-print x (current-error-port))) expect-xs))))))]))
|
|
|
|
(define-syntax (test-list stx)
|
|
(syntax-case stx ()
|
|
[(_ actual expected)
|
|
(with-syntax ([line (syntax-line (syntax actual))])
|
|
(syntax
|
|
(begin
|
|
(when show-tests? (printf "> running test ~s\n" line))
|
|
(let ([actual-x actual]
|
|
[expect-x expected]
|
|
[show-err
|
|
(lambda (in not-in val)
|
|
(set-box! failure-count (+ (unbox failure-count) 1))
|
|
(fprintf (current-error-port) "test ~a ~s found in ~a but not in ~a:\n"
|
|
line
|
|
'actual
|
|
in
|
|
not-in)
|
|
(pretty-print val (current-error-port)))])
|
|
(set-box! test-count (+ (unbox test-count) 1))
|
|
(for-each (lambda (one-actual)
|
|
(unless (member one-actual expect-x)
|
|
(show-err "actual" "expected" one-actual)))
|
|
actual-x)
|
|
(for-each (lambda (one-expected)
|
|
(unless (member one-expected actual-x)
|
|
(show-err "expected" "actual" one-expected)))
|
|
expect-x)))))]))
|
|
|
|
(define (flatten-list lst)
|
|
(cond
|
|
[(null? lst) ""]
|
|
[else
|
|
(let loop ([lst (cdr lst)]
|
|
[ss (list (format "~e" (car lst)))])
|
|
(cond
|
|
[(null? lst) (apply string-append (reverse ss))]
|
|
[else (loop (cdr lst)
|
|
(list* (format "~e" (car lst))
|
|
" "
|
|
ss))]))])))
|