Compile time check implementation

rackunit-doc/rackunit/scribblings/check.scrbl

@@ -189,6 +189,24 @@ the check fails.
 
 }
 
+@defform[(check-compile-time-exn (exn-predicate (or/c (-> any/c any/c) regexp?))
+                    (expr (-> any)))
+         void?]{
+
+Similar to @racket[check-exn], but checks that an expression, @racket[expr],
+raises a runtime or compile time exception and that either @racket[exn-predicate] 
+returns a true value if it is a function, or that it matches the 
+message in the exception if  @racket[exn-predicate] is a regexp. 
+In the latter case, the exception raised must be an @racket[exn:fail?].
+}
+
+@defform[(check-compile-time-exn (expr (-> any)))
+         void?]{
+
+Similar to @racket[check-not-exn], but checks that an expression, @racket[expr],
+does not raise a runtime or compile time exception.
+}
+
 @defproc[(check-regexp-match (regexp regexp?)
                              (string string?))
          void?]{

rackunit-lib/rackunit/private/check.rkt

@@ -7,6 +7,7 @@
          racket/match
          rackunit/log
          syntax/parse/define
+         syntax/macro-testing
          "base.rkt"
          "equal-within.rkt"
          "check-info.rkt"
@@ -29,6 +30,8 @@
          check
          check-exn
          check-not-exn
+         check-compile-time-exn
+         check-not-compile-time-exn
          check-true
          check-false
          check-pred
@@ -147,14 +150,16 @@
                (procedure-arity-includes? thunk 0))
     (raise-arguments-error name "thunk must be a procedure that accepts 0 arguments" "thunk" thunk)))
 
+(define (get-pred raw-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 "(or/c (-> any/c any/c) regexp?)" raw-pred)]))
+
 (define-check (check-exn raw-pred thunk)
-  (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 "(or/c (-> any/c any/c) regexp?)" raw-pred)])])
+  (let ([pred (get-pred raw-pred)])
     (raise-error-if-not-thunk 'check-exn thunk)
     (let/ec succeed
       (with-handlers
@@ -196,6 +201,48 @@
            (lambda () (fail-check))))])
     (thunk)))
 
+(define-syntax (check-compile-time-exn stx)
+  (syntax-parse stx
+    [(_ raw-pred expr:expr)
+     #:with loc (datum->syntax #f 'loc stx)
+     #'(let ([pred (get-pred raw-pred)]
+             [location (syntax->location #'loc)])
+         (with-check-info (['name 'check-compile-time-exn]
+                           ['location location]
+                           ['params (list raw-pred (syntax->datum #'expr))])
+           (let/ec finish
+             (with-check-info (['message "Wrong exception raised"])
+               (with-handlers
+                   ([pred
+                     (lambda (exn) (finish))]
+                    [exn:fail?
+                     (lambda (exn)
+                       (with-check-info (['exn exn])
+                         (fail)
+                         (finish)))])
+                 (convert-compile-time-error expr)))
+             (with-check-info (['message "No exception raised"])
+               (fail)))))]))
+
+(define-syntax (check-not-compile-time-exn stx)
+  (syntax-parse stx
+    [(_ expr:expr)
+     #:with loc (datum->syntax #f 'loc stx)
+     #'(let ([location (syntax->location #'loc)])
+         (with-check-info (['name 'check-compile-time-exn]
+                           ['location location]
+                           ['params (list (syntax->datum #'expr))])
+           (let/ec finish
+             (with-check-info (['message "Exception raised"])
+               (with-handlers
+                   ([exn:fail?
+                     (lambda (exn)
+                       (with-check-info (['exn exn])
+                         (fail)
+                         (finish)))])
+                 (convert-compile-time-error expr)))
+             (finish))))]))
+
 (define-syntax-rule (define-simple-check-values [header body ...] ...)
   (begin (define-simple-check header body ...) ...))
 

rackunit-test/tests/rackunit/check-test.rkt

@@ -34,7 +34,8 @@
          rackunit
          rackunit/private/check
          rackunit/private/result
-         rackunit/private/test-suite)
+         rackunit/private/test-suite
+         syntax/macro-testing)
 
 (define (make-failure-test name pred . args)
   (test-case
@@ -434,6 +435,45 @@
                (lambda ()
                  (check-not-exn (lambda (x) x)))))
 
+  ;; Verify compile time exceptions are now
+  ;; supported by check-compile-time-exn and
+  ;; check-not-compile-time-exn
+  (test-case
+      "check-compile-time-exn converts compile time exceptions to runtime phase"
+    (check-compile-time-exn exn:fail:syntax?
+                            (lambda ()
+                              (if 1 2))))
+
+  (test-case "check-compile-time-exn should not evaluate its body"
+    (define evaluated? (box #f))
+    (check-compile-time-exn exn:fail?
+      (lambda ()
+        (set-box! evaluated? #t)
+        (define kaboom)))
+    (check-false (unbox evaluated?)))
+
+  (test-case "check-compile-time-exn expression do not need to be thunks"
+    (check-compile-time-exn exn:fail? (define)))
+
+  (test-case "check-compile-time-exn accepts regular expression"
+    (check-compile-time-exn #rx"missing an \"else\" expression" (if 1 2)))
+
+  (test-case
+      "check-not-compile-time-exn does not call any compile time exceptions when none are provided"
+    (check-not-compile-time-exn (lambda ()
+                                  (if 1 2 3))))
+
+  (test-case "check-not-compile-time-exn should not evaluate its body"
+    (define evaluated? (box #f))
+    (check-not-compile-time-exn
+      (lambda ()
+        (set-box! evaluated? #t)
+        (define kaboom 7)))
+    (check-false (unbox evaluated?)))
+
+  (test-case "check-not-compile-time-exn expression do not need to be thunks"
+    (check-compile-time-exn exn:fail? (define 7)))
+
   ;; Regression test
   ;; Uses of check (and derived forms) used to be un-compilable!
   ;; We check that (write (compile --code-using-check--)) works.