failure-prefix form and failure-format parameter in eli-tester
This commit is contained in:
Jay McCarthy
parent
f4b07e9640
commit
94a6aac517
|
|
@ -28,7 +28,28 @@
|
|||
[x (format "INTERNAL ERROR, unexpected value: ~s" x)]))
|
||||
|
||||
(define test-context (make-parameter #f))
|
||||
(define failure-message (make-parameter #f))
|
||||
(define failure-format
|
||||
(make-parameter
|
||||
(lambda (prefix qe fmt . args)
|
||||
(define prefix-str
|
||||
(apply string-append
|
||||
(add-between (reverse (list* "" prefix))
|
||||
" > ")))
|
||||
(define str
|
||||
(regexp-replace #rx"\n"
|
||||
(apply format fmt args)
|
||||
"\n "))
|
||||
(format "~atest failure in ~e\n ~a"
|
||||
prefix-str qe str))))
|
||||
|
||||
(define (make-failure-message msg)
|
||||
(define str
|
||||
(regexp-replace #rx"\n" msg "\n "))
|
||||
(define real-msg
|
||||
(format "test failure\n ~a" str))
|
||||
(lambda (prefix qe fmt . args)
|
||||
real-msg))
|
||||
(define failure-prefix-mark (gensym 'failure-prefix))
|
||||
|
||||
(define-syntax (test-thunk stx)
|
||||
(define (blame e fmt . args)
|
||||
|
|
@ -41,13 +62,10 @@
|
|||
[(syntax-position e) => (lambda (p) (format "#~a" p))]
|
||||
[else "?"])))))
|
||||
(with-syntax ([e e] [fmt fmt] [(arg ...) args] [loc loc])
|
||||
#'(let* ([msg (failure-message)]
|
||||
[str (regexp-replace #rx"\n"
|
||||
(if msg (msg) (format fmt arg ...))
|
||||
"\n ")])
|
||||
(if msg
|
||||
(error 'loc "test failure\n ~a" str)
|
||||
(error 'loc "test failure in ~e\n ~a" 'e str)))))
|
||||
#'(let* ([form (failure-format)]
|
||||
[prefix
|
||||
(continuation-mark-set->list (current-continuation-marks) failure-prefix-mark)])
|
||||
(error 'loc (form prefix 'e fmt arg ...)))))
|
||||
(define (t1 x)
|
||||
#`(let ([x (safe #,x)])
|
||||
(unless (and (eq? 'values (car x)) (= 2 (length x)) (cadr x))
|
||||
|
|
@ -55,7 +73,7 @@
|
|||
#'(show x)))))
|
||||
(define (t2 x y [eval2? #t])
|
||||
#`(let* ([x (safe #,x)] [xtag (car x)]
|
||||
[y #,(if eval2? #`(safe #,y) y)] [ytag (car y)])
|
||||
[y #,(if eval2? #`(safe #,y) y)] [ytag (car y)])
|
||||
(cond
|
||||
[(eq? ytag 'values)
|
||||
(unless (equal? x y)
|
||||
|
|
@ -93,19 +111,26 @@
|
|||
(let ([e (syntax-e x)])
|
||||
(if (or (memq e '(do => <= =error> <error=))
|
||||
(keyword? e))
|
||||
e x)))
|
||||
e x)))
|
||||
(cdr (syntax->list stx)))]
|
||||
[r '()])
|
||||
(let ([t (let tloop ([xs xs])
|
||||
(match xs
|
||||
[(list* #:failure-prefix msg r)
|
||||
(let ([r (tloop r)])
|
||||
(if (pair? r)
|
||||
(cons
|
||||
#`(with-continuation-mark failure-prefix-mark #,msg #,(car r))
|
||||
(cdr r))
|
||||
r))]
|
||||
[(list* #:failure-message msg r)
|
||||
(let ([r (tloop r)])
|
||||
(if (pair? r)
|
||||
(cons
|
||||
#`(parameterize ([failure-message (lambda () #,msg)])
|
||||
#,(car r))
|
||||
(cdr r))
|
||||
r))]
|
||||
(cons
|
||||
#`(parameterize ([failure-format (make-failure-message #,msg)])
|
||||
#,(car r))
|
||||
(cdr r))
|
||||
r))]
|
||||
[(list* 'do x r) ; to avoid counting non-test exprs as tests
|
||||
(cons (tb x) r)]
|
||||
[(list* x '=> y r) (cons (try t2 x y) r)]
|
||||
|
|
@ -120,26 +145,26 @@
|
|||
[_ (cons (try t1 x) r)])]
|
||||
[(list) '()]))])
|
||||
(if (pair? t)
|
||||
(loop (cdr t) (cons (car t) r))
|
||||
#`(lambda () #,@(reverse r))))))
|
||||
(loop (cdr t) (cons (car t) r))
|
||||
#`(lambda () #,@(reverse r))))))
|
||||
|
||||
(define (run-tests thunk force-new-context?)
|
||||
(if (and (test-context) (not force-new-context?))
|
||||
(thunk)
|
||||
(let ([c (mcons 0 '())])
|
||||
(parameterize ([test-context c])
|
||||
(dynamic-wind
|
||||
void
|
||||
thunk
|
||||
(lambda ()
|
||||
(test-context #f)
|
||||
(let ([num (mcar c)] [exns (mcdr c)])
|
||||
(if (null? exns)
|
||||
(printf "~a test~a passed\n" num (if (= num 1) "" "s"))
|
||||
(error 'test "~a/~a test failures:~a" (length exns) num
|
||||
(string-append*
|
||||
(append-map (lambda (e) (list "\n" (exn-message e)))
|
||||
(reverse exns))))))))))))
|
||||
(thunk)
|
||||
(let ([c (mcons 0 '())])
|
||||
(parameterize ([test-context c])
|
||||
(dynamic-wind
|
||||
void
|
||||
thunk
|
||||
(lambda ()
|
||||
(test-context #f)
|
||||
(let ([num (mcar c)] [exns (mcdr c)])
|
||||
(if (null? exns)
|
||||
(printf "~a test~a passed\n" num (if (= num 1) "" "s"))
|
||||
(error 'test "~a/~a test failures:~a" (length exns) num
|
||||
(string-append*
|
||||
(append-map (lambda (e) (list "\n" (exn-message e)))
|
||||
(reverse exns))))))))))))
|
||||
|
||||
(provide test test*)
|
||||
(define-syntax-rule (test x0 x ...) (run-tests (test-thunk x0 x ...) #f))
|
||||
|
|
@ -163,7 +188,7 @@
|
|||
(car '()) => (error "expects argument of type")
|
||||
;; syntax errors
|
||||
(if 1) =error> "if: bad syntax"
|
||||
|
||||
|
||||
;; error (and non-exception raises) predicates
|
||||
(+ 1 "2") =error> exn:fail:contract?
|
||||
(+ 1 "2") =error> (lambda (x) (not (exn:fail:filesystem? x)))
|
||||
|
|
@ -171,7 +196,7 @@
|
|||
(error "1") =error> exn?
|
||||
(raise 1) =error> number?
|
||||
(raise "1") =error> string?
|
||||
|
||||
|
||||
;; test `test' errors
|
||||
(test* (/ 0)) =error> "expected: non-#f single value"
|
||||
(test* 1 => 2) =error> "expected: 2"
|
||||
|
|
@ -180,7 +205,8 @@
|
|||
(test* (raise 1) =error> "foo") =error> "raised non-exception"
|
||||
(test* #:failure-message "FOO" (/ 0) => 1) =error> "FOO"
|
||||
(test* #:failure-message "FOO" (/ 0)) =error> "FOO"
|
||||
|
||||
(test* #:failure-prefix "FOO" (/ 0)) =error> "FOO"
|
||||
|
||||
;; test possitive message
|
||||
(let ([o (open-output-bytes)])
|
||||
(list (begin (parameterize ([current-output-port o]) (test* 1 => 1))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user