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

Add chaperone-based hash/c contracts.

Browse Source 
* Domain contracts must be either flat or chaperone contracts.
 * When the domain is a chaperone contract, hash/c must check
   that the hash is equal?-based.
This commit is contained in:
Stevie Strickland 2010-05-12 15:24:47 -04:00
parent d2b3ee8892
commit 56b83e4a96
2 changed files with 126 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -13,12 +13,18 @@
[rng-ctc (if flat?
(coerce-flat-contract 'hash/c rng)
(coerce-contract 'hash/c rng))])
(if (or flat?
(and (eq? immutable #t)
(flat-contract? dom-ctc)
(flat-contract? rng-ctc)))
(make-flat-hash/c dom-ctc rng-ctc immutable)
(make-ho-hash/c dom-ctc rng-ctc immutable))))
(unless (chaperone-contract? dom-ctc)
(error 'hash/c "expected either a flat or chaperone contract for the domain, got ~s" (contract-name dom-ctc)))
(cond
[(or flat?
(and (eq? immutable #t)
(flat-contract? dom-ctc)
(flat-contract? rng-ctc)))
(make-flat-hash/c dom-ctc rng-ctc immutable)]
[(chaperone-contract? rng-ctc)
(make-chaperone-hash/c dom-ctc rng-ctc immutable)]
[else
(make-proxy-hash/c dom-ctc rng-ctc immutable)])))
(define (hash/c-first-order ctc)
(let ([dom-ctc (hash/c-dom ctc)]
@ -33,6 +39,10 @@
(return #f)))
(unless (hash? val)
(fail "expected a hash, got ~a" val))
(when (and (not flat?)
(not (flat-contract? dom-ctc))
(not (hash-equal? val)))
(fail "expected equal?-based hash table due to higher-order domain contract, got ~a" val))
(case immutable
[(#t)
(unless (immutable? val)
@ -85,7 +95,55 @@
((hash/c-first-order ctc) val #:blame blame)
val)))))
(define-struct (ho-hash/c hash/c) ()
(define (ho-projection hash-wrapper)
(λ (ctc)
(let ([dom-proc (contract-projection (hash/c-dom ctc))]
[rng-proc (contract-projection (hash/c-rng ctc))]
[immutable (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)
((hash/c-first-order ctc) val #:blame 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))))))))))
(define-struct (chaperone-hash/c hash/c) ()
#:omit-define-syntaxes
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:name hash/c-name
#:first-order hash/c-first-order
#:projection
(ho-projection chaperone-hash)))
(define-struct (proxy-hash/c hash/c) ()
#:omit-define-syntaxes
#:property prop:contract
@ -94,38 +152,4 @@
#:first-order hash/c-first-order
#:projection
(λ (ctc)
(let ([dom-proc (contract-projection (hash/c-dom ctc))]
[rng-proc (contract-projection (hash/c-rng ctc))]
[immutable (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)
((hash/c-first-order ctc) val #:blame 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)))))
(proxy-hash
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)))))))))))
(ho-projection proxy-hash)))

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

@ -3666,6 +3666,31 @@
'x)
1)
(test/pos-blame
'hash/c13a
'(contract (hash/c (hash/c number? number?) number?)
(make-hasheq)
'pos
'neg))
(test/pos-blame
'hash/c13b
'(contract (hash/c (hash/c number? number?) number?)
(make-hasheq)
'pos
'neg))
(test/neg-blame
'hash/c13c
'(let ([h (contract (hash/c (hash/c number? number?) number?)
(make-hash)
'pos
'neg)])
(hash-set! h (make-hash '((2 . 3))) 2)
(hash-set! h (make-hash '((3 . #t))) 3)
(for ([(k v) (in-hash h)])
(hash-ref k v))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; make-contract
@ -8821,23 +8846,45 @@ so that propagation occurs.
(define-struct s (a b))
(struct/c s any/c any/c)))
(ctest #t contract? (hash/c any/c any/c #:immutable #f))
(ctest #t flat-contract? (hash/c any/c any/c #:immutable #f #:flat? #t))
;; Hash contracts with flat domain/range contracts
(ctest #t contract? (hash/c any/c any/c #:immutable #f))
(ctest #t chaperone-contract? (hash/c any/c any/c #:immutable #f))
(ctest #t flat-contract? (hash/c any/c any/c #:immutable #f #:flat? #t))
(ctest #t flat-contract? (hash/c any/c any/c #:immutable #t))
(ctest #t flat-contract? (hash/c any/c any/c #:immutable #t #:flat? #t))
(ctest #t flat-contract? (hash/c any/c any/c #:immutable #t))
(ctest #t flat-contract? (hash/c any/c any/c #:immutable #t #:flat? #t))
(ctest #t contract? (hash/c any/c any/c))
(ctest #t flat-contract? (hash/c any/c any/c #:flat? #t))
(ctest #t contract? (hash/c any/c any/c))
(ctest #t chaperone-contract? (hash/c any/c any/c))
(ctest #t flat-contract? (hash/c any/c any/c #:flat? #t))
(ctest #t contract? (hash/c number? (-> number? number?) #:immutable #f))
(ctest #f flat-contract? (hash/c number? (-> number? number?) #:immutable #f))
;; Hash contracts with chaperone range contracts
(ctest #t contract? (hash/c number? (hash/c number? number?)))
(ctest #t chaperone-contract? (hash/c number? (hash/c number? number?)))
(ctest #f flat-contract? (hash/c number? (hash/c number? number?)))
(ctest #t contract? (hash/c number? (-> number? number?) #:immutable #t))
(ctest #f flat-contract? (hash/c number? (-> number? number?) #:immutable #t))
;; Hash contracts with proxy range contracts
(ctest #t contract? (hash/c number? (-> number? number?) #:immutable #f))
(ctest #f chaperone-contract? (hash/c number? (-> number? number?) #:immutable #f))
(ctest #f flat-contract? (hash/c number? (-> number? number?) #:immutable #f))
(ctest #t contract? (hash/c number? (-> number? number?)))
(ctest #f flat-contract? (hash/c number? (-> number? number?)))
(ctest #t contract? (hash/c number? (-> number? number?) #:immutable #t))
(ctest #f chaperone-contract? (hash/c number? (-> number? number?) #:immutable #t))
(ctest #f flat-contract? (hash/c number? (-> number? number?) #:immutable #t))
(ctest #t contract? (hash/c number? (-> number? number?)))
(ctest #f chaperone-contract? (hash/c number? (-> number? number?)))
(ctest #f flat-contract? (hash/c number? (-> number? number?)))
;; Make sure that proxies cannot be used as the domain contract in hash/c.
(contract-error-test
'(let ([proxy-ctc
(make-contract
#:name 'proxy-ctc
#:first-order values
#:higher-order (λ (b) values))])
(hash/c proxy-ctc proxy-ctc))
exn:fail?)
(ctest #t contract? 1)
(ctest #t contract? (-> 1 1))