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

add context information to hash/c (also, rackety)

Browse Source
This commit is contained in:
Robby Findler 2012-05-14 21:43:28 -05:00
parent 9e7eb963d7
commit 005d3b7218
2 changed files with 55 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
collects/racket/contract/private/hash.rkt
View File

@ -139,7 +139,7 @@
(define-struct (flat-hash/c base-hash/c) ()
#:omit-define-syntaxes
#:property prop:flat-contract
(build-flat-contract-property
#:name hash/c-name
@ -149,11 +149,13 @@
(λ (blame)
(λ (val)
(check-hash/c ctc val blame)
(let ([dom-proj ((contract-projection (base-hash/c-dom ctc)) blame)]
[rng-proj ((contract-projection (base-hash/c-rng ctc)) blame)])
(for ([(k v) (in-hash val)])
(dom-proj k)
(rng-proj v)))
(define dom-proj ((contract-projection (base-hash/c-dom ctc))
(blame-add-context blame "the keys of")))
(define rng-proj ((contract-projection (base-hash/c-rng ctc))
(blame-add-context blame "the values of")))
(for ([(k v) (in-hash val)])
(dom-proj k)
(rng-proj v))
val)))))
(define (ho-projection hash-wrapper)
@ -162,36 +164,36 @@
[rng-proc (contract-projection (base-hash/c-rng ctc))]
[immutable (base-hash/c-immutable ctc)])
(λ (blame)
(let ([pos-dom-proj (dom-proc blame)]
[neg-dom-proj (dom-proc (blame-swap blame))]
[pos-rng-proj (rng-proc blame)]
[neg-rng-proj (rng-proc (blame-swap blame))])
(λ (val)
(check-hash/c ctc val blame)
(if (immutable? val)
(let ([hash-maker
(cond
[(hash-equal? val) make-immutable-hash]
[(hash-eqv? val) make-immutable-hasheqv]
[(hash-eq? val) make-immutable-hasheq])])
(hash-maker
(for/list ([(k v) (in-hash val)])
(cons (pos-dom-proj k)
(pos-rng-proj v)))))
(hash-wrapper
val
(λ (h k)
(values (neg-dom-proj k)
(λ (h k v)
(pos-rng-proj v))))
(λ (h k v)
(values (neg-dom-proj k)
(neg-rng-proj v)))
(λ (h k)
(neg-dom-proj k))
(λ (h k)
(pos-dom-proj k))
impersonator-prop:contracted ctc))))))))
(define pos-dom-proj (dom-proc (blame-add-context blame "the keys of")))
(define neg-dom-proj (dom-proc (blame-add-context blame "the keys of" #:swap? #t)))
(define pos-rng-proj (rng-proc (blame-add-context blame "the values of")))
(define neg-rng-proj (rng-proc (blame-add-context blame "the values of" #:swap? #t)))
(λ (val)
(check-hash/c ctc val blame)
(if (immutable? val)
(let ([hash-maker
(cond
[(hash-equal? val) make-immutable-hash]
[(hash-eqv? val) make-immutable-hasheqv]
[(hash-eq? val) make-immutable-hasheq])])
(hash-maker
(for/list ([(k v) (in-hash val)])
(cons (pos-dom-proj k)
(pos-rng-proj v)))))
(hash-wrapper
val
(λ (h k)
(values (neg-dom-proj k)
(λ (h k v)
(pos-rng-proj v))))
(λ (h k v)
(values (neg-dom-proj k)
(neg-rng-proj v)))
(λ (h k)
(neg-dom-proj k))
(λ (h k)
(pos-dom-proj k))
impersonator-prop:contracted ctc)))))))
(define-struct (chaperone-hash/c base-hash/c) ()
#:omit-define-syntaxes

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

@ -12724,6 +12724,23 @@ so that propagation occurs.
'neg)
0)))
(ctest '("the keys of")
extract-context-lines
(λ () (contract (hash/c integer? (-> integer? integer?))
(hash #f (λ (x) #f))
'pos
'neg)))
(ctest '("the range of" "the values of")
extract-context-lines
(λ () ((hash-ref
(contract (hash/c integer? (-> integer? integer?))
(hash 0 (λ (x) #f))
'pos
'neg)
0)
1)))
;
;
;