racket/collects/games/parcheesi/test.ss
2008-02-24 21:27:36 +00:00

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))]))])))