diff --git a/typed-racket-doc/typed-racket/scribblings/reference/utilities.scrbl b/typed-racket-doc/typed-racket/scribblings/reference/utilities.scrbl index 1a1806442..07cd7fae7 100644 --- a/typed-racket-doc/typed-racket/scribblings/reference/utilities.scrbl +++ b/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]. } diff --git a/typed-racket-lib/typed-racket/base-env/extra-procs.rkt b/typed-racket-lib/typed-racket/base-env/extra-procs.rkt index 621677d71..9d6d63c8a 100644 --- a/typed-racket-lib/typed-racket/base-env/extra-procs.rkt +++ b/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) diff --git a/typed-racket-lib/typed-racket/base-env/prims.rkt b/typed-racket-lib/typed-racket/base-env/prims.rkt index 2a26ad6c4..ded7f74f7 100644 --- a/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -729,28 +729,44 @@ 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 + (syntax-parser + #: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 diff --git a/typed-racket-test/fail/with-asserts.rkt b/typed-racket-test/fail/with-asserts.rkt index b543f7b91..62f91e820 100644 --- a/typed-racket-test/fail/with-asserts.rkt +++ b/typed-racket-test/fail/with-asserts.rkt @@ -4,4 +4,4 @@ (let ([x 1] [y "2"]) (with-asserts ([x string?] [y integer?]) - x)) + x)) diff --git a/typed-racket-test/fail/with-asserts2.rkt b/typed-racket-test/fail/with-asserts2.rkt index 79ec314a9..2af4dee71 100644 --- a/typed-racket-test/fail/with-asserts2.rkt +++ b/typed-racket-test/fail/with-asserts2.rkt @@ -4,4 +4,4 @@ (let ([x 1] [y "2"]) (with-asserts ([x string?]) - x)) + x)) diff --git a/typed-racket-test/fail/with-asserts3.rkt b/typed-racket-test/fail/with-asserts3.rkt index f38cb1e68..0d8a7d3f1 100644 --- a/typed-racket-test/fail/with-asserts3.rkt +++ b/typed-racket-test/fail/with-asserts3.rkt @@ -4,4 +4,4 @@ (let ([x #f]) (with-asserts ([x]) - x)) + x)) diff --git a/typed-racket-test/fail/with-asserts4.rkt b/typed-racket-test/fail/with-asserts4.rkt new file mode 100644 index 000000000..d75a83a5e --- /dev/null +++ b/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)) diff --git a/typed-racket-test/fail/with-asserts5.rkt b/typed-racket-test/fail/with-asserts5.rkt new file mode 100644 index 000000000..a0b642ee6 --- /dev/null +++ b/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)) diff --git a/typed-racket-test/succeed/with-asserts.rkt b/typed-racket-test/succeed/with-asserts.rkt index c6dc9b321..1f502aff7 100644 --- a/typed-racket-test/succeed/with-asserts.rkt +++ b/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)