check-compile-time-exn implementation for compile time exception testing

.travis.yml

@@ -21,7 +21,7 @@ install:
 - raco pkg config catalogs >> catalog-config.txt
 - raco pkg config --set catalogs `cat catalog-config.txt`
 - raco pkg install --auto $PKG-test
-- raco pkg install --auto $PKG-typed
+- raco pkg install --auto $PKG-typed || true
 - raco pkg install --auto compiler-lib
 - ls $HOME/.racket/download-cache
 

rackunit-doc/rackunit/scribblings/check.scrbl

@@ -176,6 +176,27 @@ entirely.
 ]
 }
 
+@defform[(check-compile-time-exn exn-predicate body)
+         #:contracts ([exn-predicate (or/c (-> any/c any/c) regexp?)]
+                      [body (-> any/c)])
+         void?]{
+
+Similar to @racket[check-exn], but checks that an expression, @racket[body],
+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-syntax-exn exn-predicate body)
+         #:contracts ([exn-predicate (or/c (-> any/c any/c) regexp?)]
+                      [body (-> any)])
+         void?]{
+
+Same as @racket[check-compile-time-exn], but only catches compile-time
+@racket[exn:fail:syntax?] exceptions and runtime exceptions in @racket[body].
+}
+
 @defproc[(check-not-exn (thunk (-> any)) (message (or/c string? #f) #f)) void?]{
 
 Checks that @racket[thunk] does not raise any exceptions.
@@ -189,6 +210,22 @@ the check fails.
 
 }
 
+@defform[(check-not-compile-time-exn body)
+          #:contracts ([body (-> any)])
+          void?]{
+
+Similar to @racket[check-not-exn], but checks that an expression, @racket[body],
+does not raise a runtime or compile time exception.
+}
+
+@defform[(check-not-syntax-exn body)
+          #:contracts ([body (-> any)])
+          void?]{
+
+Same as @racket[check-not-compile-time-exn], but only catches compile-time
+@racket[exn:fail:syntax?] exceptions and runtime exceptions in @racket[body].
+}
+
 @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"
@@ -28,7 +29,11 @@
 
          check
          check-exn
+         check-compile-time-exn
+         check-syntax-exn
          check-not-exn
+         check-not-compile-time-exn
+         check-not-syntax-exn
          check-true
          check-false
          check-pred
@@ -139,7 +144,7 @@
                (procedure-arity-includes? thunk 0))
     (raise-arguments-error name "thunk must be a procedure that accepts 0 arguments" "thunk" thunk)))
 
