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

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

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

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

@ -12724,6 +12724,23 @@ so that propagation occurs.
'neg) 'neg)
0))) 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)))
; ;
; ;
; ;