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

add hash/c stronger

Browse Source 
also, bring down below 102 columns
This commit is contained in:
Robby Findler 2014-09-25 14:26:02 -05:00
parent 3ad2cb83bb
commit a9c0c8bccd
2 changed files with 46 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
View File

@ -193,6 +193,22 @@
(ctest #f contract-stronger? (box/c (<=/c 3)) (box/c (<=/c 3) #:immutable #t))
(ctest #f contract-stronger? (box/c (<=/c 3)) (box/c (<=/c 3) #:immutable #f))
(ctest #t contract-stronger? (hash/c integer? symbol?) (hash/c integer? symbol?))
(ctest #f contract-stronger? (hash/c integer? symbol?) (hash/c symbol? integer?))
(ctest #f contract-stronger? (hash/c (<=/c 2) symbol?) (hash/c (<=/c 3) symbol?))
(ctest #t contract-stronger?
(hash/c (<=/c 2) symbol? #:immutable #t)
(hash/c (<=/c 3) symbol? #:immutable #t))
(ctest #f contract-stronger?
(hash/c (<=/c 3) symbol? #:immutable #t)
(hash/c (<=/c 2) symbol? #:immutable #t))
(ctest #t contract-stronger?
(hash/c (<=/c 2) symbol? #:immutable #f)
(hash/c (<=/c 2) symbol?))
(ctest #f contract-stronger?
(hash/c (<=/c 2) symbol?)
(hash/c (<=/c 2) symbol? #:immutable #f))
(contract-eval
`(let ()
(define x (flat-rec-contract x (or/c (cons/c x '()) '())))

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

@ -86,7 +86,8 @@
(when (and (not flat?)
(not (flat-contract? dom-ctc))
(not (hash-equal? val)))
(raise-blame-error blame val
(raise-blame-error
blame val
'(expected "equal?-based hash table due to higher-order domain contract" given: "~e")
val))
(case immutable
@ -136,6 +137,29 @@
(define-struct base-hash/c (dom rng immutable))
(define (hash/c-stronger this that)
(define this-dom (base-hash/c-dom this))
(define this-rng (base-hash/c-rng this))
(define this-immutable (base-hash/c-immutable this))
(cond
[(base-hash/c? that)
(define that-dom (base-hash/c-dom that))
(define that-rng (base-hash/c-rng that))
(define that-immutable (base-hash/c-immutable that))
(cond
[(and (equal? this-immutable #t)
(equal? that-immutable #t))
(and (contract-stronger? this-dom that-dom)
(contract-stronger? this-rng that-rng))]
[(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable))
(and (contract-stronger? this-dom that-dom)
(contract-stronger? that-dom this-dom)
(contract-stronger? this-rng that-rng)
(contract-stronger? that-rng this-rng))]
[else #f])]
[else #f]))
(define-struct (flat-hash/c base-hash/c) ()
#:omit-define-syntaxes
#:property prop:custom-write custom-write-property-proc
@ -143,6 +167,7 @@
(build-flat-contract-property
#:name hash/c-name
#:first-order hash/c-first-order
#:stronger hash/c-stronger
#:projection
(λ (ctc)
(λ (blame)
@ -202,6 +227,7 @@
(build-chaperone-contract-property
#:name hash/c-name
#:first-order hash/c-first-order
#:stronger hash/c-stronger
#:projection (ho-projection chaperone-hash)))
(define-struct (impersonator-hash/c base-hash/c) ()
@ -211,4 +237,5 @@
(build-contract-property
#:name hash/c-name
#:first-order hash/c-first-order
#:stronger hash/c-stronger
#:projection (ho-projection impersonate-hash)))