From 9b88a732ebebfdcb2229b79c1b5249295ff85c43 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 17 Nov 2013 18:17:54 -0500 Subject: [PATCH] add check for check-exn predicate closes PR 14165 --- .../rackunit-lib/rackunit/private/check.rkt | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/pkgs/rackunit-pkgs/rackunit-lib/rackunit/private/check.rkt b/pkgs/rackunit-pkgs/rackunit-lib/rackunit/private/check.rkt index 8b9539751e..0e6433e22b 100644 --- a/pkgs/rackunit-pkgs/rackunit-lib/rackunit/private/check.rkt +++ b/pkgs/rackunit-pkgs/rackunit-lib/rackunit/private/check.rkt @@ -211,10 +211,14 @@ (raise-arguments-error name "thunk must be a procedure that accepts 0 arguments" "thunk" thunk))) (define-check (check-exn raw-pred thunk) - (raise-error-if-not-thunk 'check-exn thunk) - (let ([pred (if (regexp? raw-pred) - (λ (x) (and (exn:fail? x) (regexp-match raw-pred (exn-message x)))) - raw-pred)]) + (let ([pred + (cond [(regexp? raw-pred) + (λ (x) (and (exn:fail? x) (regexp-match raw-pred (exn-message x))))] + [(and (procedure? raw-pred) (procedure-arity-includes? raw-pred 1)) + raw-pred] + [else + (raise-argument-error 'check-exn "(-> any/c any/c)" raw-pred)])]) + (raise-error-if-not-thunk 'check-exn thunk) (let/ec succeed (with-handlers (;; catch the exception we are looking for and