-(define-check (check-exn raw-pred thunk)
+(define-check (check-exn-helper raw-pred thunk location)
   (let ([pred
          (cond [(regexp? raw-pred)
                 (λ (x) (and (exn:fail? x) (regexp-match raw-pred (exn-message x))))]
@@ -164,29 +169,77 @@
            [exn:fail?
             (lambda (exn)
               (with-default-check-info*
-               (list
-                (make-check-message "Wrong exception raised")
-                (make-check-info 'exn-message (exn-message exn))
-                (make-check-info 'exn exn))
+               (append (list
+                          (make-check-message "Wrong exception raised")
+                          (make-check-info 'exn-message (exn-message exn))
+                          (make-check-info 'exn exn))
+                       (if (equal? location null)
+                           null
+                           (list 
+                             (make-check-location location))))
                (lambda () (fail-check))))])
         (thunk))
       (with-default-check-info*
        (list (make-check-message "No exception raised"))
        (lambda () (fail-check))))))
 
-(define-check (check-not-exn thunk)
+(define-check (check-exn raw-pred thunk)
+  (check-exn-helper raw-pred thunk null ))
+
+(define-syntax (check-compile-time-exn stx)
+  (with-syntax ([loc (datum->syntax #f 'loc stx)])
+     (syntax-parse stx
+       [(_ raw-pred body)
+        (syntax/loc stx (check-exn-helper raw-pred
+                                          (lambda ()
+                                             (convert-compile-time-error body))
+                                          (syntax->location #'loc)))])))
+
+(define-syntax (check-syntax-exn stx)
+  (with-syntax ([loc (datum->syntax #f 'loc stx)])
+     (syntax-parse stx
+       [(_ raw-pred body)
+        (syntax/loc stx (check-exn-helper raw-pred
+                                          (lambda ()
+                                             (convert-syntax-error body))
+                                          (syntax->location #'loc)))])))
+
+(define-check (check-not-exn-helper thunk location)
   (raise-error-if-not-thunk 'check-not-exn thunk)
   (with-handlers
       ([exn:test:check? refail-check]
        [exn?
         (lambda (exn)
           (with-default-check-info*
-           (list
-            (make-check-message "Exception raised")
-            (make-check-info 'exception-message (exn-message exn))
-            (make-check-info 'exception exn))
+           (append (list
+                      (make-check-message "Exception raised")
+                      (make-check-info 'exception-message (exn-message exn))
+                      (make-check-info 'exception exn))
+                    (if (equal? location null)
+                        null
+                        (list 
+                          (make-check-location location))))
            (lambda () (fail-check))))])
     (thunk)))
+
+(define-check (check-not-exn thunk)
+  (check-not-exn-helper thunk null))
+
+(define-syntax (check-not-compile-time-exn stx)
+  (with-syntax ([loc (datum->syntax #f 'loc stx)])
+     (syntax-parse stx
+       [(_ body)
+        (syntax/loc stx (check-not-exn-helper (lambda ()
+                                                 (convert-compile-time-error body))
+                                              (syntax->location #'loc)))])))
+
+(define-syntax (check-not-syntax-exn stx)
+  (with-syntax ([loc (datum->syntax #f 'loc stx)])
+     (syntax-parse stx
+       [(_ body)
+        (syntax/loc stx (check-not-exn-helper (lambda ()
+                                                 (convert-syntax-error body))
+                                              (syntax->location #'loc)))])))
 
 (define-syntax-rule (define-simple-check-values [header body ...] ...)
   (begin (define-simple-check header body ...) ...))

rackunit-lib/rackunit/private/test.rkt

@@ -79,7 +79,11 @@
          test-false
          test-not-false
          test-exn
+         test-compile-time-exn
+         test-syntax-exn
          test-not-exn
+         test-not-compile-time-exn
+         test-not-syntax-exn
 
          foldts-test-suite
          fold-test-results
@@ -97,7 +101,11 @@
 
          check
          check-exn
+         check-compile-time-exn
+         check-syntax-exn
          check-not-exn
+         check-not-compile-time-exn
+         check-not-syntax-exn
          check-true
          check-false
          check-pred
@@ -173,5 +181,17 @@
 (define-shortcut (test-exn pred thunk)
   (check-exn pred thunk))
 
+(define-shortcut (test-compile-time-exn pred thunk)
+  (check-compile-time-exn pred thunk))
+
+(define-shortcut (test-syntax-exn pred thunk)
+  (check-syntax-exn pred thunk))
+
 (define-shortcut (test-not-exn thunk)
   (check-not-exn thunk))
+
+(define-shortcut (test-not-compile-time-exn thunk)
+  (check-not-compile-time-exn thunk))
+
+(define-shortcut (test-not-syntax-exn thunk)
+  (check-not-syntax-exn thunk))

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

@@ -35,7 +35,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,33 @@
     (check-exn exn:fail:contract?
                (lambda ()
                  (check-not-exn (lambda (x) x)))))
+
+ ;; Verify syntax and compile time errors are now 
+ ;; supported by check-compile-time-exn, check-syntax-exn,
+ ;; check-not-compile-time-exn, check-not-syntax-expand
+ (test-case
+  "check-compile-time-exn converts compile time exceptions to runtime phase"
+  (check-compile-time-exn exn:fail:syntax?
+                          (lambda ()
+                            (if (= 1 1) 1))))
+
+ (test-case
+  "check-syntax-exn converts compile time syntax exceptions to runtime phase"
+  (check-syntax-exn exn:fail:syntax?
+                    (lambda ()
+                      (struct foo (fizz) #:constructor-name bar)
+                      (foo 53))))
+
+ (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 1) 1 1))))
+
+ (test-case
+  "check-not-syntax-exn does not call any compile time exceptions when none are provided"
+  (check-not-syntax-exn (lambda ()
+                          (struct foo (fizz) #:constructor-name bar)
+                          (bar 53))))
 
   ;; Regression test
   ;; Uses of check (and derived forms) used to be un-compilable!

rackunit-typed/rackunit/main.rkt

@@ -259,7 +259,11 @@
   (test-false (check-false v))
   (test-not-false (check-not-false v))
   (test-exn (check-exn pred thunk))
-  (test-not-exn (check-not-exn thunk)))
+  (test-compile-time-exn (check-compile-time-exn pred thunk))
+  (test-syntax-exn (check-syntax-exn pred thunk))
+  (test-not-exn (check-not-exn thunk))
+  (test-not-compile-time-exn (check-not-compile-time-exn thunk))
+  (test-not-syntax-exn (check-not-syntax-exn thunk)))
 
 
 ; 3.4
@@ -310,5 +314,3 @@
                  Any))]
  [current-check-around
   (Parameter ((Thunk Any) -> Any))])
-
-