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

Ported misc.ss to new properties.

Browse Source 
svn: r17693
This commit is contained in:
Carl Eastlund 2010-01-17 05:44:54 +00:00
parent 41565a3869
commit 2ed1f852aa
1 changed files with 307 additions and 326 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

297
collects/scheme/contract/private/misc.ss
View File

@ -126,34 +126,36 @@
(define-struct or/c (pred flat-ctcs ho-ctc) (define-struct or/c (pred flat-ctcs ho-ctc)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property proj-prop #:property prop:contract
(build-contract-property
#:projection
(λ (ctc) (λ (ctc)
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))] (let ([c-proc (contract-projection (or/c-ho-ctc ctc))]
[pred (or/c-pred ctc)]) [pred (or/c-pred ctc)])
(λ (pos-blame neg-blame src-info orig-str positive-position?) (λ (blame)
(let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str positive-position?)]) (let ([partial-contract (c-proc blame)])
(λ (val) (λ (val)
(cond (cond
[(pred val) val] [(pred val) val]
[else [else
(partial-contract val)])))))) (partial-contract val)]))))))
#:property name-prop #:name
(λ (ctc) (λ (ctc)
(apply build-compound-type-name (apply build-compound-type-name
'or/c 'or/c
(or/c-ho-ctc ctc) (or/c-ho-ctc ctc)
(or/c-flat-ctcs ctc))) (or/c-flat-ctcs ctc)))
#:property first-order-prop #:first-order
(λ (ctc) (λ (ctc)
(let ([pred (or/c-pred ctc)] (let ([pred (or/c-pred ctc)]
[ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]) [ho (contract-first-order (or/c-ho-ctc ctc))])
(λ (x) (λ (x)
(or (ho x) (or (ho x)
(pred x))))) (pred x)))))
#:property stronger-prop #:stronger
(λ (this that) (λ (this that)
(and (or/c? that) (and (or/c? that)
(contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that)) (contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that))
@ -162,15 +164,15 @@
(and (= (length this-ctcs) (length that-ctcs)) (and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger? (andmap contract-stronger?
this-ctcs this-ctcs
that-ctcs)))))) that-ctcs)))))))
(define (multi-or/c-proj ctc) (define (multi-or/c-proj ctc)
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)] (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
[c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)] [c-procs (map (λ (x) (contract-projection x)) ho-contracts)]
[first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)] [first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
[predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]) [predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
(λ (pos-blame neg-blame src-info orig-str positive-position?) (λ (blame)
(let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str positive-position?)) c-procs)]) (let ([partial-contracts (map (λ (c-proc) (c-proc blame)) c-procs)])
(λ (val) (λ (val)
(cond (cond
[(ormap (λ (pred) (pred val)) predicates) [(ormap (λ (pred) (pred val)) predicates)
@ -185,12 +187,12 @@
[(null? checks) [(null? checks)
(if candidate-proc (if candidate-proc
(candidate-proc val) (candidate-proc val)
(raise-contract-error val src-info pos-blame orig-str (raise-blame-error blame val
"none of the branches of the or/c matched, given ~e" "none of the branches of the or/c matched, given ~e"
val))] val))]
[((car checks) val) [((car checks) val)
(if candidate-proc (if candidate-proc
(raise-contract-error val src-info pos-blame orig-str (raise-blame-error blame val
"two of the clauses in the or/c might both match: ~s and ~s, given ~e" "two of the clauses in the or/c might both match: ~s and ~s, given ~e"
(contract-name candidate-contract) (contract-name candidate-contract)
(contract-name (car contracts)) (contract-name (car contracts))
@ -208,8 +210,10 @@
candidate-contract)]))])))))) candidate-contract)]))]))))))
(define-struct multi-or/c (flat-ctcs ho-ctcs) (define-struct multi-or/c (flat-ctcs ho-ctcs)
#:property proj-prop multi-or/c-proj #:property prop:contract
#:property name-prop (build-contract-property
#:projection multi-or/c-proj
#:name
(λ (ctc) (λ (ctc)
(apply build-compound-type-name (apply build-compound-type-name
'or/c 'or/c
@ -217,15 +221,15 @@
(multi-or/c-flat-ctcs ctc) (multi-or/c-flat-ctcs ctc)
(reverse (multi-or/c-ho-ctcs ctc))))) (reverse (multi-or/c-ho-ctcs ctc)))))
#:property first-order-prop #:first-order
(λ (ctc) (λ (ctc)
(let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))] (let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
[hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))]) [hos (map (λ (x) (contract-first-order x)) (multi-or/c-ho-ctcs ctc))])
(λ (x) (λ (x)
(or (ormap (λ (f) (f x)) hos) (or (ormap (λ (f) (f x)) hos)
(ormap (λ (f) (f x)) flats))))) (ormap (λ (f) (f x)) flats)))))
#:property stronger-prop #:stronger
(λ (this that) (λ (this that)
(and (multi-or/c? that) (and (multi-or/c? that)
(let ([this-ctcs (multi-or/c-ho-ctcs this)] (let ([this-ctcs (multi-or/c-ho-ctcs this)]
@ -239,16 +243,17 @@
(and (= (length this-ctcs) (length that-ctcs)) (and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger? (andmap contract-stronger?
this-ctcs this-ctcs
that-ctcs)))))) that-ctcs)))))))
(define-struct flat-or/c (pred flat-ctcs) (define-struct flat-or/c (pred flat-ctcs)
#:property proj-prop flat-proj #:property prop:flat-contract
#:property name-prop (build-flat-contract-property
#:name
(λ (ctc) (λ (ctc)
(apply build-compound-type-name (apply build-compound-type-name
'or/c 'or/c
(flat-or/c-flat-ctcs ctc))) (flat-or/c-flat-ctcs ctc)))
#:property stronger-prop #:stronger
(λ (this that) (λ (this that)
(and (flat-or/c? that) (and (flat-or/c? that)
(let ([this-ctcs (flat-or/c-flat-ctcs this)] (let ([this-ctcs (flat-or/c-flat-ctcs this)]
@ -258,8 +263,8 @@
this-ctcs this-ctcs
that-ctcs))))) that-ctcs)))))
#:property flat-prop #:first-order
(λ (ctc) (flat-or/c-pred ctc))) (λ (ctc) (flat-or/c-pred ctc))))
;; ;;
;; or/c opter ;; or/c opter
@ -283,12 +288,8 @@
(list (cons (list (cons
partial-var partial-var
(with-syntax ((lift-var lift-var) (with-syntax ((lift-var lift-var)
(pos (opt/info-pos opt/info)) (blame (opt/info-blame opt/info)))
(neg (opt/info-neg opt/info)) (syntax ((contract-projection lift-var) blame)))))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(positive-position? (opt/info-orig-str opt/info)))
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str positive-position?)))))
#f #f
lift-var lift-var
(list #f) (list #f)
@ -351,13 +352,12 @@
(cond (cond
[(null? hos) [(null? hos)
(with-syntax ([val (opt/info-val opt/info)] (with-syntax ([val (opt/info-val opt/info)]
[pos (opt/info-pos opt/info)] [blame (opt/info-blame opt/info)])
[src-info (opt/info-src-info opt/info)]
[orig-str (opt/info-orig-str opt/info)])
(syntax (syntax
(if next-ps (if next-ps
val val
(raise-contract-error val src-info pos orig-str (raise-blame-error blame
val
"none of the branches of the or/c matched"))))] "none of the branches of the or/c matched"))))]
[(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc)) [(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc))
(syntax (syntax
@ -435,8 +435,9 @@
(define-struct one-of/c (elems) (define-struct one-of/c (elems)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property proj-prop flat-proj #:property prop:flat-contract
#:property name-prop (build-flat-contract-property
#:name
(λ (ctc) (λ (ctc)
(let ([elems (one-of/c-elems ctc)]) (let ([elems (one-of/c-elems ctc)])
`(,(cond `(,(cond
@ -446,7 +447,7 @@
'one-of/c]) 'one-of/c])
,@(map one-of-pc elems)))) ,@(map one-of-pc elems))))
#:property stronger-prop #:stronger
(λ (this that) (λ (this that)
(and (one-of/c? that) (and (one-of/c? that)
(let ([this-elems (one-of/c-elems this)] (let ([this-elems (one-of/c-elems this)]
@ -455,10 +456,10 @@
(andmap (λ (this-elem) (memv this-elem that-elems)) (andmap (λ (this-elem) (memv this-elem that-elems))
this-elems) this-elems)
#t)))) #t))))
#:property flat-prop #:first-order
(λ (ctc) (λ (ctc)
(let ([elems (one-of/c-elems ctc)]) (let ([elems (one-of/c-elems ctc)])
(λ (x) (memv x elems))))) (λ (x) (memv x elems))))))
(define printable/c (define printable/c
(flat-named-contract (flat-named-contract
@ -484,8 +485,9 @@
(define-struct between/c (low high) (define-struct between/c (low high)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property proj-prop flat-proj #:property prop:flat-contract
#:property name-prop (build-flat-contract-property
#:name
(λ (ctc) (λ (ctc)
(let ([n (between/c-low ctc)] (let ([n (between/c-low ctc)]
[m (between/c-high ctc)]) [m (between/c-high ctc)])
@ -495,19 +497,19 @@
[(= n m) `(=/c ,n)] [(= n m) `(=/c ,n)]
[else `(between/c ,n ,m)]))) [else `(between/c ,n ,m)])))
#:property stronger-prop #:stronger
(λ (this that) (λ (this that)
(and (between/c? that) (and (between/c? that)
(<= (between/c-low that) (between/c-low this)) (<= (between/c-low that) (between/c-low this))
(<= (between/c-high this) (between/c-high that)))) (<= (between/c-high this) (between/c-high that))))
#:property flat-prop #:first-order
(λ (ctc) (λ (ctc)
(let ([n (between/c-low ctc)] (let ([n (between/c-low ctc)]
[m (between/c-high ctc)]) [m (between/c-high ctc)])
(λ (x) (λ (x)
(and (real? x) (and (real? x)
(<= n x m)))))) (<= n x m)))))))
(define-syntax (check-unary-between/c stx) (define-syntax (check-unary-between/c stx)
(syntax-case stx () (syntax-case stx ()
@ -556,21 +558,17 @@
(let ([lifts3 (lift/effect #'(check-between/c n m) lifts2)]) (let ([lifts3 (lift/effect #'(check-between/c n m) lifts2)])
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info)) (blame (opt/info-blame opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(this (opt/info-this opt/info)) (this (opt/info-this opt/info))
(that (opt/info-that opt/info))) (that (opt/info-that opt/info)))
(values (values
(syntax (if (and (number? val) (<= n val m)) (syntax (if (and (number? val) (<= n val m))
val val
(raise-contract-error (raise-blame-error
blame
val val
src-info
pos
orig-str
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
((name-get ctc) ctc) (contract-name ctc)
val))) val)))
lifts3 lifts3
null null
@ -597,22 +595,18 @@
(let ([lifts3 (lift/effect (check-arg #'m) lifts2)]) (let ([lifts3 (lift/effect (check-arg #'m) lifts2)])
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info)) (blame (opt/info-blame opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(this (opt/info-this opt/info)) (this (opt/info-this opt/info))
(that (opt/info-that opt/info))) (that (opt/info-that opt/info)))
(values (values
(syntax (syntax
(if (and (real? val) (comparison val m)) (if (and (real? val) (comparison val m))
val val
(raise-contract-error (raise-blame-error
blame
val val
src-info
pos
orig-str
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
((name-get ctc) ctc) (contract-name ctc)
val))) val)))
lifts3 lifts3
null null
@ -731,18 +725,17 @@
(build-flat-contract (build-flat-contract
`(name ,(contract-name ctc)) `(name ,(contract-name ctc))
(lambda (x) (and (predicate? x) (testmap content-pred? x))))) (lambda (x) (and (predicate? x) (testmap content-pred? x)))))
(let ([proj (contract-proc ctc)]) (let ([proj (contract-projection ctc)])
(make-proj-contract (simple-contract
(build-compound-type-name 'name ctc) #:name (build-compound-type-name 'name ctc)
(λ (pos-blame neg-blame src-info orig-str positive-position?) #:projection
(let ([p-app (proj pos-blame neg-blame src-info orig-str positive-position?)]) (λ (blame)
(let ([p-app (proj blame)])
(λ (val) (λ (val)
(unless (predicate? val) (unless (predicate? val)
(raise-contract-error (raise-blame-error
blame
val val
src-info
pos-blame
orig-str
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
'type-name 'type-name
val)) val))
@ -816,18 +809,14 @@
(values (values
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info)) (blame (opt/info-blame opt/info)))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)))
(syntax (if next (syntax (if next
val val
(raise-contract-error (raise-blame-error
blame
val val
src-info
pos
orig-str
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
((name-get ctc) ctc) (contract-name ctc)
val)))) val))))
(append (append
lifts-hdp lifts-tlp lifts-hdp lifts-tlp
@ -894,22 +883,21 @@
(and (predicate?-name x) (and (predicate?-name x)
(p-apps (selector-names x)) (p-apps (selector-names x))
...)))) ...))))
(let ([procs (contract-proc ctc-x)] ...) (let ([procs (contract-projection ctc-x)] ...)
(make-proj-contract (simple-contract
(build-compound-type-name 'name ctc-x ...) #:name (build-compound-type-name 'name ctc-x ...)
(λ (pos-blame neg-blame src-info orig-str positive-position?) #:projection
(let ([p-apps (procs pos-blame neg-blame src-info orig-str positive-position?)] ...) (λ (blame)
(let ([p-apps (procs blame)] ...)
(λ (v) (λ (v)
(if #,(if test-immutable? (if #,(if test-immutable?
#'(and (predicate?-name v) #'(and (predicate?-name v)
(immutable? v)) (immutable? v))
#'(predicate?-name v)) #'(predicate?-name v))
(constructor-name (p-apps (selector-names v)) ...) (constructor-name (p-apps (selector-names v)) ...)
(raise-contract-error (raise-blame-error
blame
v v
src-info
pos-blame
orig-str
#,(if test-immutable? #,(if test-immutable?
"expected immutable <~a>, given: ~e" "expected immutable <~a>, given: ~e"
"expected <~a>, given: ~e") "expected <~a>, given: ~e")
@ -924,11 +912,12 @@
[selector-name selector]) [selector-name selector])
(λ params (λ params
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)]) (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
(let ([procs (map contract-proc ctcs)]) (let ([procs (map contract-projection ctcs)])
(make-proj-contract (simple-contract
(apply build-compound-type-name 'name ctcs) #:name (apply build-compound-type-name 'name ctcs)
(λ (pos-blame neg-blame src-info orig-str positive-position?) #:projection
(let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str positive-position?)) procs)] (λ (blame)
(let ([p-apps (map (λ (proc) (proc blame)) procs)]
[count (length params)]) [count (length params)])
(λ (v) (λ (v)
(if (and (immutable? v) (if (and (immutable? v)
@ -942,11 +931,9 @@
[else (let ([p-app (car p-apps)]) [else (let ([p-app (car p-apps)])
(cons (p-app (selector-name v i)) (cons (p-app (selector-name v i))
(loop (cdr p-apps) (+ i 1))))]))) (loop (cdr p-apps) (+ i 1))))])))
(raise-contract-error (raise-blame-error
blame
v v
src-info
pos-blame
orig-str
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
'type-name 'type-name
v))))) v)))))
@ -975,21 +962,17 @@
(values (values
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info)) (blame (opt/info-blame opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(next-hdp next-hdp) (next-hdp next-hdp)
(next-tlp next-tlp)) (next-tlp next-tlp))
(syntax (if check (syntax (if check
(cons (let ((val (car val))) next-hdp) (cons (let ((val (car val))) next-hdp)
(let ((val (cdr val))) next-tlp)) (let ((val (cdr val))) next-tlp))
(raise-contract-error (raise-blame-error
blame
val val
src-info
pos
orig-str
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
((name-get ctc) ctc) (contract-name ctc)
val)))) val))))
(append lifts-hdp lifts-tlp) (append lifts-hdp lifts-tlp)
(append superlifts-hdp superlifts-tlp) (append superlifts-hdp superlifts-tlp)
@ -1026,19 +1009,16 @@
(define promise/c (define promise/c
(λ (ctc-in) (λ (ctc-in)
(let* ([ctc (coerce-contract 'promise/c ctc-in)] (let* ([ctc (coerce-contract 'promise/c ctc-in)]
[ctc-proc (contract-proc ctc)]) [ctc-proc (contract-projection ctc)])
(make-proj-contract (simple-contract
(build-compound-type-name 'promise/c ctc) #:name (build-compound-type-name 'promise/c ctc)
(λ (pos-blame neg-blame src-info orig-str positive-position?) (λ (blame)
(let ([p-app (ctc-proc pos-blame neg-blame src-info orig-str positive-position?)]) (let ([p-app (ctc-proc blame)])
(λ (val) (λ (val)
(unless (promise? val) (unless (promise? val)
(raise-contract-error (raise-blame-error
blame
val val
src-info
pos-blame
'ignored
orig-str
"expected <promise>, given: ~e" "expected <promise>, given: ~e"
val)) val))
(delay (p-app (force val)))))) (delay (p-app (force val))))))
@ -1117,12 +1097,14 @@
(define-struct parameter/c (ctc) (define-struct parameter/c (ctc)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property proj-prop #:property prop:contract
(build-contract-property
#:projection
(λ (ctc) (λ (ctc)
(let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) (let ([c-proc (contract-projection (parameter/c-ctc ctc))])
(λ (pos-blame neg-blame src-info orig-str positive-position?) (λ (blame)
(let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str (not positive-position?))] (let ([partial-neg-contract (c-proc (blame-swap blame))]
[partial-pos-contract (c-proc pos-blame neg-blame src-info orig-str positive-position?)]) [partial-pos-contract (c-proc blame)])
(λ (val) (λ (val)
(cond (cond
[(parameter? val) [(parameter? val)
@ -1131,18 +1113,18 @@
partial-neg-contract partial-neg-contract
partial-pos-contract)] partial-pos-contract)]
[else [else
(raise-contract-error val src-info pos-blame orig-str (raise-blame-error blame val "expected a parameter")]))))))
"expected a parameter")]))))))
#:property name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc))) #:name
#:property first-order-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))
#:first-order
(λ (ctc) (λ (ctc)
(let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) (let ([tst (contract-first-order (parameter/c-ctc ctc))])
(λ (x) (λ (x)
(and (parameter? x) (and (parameter? x)
(tst (x)))))) (tst (x))))))
#:property stronger-prop #:stronger
(λ (this that) (λ (this that)
;; must be invariant (because the library doesn't currently split out pos/neg contracts ;; must be invariant (because the library doesn't currently split out pos/neg contracts
;; which could be tested individually ....) ;; which could be tested individually ....)
@ -1150,7 +1132,7 @@
(contract-stronger? (parameter/c-ctc this) (contract-stronger? (parameter/c-ctc this)
(parameter/c-ctc that)) (parameter/c-ctc that))
(contract-stronger? (parameter/c-ctc that) (contract-stronger? (parameter/c-ctc that)
(parameter/c-ctc this))))) (parameter/c-ctc this))))))
(define (hash/c dom rng #:immutable [immutable 'dont-care]) (define (hash/c dom rng #:immutable [immutable 'dont-care])
(unless (memq immutable '(#t #f dont-care)) (unless (memq immutable '(#t #f dont-care))
@ -1166,8 +1148,8 @@
;; hash-test : hash/c -> any -> bool ;; hash-test : hash/c -> any -> bool
(define (hash-test ctc) (define (hash-test ctc)
(let ([dom-proc ((flat-get (hash/c-dom ctc)) (hash/c-dom ctc))] (let ([dom-proc (flat-contract-predicate (hash/c-dom ctc))]
[rng-proc ((flat-get (hash/c-rng ctc)) (hash/c-rng ctc))] [rng-proc (flat-contract-predicate (hash/c-rng ctc))]
[immutable (hash/c-immutable ctc)]) [immutable (hash/c-immutable ctc)])
(λ (val) (λ (val)
(and (hash? val) (and (hash? val)
@ -1186,25 +1168,26 @@
(define-struct hash/c (dom rng immutable) (define-struct hash/c (dom rng immutable)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property flat-prop hash-test #:property prop:flat-contract
#:property proj-prop (build-flat-contract-property
#:first-order hash-test
#:projection
(λ (ctc) (λ (ctc)
(let ([dom-proc ((proj-get (hash/c-dom ctc)) (hash/c-dom ctc))] (let ([dom-proc (contract-projection (hash/c-dom ctc))]
[rng-proc ((proj-get (hash/c-rng ctc)) (hash/c-rng ctc))] [rng-proc (contract-projection (hash/c-rng ctc))]
[immutable (hash/c-immutable ctc)]) [immutable (hash/c-immutable ctc)])
(λ (pos-blame neg-blame src-info orig-str positive-position?) (λ (blame)
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str positive-position?)] (let ([partial-dom-contract (dom-proc blame)]
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str positive-position?)]) [partial-rng-contract (rng-proc blame)])
(λ (val) (λ (val)
(unless (hash? val) (unless (hash? val)
(raise-contract-error val src-info pos-blame orig-str (raise-blame-error blame val "expected a hash, got ~a" val))
"expected a hash, got ~a" val))
(case immutable (case immutable
[(#t) (unless (immutable? val) [(#t) (unless (immutable? val)
(raise-contract-error val src-info pos-blame orig-str (raise-blame-error blame val
"expected an immutable hash, got ~a" val))] "expected an immutable hash, got ~a" val))]
[(#f) (when (immutable? val) [(#f) (when (immutable? val)
(raise-contract-error val src-info pos-blame orig-str (raise-blame-error blame val
"expected a mutable hash, got ~a" val))] "expected a mutable hash, got ~a" val))]
[(dont-care) (void)]) [(dont-care) (void)])
@ -1216,31 +1199,31 @@
val))))) val)))))
#:property name-prop (λ (ctc) (apply #:name
(λ (ctc) (apply
build-compound-type-name build-compound-type-name
'hash/c (hash/c-dom ctc) (hash/c-rng ctc) 'hash/c (hash/c-dom ctc) (hash/c-rng ctc)
(if (eq? 'dont-care (hash/c-immutable ctc)) (if (eq? 'dont-care (hash/c-immutable ctc))
'() '()
(list '#:immutable (hash/c-immutable ctc))))) (list '#:immutable (hash/c-immutable ctc)))))))
#:property stronger-prop
(λ (this that)
#f))
(define-struct immutable-hash/c (dom rng) (define-struct immutable-hash/c (dom rng)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property first-order-prop (λ (ctc) (λ (val) (and (hash? val) (immutable? val)))) #:property prop:contract
#:property proj-prop (build-contract-property
#:first-order (λ (ctc) (λ (val) (and (hash? val) (immutable? val))))
#:projection
(λ (ctc) (λ (ctc)
(let ([dom-proc ((proj-get (immutable-hash/c-dom ctc)) (immutable-hash/c-dom ctc))] (let ([dom-proc (contract-projection (immutable-hash/c-dom ctc))]
[rng-proc ((proj-get (immutable-hash/c-rng ctc)) (immutable-hash/c-rng ctc))]) [rng-proc (contract-projection (immutable-hash/c-rng ctc))])
(λ (pos-blame neg-blame src-info orig-str positive-position?) (λ (blame)
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str positive-position?)] (let ([partial-dom-contract (dom-proc blame)]
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str positive-position?)]) [partial-rng-contract (rng-proc blame)])
(λ (val) (λ (val)
(unless (and (hash? val) (unless (and (hash? val)
(immutable? val)) (immutable? val))
(raise-contract-error val src-info pos-blame orig-str (raise-blame-error blame val
"expected an immutable hash")) "expected an immutable hash"))
(make-immutable-hash (make-immutable-hash
(hash-map (hash-map
@ -1249,9 +1232,7 @@
(cons (partial-dom-contract k) (cons (partial-dom-contract k)
(partial-rng-contract v)))))))))) (partial-rng-contract v))))))))))
#:property name-prop (λ (ctc) (build-compound-type-name #:name
(λ (ctc) (build-compound-type-name
'hash/c (immutable-hash/c-dom ctc) (immutable-hash/c-rng ctc) 'hash/c (immutable-hash/c-dom ctc) (immutable-hash/c-rng ctc)
'#:immutable #t)) '#:immutable #t))))
#:property stronger-prop
(λ (this that)
#f))