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

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

@ -12664,13 +12664,65 @@ so that propagation occurs.
'pos 'pos
'neg))) 'neg)))
#; (ctest '("an element of" "the 2nd element of")
(ctest '("an element of" "the 3rd element of")
extract-context-lines extract-context-lines
(λ () (contract (vector/c (vectorof real?) (vectorof number?) (vectorof boolean?)) (λ () (vector-ref
(vector-ref
(contract (vector/c (vectorof real?) (vectorof number?) (vectorof boolean?))
(vector (vector 1) (vector 1) (vector 1)) (vector (vector 1) (vector 1) (vector 1))
'pos 'pos
'neg))) '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)))
; ;
; ;