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

added blame context information to vector/c and vectorof contracts

Browse Source
This commit is contained in:
Robby Findler 2012-05-13 08:38:31 -05:00
parent f5e3182345
commit dfad46cd7a
2 changed files with 72 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/racket/contract/private/vector.rkt
View File

@ -96,8 +96,8 @@
[immutable (base-vectorof-immutable ctc)]
[check (check-vectorof ctc)])
(λ (blame)
(let ([elem-pos-proj ((contract-projection elem-ctc) blame)]
[elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))])
(let ([elem-pos-proj ((contract-projection elem-ctc) (blame-add-context blame "an element of"))]
[elem-neg-proj ((contract-projection elem-ctc) (blame-add-context blame "an element of" #:swap? #t))])
(define checked-ref (λ (vec i val) (elem-pos-proj val)))
(define checked-set (λ (vec i val) (elem-neg-proj val)))
(define raise-blame (λ (val . args)
@ -229,11 +229,12 @@
#:projection
(λ (ctc)
(λ (blame)
(define blame+ctxt (blame-add-context blame "an element of"))
(λ (val)
(check-vector/c ctc val blame)
(for ([e (in-vector val)]
[c (in-list (base-vector/c-elems ctc))])
(((contract-projection c) blame) e))
(((contract-projection c) blame+ctxt) e))
val)))))
(define (vector/c-ho-projection vector-wrapper)
@ -241,10 +242,16 @@
(let ([elem-ctcs (base-vector/c-elems ctc)]
[immutable (base-vector/c-immutable ctc)])
(λ (blame)
(let ([elem-pos-projs (apply vector-immutable
(map (λ (c) ((contract-projection c) blame)) elem-ctcs))]
[elem-neg-projs (apply vector-immutable
(map (λ (c) ((contract-projection c) (blame-swap blame))) elem-ctcs))])
(let ([elem-pos-projs (for/vector #:length (length elem-ctcs)
([c (in-list elem-ctcs)]
[i (in-naturals)])
((contract-projection c)
(blame-add-context blame (format "the ~a element of" (n->th i)))))]
[elem-neg-projs (for/vector #:length (length elem-ctcs)
([c (in-list elem-ctcs)]
[i (in-naturals)])
((contract-projection c)
(blame-add-context blame (format "the ~a element of" (n->th i)) #:swap? #t)))])
(λ (val)
(check-vector/c ctc val blame)
(if (immutable? val)

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

@ -12664,13 +12664,65 @@ so that propagation occurs.
'pos
'neg)))
#;
(ctest '("an element of" "the 3rd element of")
(ctest '("an element of" "the 2nd element of")
extract-context-lines
(λ () (contract (vector/c (vectorof real?) (vectorof number?) (vectorof boolean?))
(vector (vector 1) (vector 1) (vector 1))
'pos
'neg)))
(λ () (vector-ref
(vector-ref
(contract (vector/c (vectorof real?) (vectorof number?) (vectorof boolean?))
(vector (vector 1) (vector 1) (vector 1))
'pos
'neg)
2)
0)))
(ctest '("the 0th element of")
extract-context-lines
(λ () (vector-ref (contract (vector/c integer?)
(vector #f)
'pos
'neg)
0)))
(ctest '("the 0th element of")
extract-context-lines
(λ () (vector-ref (contract (vector/c (-> integer? integer?))
(vector #f)
'pos
'neg)
0)))
(ctest '("the 0th element of")
extract-context-lines
(λ () (vector-ref (contract (vector/c (new-∀/c 'α))
(vector #f)
'pos
'neg)
0)))
(ctest '("an element of")
extract-context-lines
(λ () (vector-ref
(contract (vectorof integer?)
(vector #f)
'pos
'neg)
0)))
(ctest '("an element of")
extract-context-lines
(λ () (vector-ref (contract (vectorof (-> integer? integer?))
(vector #f)
'pos
'neg)
0)))
(ctest '("an element of")
extract-context-lines
(λ () (vector-ref (contract (vectorof (new-∀/c 'α))
(vector #f)
'pos
'neg)
0)))
;
;