Add support for negated predicates in assert and with-asserts.

typed-racket-doc/typed-racket/scribblings/reference/utilities.scrbl

@@ -13,10 +13,12 @@
 
 Typed Racket provides some additional utility functions to facilitate typed programming.
 
-@defproc*[
-([(assert [v (U #f A)]) A]
- [(assert [v A] [p? (A -> Any : B)]) B])]{
-Verifies that the argument satisfies the constraint.  If no predicate
+@defform*/subs[[(assert val maybe-pred)]
+               ([pred (code:line predicate)
+                      (code:line (not/p pred))]
+                [maybe-pred code:blank
+                            (code:line pred)])]{
+Verifies that the argument satisfies the constraint. If no predicate
 is provided, simply checks that the value is not
 @racket[#f].
 
@@ -30,11 +32,16 @@ x
 (define: y : (U String Symbol) "hello")
 y
 (assert y string?)
-(eval:error (assert y boolean?))]
+(eval:error (assert y boolean?))
+(eval:error (assert y (not/p string?)))
+(assert y (not/p (not/p string?)))
+(assert y (not/p boolean?))]
 
 @defform*/subs[[(with-asserts ([id maybe-pred] ...) body ...+)]
-              ([maybe-pred code:blank
-                           (code:line predicate)])]{
+               ([pred (code:line predicate)
+                      (code:line (not/p pred))]
+                [maybe-pred code:blank
+                            (code:line pred)])]{
 Guard the body with assertions. If any of the assertions fail, the
 program errors. These assertions behave like @racket[assert].
 }

typed-racket-lib/typed-racket/base-env/extra-procs.rkt

@@ -3,21 +3,30 @@
 (provide assert defined?)
 
 (define-syntax (assert stx)
-  (syntax-case stx ()
-    [(assert v)
-     #`(let ([val v])
+  (syntax-case stx (not/p)
+    [(assert v) #'(assert v (not/p not))]
+    [(assert v (not/p (not/p p))) #'(assert v p)]
+    [(assert v (not/p p))
+     #`(let ([val v] [pred p])
          #,(syntax-property
             (syntax/loc stx
-              (or val (error (format "Assertion failed on ~e" val))))
+              (if (pred val)
+                  (raise-arguments-error 'assert
+                   (format "Assertion ~s failed" '(assert v (not/p p)))
+                   "expected" `(not/p ,(or (object-name pred) pred))
+                   "given" val)
+                  val))
             'feature-profile:TR-dynamic-check #t))]
     [(assert v p)
-     #`(let ([val  v]
-             [pred p])
+     #`(let ([val v] [pred p])
          #,(syntax-property
             (quasisyntax/loc stx
               (if (pred val)
                   val
-                  (error (format "Assertion ~e failed on ~e" pred val))))
+                  (raise-arguments-error 'assert
+                   (format "Assertion ~s failed" '(assert v p))
+                   "expected" (or (object-name pred) pred)
+                   "given" val)))
             'feature-profile:TR-dynamic-check #t))]))
 
 (define (defined? v) #t)

typed-racket-lib/typed-racket/base-env/prims.rkt

@@ -729,28 +729,46 @@ the typed racket language.
          [_ rhs]))
      (quasisyntax/loc stx (define #,defined-id #,rhs*))]))
 
-(define-syntax (with-asserts stx)
-  (define-syntax-class with-asserts-clause
-    [pattern [x:id]
-             #:with cond-clause
-             (syntax/loc #'x
-               [(not x)
-                (error "Assertion failed")])]
-    [pattern [x:id pred]
-             #:with cond-clause
-             (syntax/loc #'x
-               [(not (pred x))
-                (error "Assertion failed")])])
-   (syntax-parse stx
-     [(_ (c:with-asserts-clause ...) body:expr ...+)
-      (syntax-property
-       (quasisyntax/loc stx
-         (cond c.cond-clause
-               ...
-               [else #,(syntax-property
-                        #'(begin body ...)
-                        'feature-profile:TR-dynamic-check 'antimark)]))
-       'feature-profile:TR-dynamic-check #t)]))
+(define-syntax with-asserts
+  (let ()
+    (define pred-parser
+      (λ (stx)
+        (syntax-parse stx
+          #:datum-literals (not/p)
+          [(not/p (not/p p)) (pred-parser #'p)]
+          [_ stx])))
+    (define assert-parser
+      (λ (stx)
+        (syntax-parse stx
+          #:datum-literals (not/p)
+          [[x (not/p p)] #'(p x)]
+          [[x p] #'(not (p x))])))
+    (define-syntax-class with-asserts-clause
+      [pattern [x:id]
+               #:with cond-clause
+               (syntax/loc #'x
+                 [(not x)
+                  (raise-arguments-error 'with-asserts
+                   (format "Assertion ~s failed" '(assert x (not/p not))))])]
+      [pattern [x:id p]
+               #:with cond-clause
+               (with-syntax ([p (pred-parser #'p)])
+                 (quasisyntax/loc #'x
+                   [#,(assert-parser #'[x p])
+                    (raise-arguments-error 'with-asserts
+                     (format "Assertion ~s failed" '(assert x p)))]))])
+    (λ (stx)
+      (syntax-parse stx
+        [(_ (c:with-asserts-clause ...) body:expr ...+)
+         (syntax-property
+          (quasisyntax/loc stx
+            (cond c.cond-clause
+                  ...
+                  [else
+                   #,(syntax-property
+                      #'(begin body ...)
+                      'feature-profile:TR-dynamic-check 'antimark)]))
+          'feature-profile:TR-dynamic-check #t)]))))
 
 (define-syntax (typecheck-fail stx)
   (syntax-parse stx

typed-racket-test/fail/with-asserts.rkt

@@ -4,4 +4,4 @@
 
 (let ([x 1] [y "2"])
   (with-asserts ([x string?] [y integer?])
-                x))
+    x))

typed-racket-test/fail/with-asserts2.rkt

@@ -4,4 +4,4 @@
 
 (let ([x 1] [y "2"])
   (with-asserts ([x string?])
-                x))
+    x))

typed-racket-test/fail/with-asserts3.rkt

@@ -4,4 +4,4 @@
 
 (let ([x #f])
   (with-asserts ([x])
-                x))
+    x))

typed-racket-test/fail/with-asserts4.rkt

@@ -0,0 +1,7 @@
+#;
+(exn-pred exn:fail?)
+#lang typed/racket
+
+(let ([x 1] [y "2"])
+  (with-asserts ([x (not/p integer?)] [y integer?])
+    x))

typed-racket-test/fail/with-asserts5.rkt

@@ -0,0 +1,7 @@
+#;
+(exn-pred exn:fail?)
+#lang typed/racket
+
+(let ([x 1] [y "2"])
+  (with-asserts ([y (not/p (not/p integer?))])
+    x))

typed-racket-test/succeed/with-asserts.rkt

@@ -2,19 +2,23 @@
 
 (let ([x 1] [y "2"])
   (with-asserts ([x integer?] [y string?])
-                x))
+    x)
+  (with-asserts ([x (not/p string?)] [y (not/p (not/p string?))])
+    x))
 (let ([x 1] [y "2"])
   (with-asserts ([x integer?])
-                x))
+    x)
+  (with-asserts ([x (not/p (not/p (not/p string?)))])
+    x))
 (let ([x 1] [y "2"])
   (with-asserts ()
-                x))
+    x))
 (let ([x 1] [y "2"])
   (with-asserts ([x])
-                x))
+    x))
 
 (: f : (U Integer String) -> Integer)
 (define (f x)
   (with-asserts ([x integer?])
-                x))
+    x))
 (f 1)