suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improved the error messages for #:pre and #:post violations in ->i by including the bindings for the variables

Browse Source
This commit is contained in:
Robby Findler 2011-03-26 08:12:30 -05:00
parent 3b4ba31d74
commit f3b0a7454a
2 changed files with 51 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/racket/contract/private/arr-i.rkt
View File

@ -337,32 +337,47 @@
(define-for-syntax (maybe-generate-temporary x) (define-for-syntax (maybe-generate-temporary x)
(and x (car (generate-temporaries (list x))))) (and x (car (generate-temporaries (list x)))))
(define (check-pre bool val str blame) (define (signal-pre/post pre? val str blame . var-infos)
(unless bool (define pre-str (or str
(raise-blame-error blame val (or str "#:pre condition violation")))) (string-append
(if pre? "#:pre" "#:post")
(define (check-post bool val str blame) " condition violation"
(unless bool (if (null? var-infos)
(raise-blame-error blame val (or str "#:post condition violation")))) ""
"; variables are:"))))
(raise-blame-error blame val
(apply
string-append
pre-str
(for/list ([var-info (in-list var-infos)])
(format "\n ~s: ~e"
(list-ref var-info 0)
(list-ref var-info 1))))))
(define-for-syntax (add-pre-cond an-istx arg/res-to-indy-var call-stx) (define-for-syntax (add-pre-cond an-istx arg/res-to-indy-var call-stx)
#`(begin #,@(for/list ([pre (in-list (istx-pre an-istx))] #`(begin #,@(for/list ([pre (in-list (istx-pre an-istx))]
[i (in-naturals)]) [i (in-naturals)])
(define id (string->symbol (format "pre-proc~a" i))) (define id (string->symbol (format "pre-proc~a" i)))
#`(check-pre (#,id #,@(map arg/res-to-indy-var (pre/post-vars pre))) #`(unless (#,id #,@(map arg/res-to-indy-var (pre/post-vars pre)))
(signal-pre/post #t
val val
#,(pre/post-str pre) #,(pre/post-str pre)
swapped-blame)) swapped-blame
#,@(map (λ (x) #`(list '#,x #,(arg/res-to-indy-var x)))
(pre/post-vars pre)))))
#,call-stx)) #,call-stx))
(define-for-syntax (add-post-cond an-istx arg/res-to-indy-var call-stx) (define-for-syntax (add-post-cond an-istx arg/res-to-indy-var call-stx)
#`(begin #,@(for/list ([post (in-list (istx-post an-istx))] #`(begin #,@(for/list ([post (in-list (istx-post an-istx))]
[i (in-naturals)]) [i (in-naturals)])
(define id (string->symbol (format "post-proc~a" i))) (define id (string->symbol (format "post-proc~a" i)))
#`(check-post (#,id #,@(map arg/res-to-indy-var (pre/post-vars post))) #`(unless (#,id #,@(map arg/res-to-indy-var (pre/post-vars post)))
(signal-pre/post #f
val val
#,(pre/post-str post) #,(pre/post-str post)
blame)) blame
#,@(map (λ (x) #`(list '#,x #,(arg/res-to-indy-var x)))
(pre/post-vars post)))))
#,call-stx)) #,call-stx))
;; add-wrapper-let : syntax ;; add-wrapper-let : syntax

21
collects/tests/racket/contract-test.rktl
View File

@ -2901,6 +2901,27 @@
'neg) 'neg)
1)) 1))
;; test to make sure the values are in the error messages
(contract-error-test
#'((contract (->i ([x number?]) #:pre (x) #f any)
(λ (x) x)
'pos
'neg)
123456789)
(λ (x)
(and (exn? x)
(regexp-match #rx"x: 123456789" (exn-message x)))))
(contract-error-test
#'((contract (->i ([|x y| number?]) #:pre (|x y|) #f any)
(λ (x) x)
'pos
'neg)
123456789)
(λ (x)
(and (exn? x)
(regexp-match (regexp-quote "|x y|: 123456789") (exn-message x)))))
(test/neg-blame (test/neg-blame
'->i-protect-shared-state '->i-protect-shared-state
'(let ([x 1]) '(let ([x 1])