From 61748bc7fa7c9fab4862bcf333790f5e58d16254 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 original commit: 9b88a732ebebfdcb2229b79c1b5249295ff85c43 --- .../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 8b95397..0e6433e 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