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

Separate out hash/c code into a separate module.

Browse Source
This commit is contained in:
Stevie Strickland 2010-05-12 12:43:45 -04:00
parent a1c188ae74
commit f5b62ececd
5 changed files with 114 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/contract.rkt
View File

@ -30,6 +30,7 @@
;;
(require racket/contract/private/base
racket/contract/private/hash
racket/contract/private/misc
racket/contract/private/provide
racket/contract/private/guts
@ -44,6 +45,7 @@
contract-struct)
(all-from-out racket/contract/private/base)
(all-from-out racket/contract/private/hash)
(all-from-out racket/contract/private/provide)
(except-out (all-from-out racket/contract/private/misc)
check-between/c

2
collects/racket/contract/base.rkt
View File

@ -6,6 +6,7 @@
(require "private/arrow.rkt"
"private/arr-i.rkt"
"private/base.rkt"
"private/hash.rkt"
"private/misc.rkt"
"private/provide.rkt"
"private/guts.rkt"
@ -25,6 +26,7 @@
check-procedure/more
make-contracted-function)
(all-from-out "private/arr-i.rkt")
(all-from-out "private/hash.rkt")
(except-out (all-from-out "private/misc.rkt")
check-between/c
check-unary-between/c)

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

@ -0,0 +1,108 @@
#lang racket/base
(require "guts.ss")
(provide hash/c)
(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-contract-predicate (hash/c-dom ctc))]
[rng-proc (flat-contract-predicate (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 prop:flat-contract
(build-flat-contract-property
#:first-order hash-test
#: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 ([partial-dom-contract (dom-proc blame)]
[partial-rng-contract (rng-proc blame)])
(λ (val)
(unless (hash? val)
(raise-blame-error blame val "expected a hash, got ~a" val))
(case immutable
[(#t) (unless (immutable? val)
(raise-blame-error blame val
"expected an immutable hash, got ~a" val))]
[(#f) (when (immutable? val)
(raise-blame-error blame val
"expected a mutable hash, got ~a" val))]
[(dont-care) (void)])
(hash-for-each
val
(λ (key val)
(partial-dom-contract key)
(partial-rng-contract val)))
val)))))
#:name
(λ (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)))))))
(define-struct immutable-hash/c (dom rng)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:first-order (λ (ctc) (λ (val) (and (hash? val) (immutable? val))))
#:projection
(λ (ctc)
(let ([dom-proc (contract-projection (immutable-hash/c-dom ctc))]
[rng-proc (contract-projection (immutable-hash/c-rng ctc))])
(λ (blame)
(let ([partial-dom-contract (dom-proc blame)]
[partial-rng-contract (rng-proc blame)])
(λ (val)
(unless (and (hash? val)
(immutable? val))
(raise-blame-error blame val
"expected an immutable hash"))
(make-immutable-hash
(hash-map
val
(λ (k v)
(cons (partial-dom-contract k)
(partial-rng-contract v))))))))))
#:name
(λ (ctc) (build-compound-type-name
'hash/c (immutable-hash/c-dom ctc) (immutable-hash/c-rng ctc)
'#:immutable #t))))

106
collects/racket/contract/private/misc.rkt
View File

@ -29,8 +29,7 @@
check-between/c
check-unary-between/c
parameter/c
hash/c)
parameter/c)
(define-syntax (flat-rec-contract stx)
(syntax-case stx ()
@ -1242,106 +1241,3 @@
(parameter/c-ctc that))
(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-contract-predicate (hash/c-dom ctc))]
[rng-proc (flat-contract-predicate (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 prop:flat-contract
(build-flat-contract-property
#:first-order hash-test
#: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 ([partial-dom-contract (dom-proc blame)]
[partial-rng-contract (rng-proc blame)])
(λ (val)
(unless (hash? val)
(raise-blame-error blame val "expected a hash, got ~a" val))
(case immutable
[(#t) (unless (immutable? val)
(raise-blame-error blame val
"expected an immutable hash, got ~a" val))]
[(#f) (when (immutable? val)
(raise-blame-error blame val
"expected a mutable hash, got ~a" val))]
[(dont-care) (void)])
(hash-for-each
val
(λ (key val)
(partial-dom-contract key)
(partial-rng-contract val)))
val)))))
#:name
(λ (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)))))))
(define-struct immutable-hash/c (dom rng)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:first-order (λ (ctc) (λ (val) (and (hash? val) (immutable? val))))
#:projection
(λ (ctc)
(let ([dom-proc (contract-projection (immutable-hash/c-dom ctc))]
[rng-proc (contract-projection (immutable-hash/c-rng ctc))])
(λ (blame)
(let ([partial-dom-contract (dom-proc blame)]
[partial-rng-contract (rng-proc blame)])
(λ (val)
(unless (and (hash? val)
(immutable? val))
(raise-blame-error blame val
"expected an immutable hash"))
(make-immutable-hash
(hash-map
val
(λ (k v)
(cons (partial-dom-contract k)
(partial-rng-contract v))))))))))
#:name
(λ (ctc) (build-compound-type-name
'hash/c (immutable-hash/c-dom ctc) (immutable-hash/c-rng ctc)
'#:immutable #t))))

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

@ -20,6 +20,7 @@ constraints.
@note-lib[racket/contract #:use-sources (racket/contract/private/ds
racket/contract/private/base
racket/contract/private/guts
racket/contract/private/hash
racket/contract/private/misc
racket/contract/private/provide)]