add option for testing errors and non-exception raised values with a predicate

svn: r14141

collects/tests/eli-tester.ss

@@ -7,17 +7,25 @@
   (syntax-case stx ()
     [(_ expr)
      ;; catch syntax errors while expanding, turn them into runtime errors
-     (with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e)))])
+     (with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e) #,e))])
        (define-values (_ opaque)
          (syntax-local-expand-expression
-          #'(with-handlers ([exn? (lambda (e) (list 'error (exn-message e)))])
+          #'(with-handlers
+                ([(lambda (_) #t)
+                  (lambda (e) (list 'error (and (exn? e) (exn-message e)) e))])
               (cons 'values (call-with-values (lambda () expr) list)))))
        opaque)]))
 
 (define show
-  (match-lambda [(list 'error msg) (format "error: ~a" msg)]
+  (match-lambda
     [(list 'values x)        (format "~e" x)]
-                [(list 'values xs ...) (format "~e" (cons 'values xs))]))
+    [(list 'values xs ...)   (format "~e" (cons 'values xs))]
+    [(list 'error err val)
+     (cond [(procedure? err) (format "error satisfying ~s" err)]
+           [(regexp? err)    (format "error matching ~s" err)]
+           [err              (format "error: ~a" err)]
+           [else             (format "a raised non-exception ~s" val)])]
+    [x (format "INTERNAL ERROR, unexpected value: ~s" x)]))
 
 (define test-context    (make-parameter #f))
 (define failure-message (make-parameter #f))
@@ -41,17 +49,36 @@
     #`(let ([x (safe #,x)])
         (unless (and (eq? 'values (car x)) (= 2 (length x)) (cadr x))
           #,(blame x "expected non-#f single value; got: ~a" #'(show x)))))
-  (define (t2 x y)
+  (define (t2 x y [eval2? #t])
-    #`(let ([x (safe #,x)] [y (safe #,y)])
+    #`(let* ([x (safe #,x)]                   [xtag (car x)]
-        (cond [(and (eq? 'values (car x)) (eq? 'error (car y)))
+             [y #,(if eval2? #`(safe #,y) y)] [ytag (car y)])
+        (cond
+          [(eq? ytag 'values)
+           (unless (equal? x y)
+             #,(blame x "expected ~a; got: ~a" #'(show y) #'(show x)))]
+          [(eq? xtag 'values)
            #,(blame x "expected an error; got ~a" #'(show x))]
-              [(and (eq? 'error (car x)) (eq? 'error (car y)))
+          ;; both are errors (or other raised values)
-               (unless (regexp-match? (regexp-quote (cadr y)) (cadr x))
+          [(not (cadr x)) ; expecting a non-exception raise
+           (unless (or (equal? x y)
+                       (and (procedure? (cadr y)) ((cadr y) (caddr x))))
+             #,(blame x "expected ~a; got ~a" #'(show y) #'(show x)))]
+          [else
+           (let ([xerr (cadr x)] [xval (caddr x)] [yerr (cadr y)])
+             (cond [(string? yerr)
+                    (unless (regexp-match? (regexp-quote yerr) xerr)
                       #,(blame x "bad error message, expected ~s; got ~s"
-                          #'(cadr y) #'(cadr x)))]
+                               #'yerr #'xerr))]
-              [(not (equal? x y))
+                   [(regexp? yerr)
-               #,(blame x "expected ~a; got: ~a" #'(show y) #'(show x))])))
+                    (unless (regexp-match? yerr xerr)
-  (define (te x y) (t2 x #`(error #,y)))
+                      #,(blame x "bad error message, expected ~a ~s; got ~s"
+                               "a match for" #'yerr #'xerr))]
+                   [(and (procedure? yerr) (procedure-arity-includes? yerr 1))
+                    (unless (yerr xval)
+                      #,(blame x "bad error message, expected ~a ~s; got ~s"
+                               "an exception satisfying" #'yerr #'xerr))]
+                   [else (error 'test "bad error specification: ~e" yerr)]))])))
+  (define (te x y) (t2 x #`(list 'error #,y #f) #f))
   (define (try t . args)
     #`(let ([c (test-context)])
         (with-handlers ([exn? (lambda (e) (set-mcdr! c (cons e (mcdr c))))])
@@ -133,11 +160,22 @@
  ;; 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)))
+ (+ 1 "2")   =error> #rx"expects.*<number>"
+ (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"
  (test* 1 =error> "") =error> "expected an error"
  (test* (/ 0) =error> "zzz") =error> "bad error message"
+ (test* (raise 1) =error> "foo") =error> "raised non-exception"
+ (test* #:failure-message "FOO" (/ 0) => 1) =error> "FOO"
+ (test* #:failure-message "FOO" (/ 0)) =error> "FOO"
  )
 
 ;; SchemeUnit stuff