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

Add new argument to apply-contract/make-blame for the "user" blame label.

Browse Source 
The new blame label gives us the location of the "use" of the value.
This blame label describes the location where we actually did the
contract wrapping, which may differ from the negative blame label.
This commit is contained in:
Stevie Strickland 2010-04-29 12:01:53 -04:00
parent 2dfe132862
commit 484be3cf02
3 changed files with 16 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/racket/contract/private/base.rkt
View File

@ -27,21 +27,21 @@ improve method arity mismatch contract violation error messages?
(syntax-case stx ()
[(_ c v pos neg name loc)
(syntax/loc stx
(apply-contract c v pos neg name loc))]
(apply-contract c v pos neg name loc (current-contract-region)))]
[(_ c v pos neg)
(syntax/loc stx
(apply-contract c v pos neg #f (build-source-location #f)))]
(apply-contract c v pos neg #f (build-source-location #f) (current-contract-region)))]
[(_ c v pos neg src)
(raise-syntax-error 'contract
(string-append
"please update contract application to new protocol "
"(either 4 or 6 arguments)"))]))
(define (apply-contract c v pos neg name loc)
(define (apply-contract c v pos neg name loc usr)
(let* ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc)
(((contract-projection c)
(make-blame loc name (contract-name c) pos neg #t))
(make-blame loc name (contract-name c) pos neg usr #t))
v)))
(define-syntax (recursive-contract stx)

11
collects/racket/contract/private/blame.rkt
View File

@ -34,7 +34,7 @@
(hash/recur (blame-original? b))))
(define-struct blame
[source value contract positive negative original?]
[source value contract positive negative user original?]
#:property prop:equal+hash
(list blame=? blame-hash blame-hash))
@ -64,12 +64,17 @@
[contract-message (show/write (blame-contract b))]
[value-message (if (blame-value b)
(format " on ~a" (show/display (blame-value b)))
"")])
(format "~a~a broke the contract ~a~a; ~a"
"")]
[user-message (if (or (blame-original? b)
(equal? (blame-positive b) (blame-user b)))
""
(format " given to ~a" (show/display (blame-user b))))])
(format "~a~a broke the contract ~a~a~a; ~a"
source-message
positive-message
contract-message
value-message
user-message
custom-message)))
(define ((show f) v)

6
collects/racket/contract/private/legacy.rkt
View File

@ -21,7 +21,8 @@
name
(unpack-blame pos)
"<<unknown party>>"
#t)
#t
name)
x
fmt
args))
@ -58,7 +59,8 @@
name
(unpack-blame (if original? pos neg))
(unpack-blame (if original? neg pos))
original?)))))
original?
name)))))
(define (legacy-property name)
(define-values [ prop pred get ]