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

added hash/c

Browse Source 
svn: r15210
This commit is contained in:
Robby Findler 2009-06-18 21:31:33 +00:00
parent d7f0c681c7
commit ec44ee7df1
3 changed files with 280 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/scheme/private/contract.ss
View File

@ -1366,7 +1366,8 @@ improve method arity mismatch contract violation error messages?
check-between/c
check-unary-between/c
parameter/c)
parameter/c
hash/c)
(define-syntax (flat-rec-contract stx)
(syntax-case stx ()
@ -2483,3 +2484,106 @@ improve method arity mismatch contract violation error messages?
(contract-stronger? (parameter/c-ctc that)
(parameter/c-ctc this)))))
(define (hash/c dom rng #:immutable [immutable 'dont-care])
(unless (memq immutable '(#t #f dont-care))
(error 'hash/c "expected #:immutable argument to be either #t, #f, or 'dont-care, got ~s" immutable))
(cond
[(eq? immutable #t)
(make-immutable-hash/c (coerce-contract 'hash/c dom)
(coerce-contract 'hash/c rng))]
[else
(make-hash/c (coerce-flat-contract 'hash/c dom)
(coerce-flat-contract 'hash/c rng)
immutable)]))
;; hash-test : hash/c -> any -> bool
(define (hash-test ctc)
(let ([dom-proc ((flat-get (hash/c-dom ctc)) (hash/c-dom ctc))]
[rng-proc ((flat-get (hash/c-rng ctc)) (hash/c-rng ctc))]
[immutable (hash/c-immutable ctc)])
(λ (val)
(and (hash? val)
(case immutable
[(#t) (immutable? val)]
[(#f) (not (immutable? val))]
[(dont-care) #t])
(let/ec k
(hash-for-each
val
(λ (dom rng)
(unless (dom-proc dom) (k #f))
(unless (rng-proc rng) (k #f))))
#t)))))
(define-struct hash/c (dom rng immutable)
#:omit-define-syntaxes
#:property flat-prop hash-test
#:property proj-prop
(λ (ctc)
(let ([dom-proc ((proj-get (hash/c-dom ctc)) (hash/c-dom ctc))]
[rng-proc ((proj-get (hash/c-rng ctc)) (hash/c-rng ctc))]
[immutable (hash/c-immutable ctc)])
(λ (pos-blame neg-blame src-info orig-str)
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str)]
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str)])
(λ (val)
(unless (hash? val)
(raise-contract-error val src-info pos-blame orig-str
"expected a hash"))
(case immutable
[(#t) (unless (immutable? val)
(raise-contract-error val src-info pos-blame orig-str
"expected an immutable hash"))]
[(#f) (when (immutable? val)
(raise-contract-error val src-info pos-blame orig-str
"expected a mutable hash"))]
[(dont-care) (void)])
(hash-for-each
val
(λ (key val)
(partial-dom-contract key)
(partial-rng-contract val)))
val)))))
#:property name-prop (λ (ctc) (apply
build-compound-type-name
'hash/c (hash/c-dom ctc) (hash/c-rng ctc)
(if (eq? 'dont-care (hash/c-immutable ctc))
'()
(list '#:immutable (hash/c-immutable ctc)))))
#:property stronger-prop
(λ (this that)
#f))
(define-struct immutable-hash/c (dom rng)
#:omit-define-syntaxes
#:property first-order-prop (λ (ctc) (λ (val) (and (hash? val) (immutable? val))))
#:property proj-prop
(λ (ctc)
(let ([dom-proc ((proj-get (immutable-hash/c-dom ctc)) (immutable-hash/c-dom ctc))]
[rng-proc ((proj-get (immutable-hash/c-rng ctc)) (immutable-hash/c-rng ctc))])
(λ (pos-blame neg-blame src-info orig-str)
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str)]
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str)])
(λ (val)
(unless (and (hash? val)
(immutable? val))
(raise-contract-error val src-info pos-blame orig-str
"expected an immutable hash"))
(make-immutable-hash
(hash-map
val
(λ (k v)
(cons (partial-dom-contract k)
(partial-rng-contract v))))))))))
#:property name-prop (λ (ctc) (build-compound-type-name
'hash/c (immutable-hash/c-dom ctc) (immutable-hash/c-rng ctc)
'#:immutable #t))
#:property stronger-prop
(λ (this that)
#f))

17
collects/scribblings/reference/contracts.scrbl
View File

@ -301,6 +301,23 @@ type named by @scheme[struct-id], and whose field values match the
Produces a contract on parameters whose values must match
@scheme[contract].}
@defproc[(hash/c [key contract?]
[val contract?]
[#:immutable immutable (or/c #t #f 'dont-care) 'dont-care])
contract?]{
Produces a contract that recognizes @scheme[hash] tables with keys and values
as specified by the @scheme[key] and @scheme[val] arguments.
If the @scheme[immutable] argument is @scheme[#f] or
@scheme['dont-care], then the resulting contract is a flat contract,
and the @scheme[key] and @scheme[val] arguments must also be flat
contracts.
If @scheme[immtable] is @scheme[#t], then the other arguments do not
have to be flat contracts, the result is not a flat contract, and
checking this contract involves making a copy of the hash-table.
}
@defform[(flat-rec-contract id flat-contract-expr ...)]

158
collects/tests/mzscheme/contract-test.ss
View File

@ -2161,7 +2161,127 @@
'pos 'neg)))
;
;
;
;
;
;
; ;; ;; ;
; ;; ;; ;
; ;;;;;; ;;;; ;;;;; ;;;;;; ;; ;;;;
; ;;;;;; ;; ;; ;; ;; ;;;;;; ; ;;;;;;
; ;; ;; ;;;; ;;;;; ;; ;; ; ;;;
; ;; ;; ;;; ;; ;;;; ;; ;; ; ;;;
; ;; ;; ;;; ;; ;; ;;; ;; ;; ;; ;;;;;;
; ;; ;; ;;;;;; ;;;;; ;; ;; ; ;;;;
;
;
;
(test/spec-passed
'hash/c1
'(contract (hash/c symbol? boolean?)
(make-hash)
'pos
'neg))
(test/spec-passed
'hash/c2
'(contract (hash/c symbol? boolean?)
(let ([h (make-hash)])
(hash-set! h 'x #t)
h)
'pos
'neg))
(test/pos-blame
'hash/c3
'(contract (hash/c symbol? boolean?)
(let ([h (make-hash)])
(hash-set! h 'x 'x)
h)
'pos
'neg))
(test/pos-blame
'hash/c4
'(contract (hash/c symbol? boolean?)
(let ([h (make-hash)])
(hash-set! h #t #f)
h)
'pos
'neg))
(test/pos-blame
'hash/c5
'(contract (hash/c symbol? boolean? #:immutable #t)
(let ([h (make-hash)])
(hash-set! h 'x #f)
h)
'pos
'neg))
(test/spec-passed
'hash/c6
'(contract (hash/c symbol? boolean? #:immutable #t)
(make-immutable-hash '((x . #f)))
'pos
'neg))
(test/spec-passed
'hash/c7
'(contract (hash/c symbol? boolean? #:immutable #f)
(let ([h (make-hash)])
(hash-set! h 'x #f)
h)
'pos
'neg))
(test/pos-blame
'hash/c8
'(contract (hash/c symbol? boolean? #:immutable #f)
(make-immutable-hash '((x . #f)))
'pos
'neg))
(test/spec-passed
'hash/c9
'(contract (hash/c symbol? boolean? #:immutable 'dont-care)
(make-immutable-hash '((x . #f)))
'pos
'neg))
(test/spec-passed
'hash/c10
'(contract (hash/c symbol? boolean? #:immutable 'dont-care)
(let ([h (make-hash)])
(hash-set! h 'x #f)
h)
'pos
'neg))
(test/spec-passed/result
'hash/c11
'(hash-ref (contract (hash/c symbol? number? #:immutable #t)
(make-immutable-hash '((x . 1)))
'pos
'neg)
'x)
1)
(test/spec-passed/result
'hash/c12
'(hash-ref (contract (hash/c symbol? number?)
(let ([ht (make-hash)])
(hash-set! ht 'x 1)
ht)
'pos
'neg)
'x)
1)
;
;
;
@ -5074,6 +5194,10 @@ so that propagation occurs.
(define-struct s (a b))
(struct/c s any/c any/c)))
(ctest #t flat-contract? (hash/c any/c any/c #:immutable #f))
(ctest #f flat-contract? (hash/c any/c any/c #:immutable #t))
(ctest #t flat-contract? (hash/c any/c any/c))
(ctest #t contract? 1)
(ctest #t contract? (-> 1 1))
@ -5170,6 +5294,23 @@ so that propagation occurs.
even1)
'(1 2 3 4)
'(1 2 3))
(test-flat-contract '(hash/c symbol? boolean?) (make-hash) 1)
(test-flat-contract '(hash/c symbol? boolean?)
(let ([ht (make-hash)])
(hash-set! ht 'x #t)
ht)
(let ([ht (make-hash)])
(hash-set! ht 'x 1)
ht))
(test-flat-contract '(hash/c symbol? boolean?)
(let ([ht (make-hash)])
(hash-set! ht 'x #t)
ht)
(let ([ht (make-hash)])
(hash-set! ht 'x 1)
ht))
(test #t 'malformed-binder
(with-handlers ((exn? exn:fail:syntax?))
(contract-eval '(flat-murec-contract ([(x) y]) x))
@ -5397,6 +5538,11 @@ so that propagation occurs.
(test-name '(parameter/c integer?) (parameter/c integer?))
(test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean?))
(test-name '(hash/c symbol? boolean? #:immutable #t) (hash/c symbol? boolean? #:immutable #t))
(test-name '(hash/c symbol? boolean? #:immutable #f) (hash/c symbol? boolean? #:immutable #f))
(test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean? #:immutable 'dont-care))
(test-name '(box/c boolean?) (box/c boolean?))
(test-name '(box/c boolean?) (box/c (flat-contract boolean?)))
(test-name 'the-name (flat-rec-contract the-name))
@ -5703,6 +5849,18 @@ so that propagation occurs.
(-> integer? integer?))
1)
(ctest #t contract-first-order-passes? (hash/c any/c any/c) (make-hash))
(ctest #f contract-first-order-passes? (hash/c any/c any/c) #f)
(ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
(hash-set! ht 'x 1)
ht))
(ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
(hash-set! ht 1 #f)
ht))
(ctest #t contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
(hash-set! ht 'x #t)
ht))
(test-name '(or/c) (or/c))
(test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))
(test-name '(or/c integer? boolean?)