merged revision 2489:2523 from plt/branches/robby -- somehow contract-guts.ss came out messed up; I replaced it with the actual latest version from the branch and things seem okay
svn: r2524
This commit is contained in:
Robby Findler
parent
5d2e3756c6
commit
cf86c57215
File diff suppressed because it is too large
Load Diff
|
|
@ -8,12 +8,13 @@
|
|||
|
||||
(define-syntax (define-contract-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name (fields ...))
|
||||
[(_ name (fields ...))
|
||||
(syntax (define-contract-struct name (fields ...) (current-inspector)))]
|
||||
[(_ name (fields ...) inspector)
|
||||
(and (identifier? (syntax name))
|
||||
(andmap identifier? (syntax->list (syntax (fields ...)))))
|
||||
(let* ([add-suffix
|
||||
(let* ([mutable? (syntax-e (syntax mutable?))]
|
||||
[add-suffix
|
||||
(λ (suffix)
|
||||
(datum->syntax-object (syntax name)
|
||||
(string->symbol
|
||||
|
|
@ -110,15 +111,20 @@
|
|||
(wrap-get stct i+1)))
|
||||
|
||||
(define (rewrite-fields contract/info ctc-x ...)
|
||||
(let* ([f-x (let ([ctc-field (contract-get (contract/info-contract contract/info) selector-indicies)])
|
||||
(let* ([f-x (let ([ctc-field (contract-get (contract/info-contract contract/info)
|
||||
selector-indicies)])
|
||||
(let ([ctc (if (procedure? ctc-field)
|
||||
(ctc-field f-xs ...)
|
||||
ctc-field)])
|
||||
((((proj-get ctc) ctc) (contract/info-pos contract/info)
|
||||
(contract/info-neg contract/info)
|
||||
(contract/info-src-info contract/info)
|
||||
(contract/info-orig-str contract/info))
|
||||
ctc-x)))] ...)
|
||||
(if (contract/info-pos contract/info)
|
||||
((((pos-proj-get ctc) ctc) (contract/info-pos contract/info)
|
||||
(contract/info-src-info contract/info)
|
||||
(contract/info-orig-str contract/info))
|
||||
ctc-x)
|
||||
((((neg-proj-get ctc) ctc) (contract/info-neg contract/info)
|
||||
(contract/info-src-info contract/info)
|
||||
(contract/info-orig-str contract/info))
|
||||
ctc-x))))] ...)
|
||||
(values f-x ...)))
|
||||
|
||||
(define (stronger-lazy-contract? a b)
|
||||
|
|
@ -127,33 +133,49 @@
|
|||
(contract-get a selector-indicies)
|
||||
(contract-get b selector-indicies)) ...))
|
||||
|
||||
(define (lazy-contract-proj ctc)
|
||||
(λ (pos neg src-info orig-str)
|
||||
(let ([contract/info (make-contract/info ctc pos neg src-info orig-str)])
|
||||
(define (lazy-contract-pos-proj ctc)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([contract/info (make-contract/info ctc blame #f src-info orig-str)])
|
||||
(λ (val)
|
||||
(unless (or (wrap-predicate val)
|
||||
(raw-predicate val))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
blame
|
||||
'ignored
|
||||
orig-str
|
||||
"expected <~a>, got ~e" 'name val))
|
||||
(cond
|
||||
[(already-there? ctc val lazy-depth-to-look)
|
||||
[(already-there? contract/info val lazy-depth-to-look)
|
||||
val]
|
||||
[else
|
||||
(wrap-maker val contract/info)])))))
|
||||
|
||||
(define (already-there? ctc val depth)
|
||||
(define (lazy-contract-neg-proj ctc)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([contract/info (make-contract/info ctc #f blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(already-there? contract/info val lazy-depth-to-look)
|
||||
val]
|
||||
[else
|
||||
(wrap-maker val contract/info)])))))
|
||||
|
||||
(define (already-there? new-contract/info val depth)
|
||||
(cond
|
||||
[(raw-predicate val) #f]
|
||||
[(zero? depth) #f]
|
||||
[(wrap-get val 0)
|
||||
(if (contract-stronger? (contract/info-contract (wrap-get val 1)) ctc)
|
||||
#t
|
||||
(already-there? ctc (wrap-get val 0) (- depth 1)))]
|
||||
(let ([old-contract/info (wrap-get val 1)])
|
||||
(if (and (eq? (contract/info-pos new-contract/info)
|
||||
(contract/info-pos old-contract/info))
|
||||
(eq? (contract/info-neg new-contract/info)
|
||||
(contract/info-neg old-contract/info))
|
||||
(contract-stronger? (contract/info-contract old-contract/info)
|
||||
(contract/info-contract new-contract/info)))
|
||||
#t
|
||||
(already-there? new-contract/info (wrap-get val 0) (- depth 1))))]
|
||||
[else
|
||||
;; when the zeroth field is cleared out, we don't
|
||||
;; have a contract to compare to anymore.
|
||||
|
|
@ -163,10 +185,6 @@
|
|||
(let ([ctc-x (coerce-contract struct/c ctc-x)] ...)
|
||||
(contract-maker ctc-x ...)))
|
||||
|
||||
(define (no-depend-apply-to-fields ctc fields ...)
|
||||
(let ([ctc-x (contract-get ctc selector-indicies)] ...)
|
||||
(values (((proj-get ctc-x) ctc-x) fields) ...)))
|
||||
|
||||
(define (selectors x) (burrow-in x 'selectors selector-indicies)) ...
|
||||
|
||||
(define (burrow-in struct selector-name i)
|
||||
|
|
@ -201,7 +219,8 @@
|
|||
field-count
|
||||
0 ;; auto-field-k
|
||||
'() ;; auto-field-v
|
||||
(list (cons proj-prop lazy-contract-proj)
|
||||
(list (cons pos-proj-prop lazy-contract-pos-proj)
|
||||
(cons neg-proj-prop lazy-contract-neg-proj)
|
||||
(cons name-prop lazy-contract-name)
|
||||
(cons stronger-prop stronger-lazy-contract?)))))))]))
|
||||
|
||||
|
|
@ -212,7 +231,7 @@
|
|||
|
||||
(define (check-sub-contract? x y)
|
||||
(cond
|
||||
[(and (proj-pred? x) (proj-pred? y))
|
||||
[(and (stronger-pred? x) (stronger-pred? y))
|
||||
(contract-stronger? x y)]
|
||||
[(and (procedure? x) (procedure? y))
|
||||
(procedure-closure-contents-eq? x y)]
|
||||
|
|
|
|||
|
|
@ -24,18 +24,23 @@
|
|||
contract?
|
||||
contract-name
|
||||
contract-proc
|
||||
make-contract
|
||||
contract-pos-proc
|
||||
contract-neg-proc
|
||||
make-pair-proj-contract
|
||||
build-flat-contract
|
||||
|
||||
define-struct/prop
|
||||
|
||||
contract-stronger?
|
||||
|
||||
proj-prop proj-pred? proj-get
|
||||
proj-pred? proj-get
|
||||
pos-proj-prop pos-proj-pred? pos-proj-get
|
||||
neg-proj-prop neg-proj-pred? neg-proj-get
|
||||
name-prop name-pred? name-get
|
||||
stronger-prop stronger-pred? stronger-get
|
||||
flat-prop flat-pred? flat-get
|
||||
flat-proj)
|
||||
any-curried-proj
|
||||
flat-pos-proj)
|
||||
|
||||
|
||||
;; define-struct/prop is a define-struct-like macro that
|
||||
|
|
@ -101,13 +106,14 @@
|
|||
(raw-proj-get ctc)]
|
||||
[(and (neg-proj-pred? ctc)
|
||||
(pos-proj-pred? ctc))
|
||||
(let ([pos-abs (pos-proj-get ctc)]
|
||||
[neg-abs (pos-proj-get ctc)])
|
||||
(λ (pos neg src-info str)
|
||||
(let ([p-proj (pos-abs pos src-info str)]
|
||||
[n-proj (neg-abs neg src-info str)])
|
||||
(lambda (v)
|
||||
(n-proj (p-proj v))))))]
|
||||
(let ([pos-abs ((pos-proj-get ctc) ctc)]
|
||||
[neg-abs ((neg-proj-get ctc) ctc)])
|
||||
(λ (ctc)
|
||||
(λ (pos neg src-info str)
|
||||
(let ([p-proj (pos-abs pos src-info str)]
|
||||
[n-proj (neg-abs neg src-info str)])
|
||||
(lambda (v)
|
||||
(n-proj (p-proj v)))))))]
|
||||
[else (error 'proj-get "unknown ~e" ctc)]))
|
||||
|
||||
;; contract-stronger? : contract contract -> boolean
|
||||
|
|
@ -179,7 +185,7 @@
|
|||
exn:fail:contract2?
|
||||
(lambda (x) (get x 0)))))
|
||||
|
||||
(define (default-contract-violation->string val src-info to-blame other-party contract-sexp msg)
|
||||
(define (default-contract-violation->string val src-info to-blame contract-sexp msg)
|
||||
(let ([blame-src (src-info-as-string src-info)]
|
||||
[formatted-contract-sexp
|
||||
(let ([one-line (format "~s" contract-sexp)])
|
||||
|
|
@ -194,13 +200,12 @@
|
|||
[specific-blame
|
||||
(let ([datum (syntax-object->datum src-info)])
|
||||
(if (symbol? datum)
|
||||
(format " on ~a" datum)
|
||||
(format "on ~a" datum)
|
||||
""))])
|
||||
(string-append (format "~a~a broke the contract ~ait had with ~a~a; "
|
||||
(string-append (format "~a~a broke the contract ~a~a; "
|
||||
blame-src
|
||||
to-blame
|
||||
formatted-contract-sexp
|
||||
other-party
|
||||
specific-blame)
|
||||
msg)))
|
||||
|
||||
|
|
@ -213,7 +218,6 @@
|
|||
((contract-violation->string) val
|
||||
src-info
|
||||
to-blame
|
||||
other-party
|
||||
contract-sexp
|
||||
(apply format fmt args)))
|
||||
(current-continuation-marks)
|
||||
|
|
@ -291,24 +295,50 @@
|
|||
val
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
'???
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
name
|
||||
val))))))
|
||||
|
||||
(define (flat-pos-proj ctc)
|
||||
(let ([predicate ((flat-get ctc) ctc)]
|
||||
[name ((name-get ctc) ctc)])
|
||||
(λ (pos src-info orig-str)
|
||||
(λ (val)
|
||||
(if (predicate val)
|
||||
val
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
'???
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
name
|
||||
val))))))
|
||||
|
||||
(define (any-curried-proj ctc) any-curred-proj2)
|
||||
(define (any-curred-proj2 pos src-info orig-str) values)
|
||||
|
||||
(define-values (make-flat-contract
|
||||
make-contract)
|
||||
make-pair-proj-contract)
|
||||
(let ()
|
||||
(define-struct/prop contract (the-name the-proc)
|
||||
((proj-prop (λ (ctc) (contract-the-proc ctc)))
|
||||
(name-prop (λ (ctc) (contract-the-name ctc)))
|
||||
(define-struct/prop pair-proj-contract (the-name pos-proc neg-proc)
|
||||
((pos-proj-prop (λ (ctc) (pair-proj-contract-pos-proc ctc)))
|
||||
(neg-proj-prop (λ (ctc) (pair-proj-contract-neg-proc ctc)))
|
||||
(name-prop (λ (ctc) (pair-proj-contract-the-name ctc)))
|
||||
(stronger-prop (λ (this that)
|
||||
(and (contract? that)
|
||||
(procedure-closure-contents-eq? (contract-the-proc this)
|
||||
(contract-the-proc that)))))))
|
||||
(and (pair-proj-contract? that)
|
||||
(procedure-closure-contents-eq?
|
||||
(pair-proj-contract-pos-proc this)
|
||||
(pair-proj-contract-pos-proc that))
|
||||
(procedure-closure-contents-eq?
|
||||
(pair-proj-contract-neg-proc that)
|
||||
(pair-proj-contract-neg-proc this)))))))
|
||||
(define-struct/prop flat-contract (the-name predicate)
|
||||
((proj-prop flat-proj)
|
||||
((pos-proj-prop flat-pos-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
(stronger-prop (λ (this that)
|
||||
(and (flat-contract? that)
|
||||
(procedure-closure-contents-eq? (flat-contract-predicate this)
|
||||
|
|
@ -316,7 +346,7 @@
|
|||
(name-prop (λ (ctc) (flat-contract-the-name ctc)))
|
||||
(flat-prop (λ (ctc) (flat-contract-predicate ctc)))))
|
||||
(values make-flat-contract
|
||||
make-contract)))
|
||||
make-pair-proj-contract)))
|
||||
|
||||
(define (flat-contract-predicate x)
|
||||
(unless (flat-contract? x)
|
||||
|
|
@ -324,8 +354,10 @@
|
|||
((flat-get x) x))
|
||||
(define (flat-contract? x) (flat-pred? x))
|
||||
(define (contract-name ctc) ((name-get ctc) ctc))
|
||||
(define (contract? x) (proj-pred? x))
|
||||
(define (contract? x) (or (proj-pred? x) (pos-proj-pred? x)))
|
||||
(define (contract-proc ctc) ((proj-get ctc) ctc))
|
||||
(define (contract-pos-proc ctc) ((pos-proj-get ctc) ctc))
|
||||
(define (contract-neg-proc ctc) ((neg-proj-get ctc) ctc))
|
||||
|
||||
(define (flat-contract predicate)
|
||||
(unless (and (procedure? predicate)
|
||||
|
|
@ -395,15 +427,27 @@
|
|||
(not (flat-contract? x))))
|
||||
fs)]
|
||||
[contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
|
||||
[contract/procs (map contract-proc contracts)])
|
||||
[pos-contract/procs (map contract-pos-proc contracts)]
|
||||
[neg-contract/procs (map contract-neg-proc contracts)])
|
||||
(unless (or (null? non-flats)
|
||||
(null? (cdr non-flats)))
|
||||
(error 'and/c "expected at most one non-flat contract as argument"))
|
||||
(make-contract
|
||||
(make-pair-proj-contract
|
||||
(apply build-compound-type-name 'and/c contracts)
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([partial-contracts (map (lambda (contract/proc) (contract/proc pos neg src-info orig-str))
|
||||
contract/procs)])
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([partial-contracts (map (lambda (contract/proc) (contract/proc blame src-info orig-str))
|
||||
pos-contract/procs)])
|
||||
(let loop ([ctct (car partial-contracts)]
|
||||
[rest (cdr partial-contracts)])
|
||||
(cond
|
||||
[(null? rest) ctct]
|
||||
[else
|
||||
(let ([fst (car rest)])
|
||||
(loop (lambda (x) (fst (ctct x)))
|
||||
(cdr rest)))]))))
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([partial-contracts (map (lambda (contract/proc) (contract/proc blame src-info orig-str))
|
||||
neg-contract/procs)])
|
||||
(let loop ([ctct (car partial-contracts)]
|
||||
[rest (cdr partial-contracts)])
|
||||
(cond
|
||||
|
|
@ -414,7 +458,8 @@
|
|||
(cdr rest)))]))))))]))
|
||||
|
||||
(define-struct/prop any/c ()
|
||||
((proj-prop (λ (ctc) (λ (pos neg src-info orig-str) (λ (v) v))))
|
||||
((pos-proj-prop any-curried-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
(stronger-prop (λ (this that) (any/c? that)))
|
||||
(name-prop (λ (ctc) 'any/c))
|
||||
(flat-prop (λ (ctc) (λ (x) #t)))))
|
||||
|
|
|
|||
|
|
@ -2,8 +2,18 @@
|
|||
|
||||
(provide module-source-as-symbol build-src-loc-string mangle-id
|
||||
build-struct-names
|
||||
nums-up-to)
|
||||
nums-up-to
|
||||
add-name-prop
|
||||
all-but-last)
|
||||
|
||||
(define (add-name-prop name stx)
|
||||
(cond
|
||||
[(identifier? name)
|
||||
(syntax-property stx 'inferred-name (syntax-e name))]
|
||||
[(symbol? name)
|
||||
(syntax-property stx 'inferred-name name)]
|
||||
[else stx]))
|
||||
|
||||
;; mangle-id : syntax string syntax ... -> syntax
|
||||
;; constructs a mangled name of an identifier from an identifier
|
||||
;; the name isn't fresh, so `id' combined with `ids' must already be unique.
|
||||
|
|
@ -23,6 +33,19 @@
|
|||
(format "-~a" (syntax-object->datum id)))
|
||||
ids)))))))
|
||||
|
||||
;; (cons X (listof X)) -> (listof X)
|
||||
;; returns the elements of `l', minus the last element
|
||||
;; special case: if l is an improper list, it leaves off
|
||||
;; the contents of the last cdr (ie, making a proper list
|
||||
;; out of the input), so (all-but-last '(1 2 . 3)) = '(1 2)
|
||||
(define (all-but-last l)
|
||||
(cond
|
||||
[(null? l) (error 'all-but-last "bad input")]
|
||||
[(not (pair? l)) '()]
|
||||
[(null? (cdr l)) null]
|
||||
[(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))]
|
||||
[else (list (car l))]))
|
||||
|
||||
;; build-src-loc-string : syntax -> (union #f string)
|
||||
(define (build-src-loc-string stx)
|
||||
(let ([source (syntax-source stx)]
|
||||
|
|
|
|||
|
|
@ -10,6 +10,8 @@ add struct contracts for immutable structs?
|
|||
(module contract mzscheme
|
||||
|
||||
(provide (rename -contract contract)
|
||||
(rename -contract/pos contract/pos)
|
||||
(rename -contract/neg contract/neg)
|
||||
recursive-contract
|
||||
provide/contract
|
||||
define/contract)
|
||||
|
|
@ -94,22 +96,22 @@ add struct contracts for immutable structs?
|
|||
[(_ arg ...)
|
||||
(syntax
|
||||
((begin-lifted
|
||||
(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'neg-stx)
|
||||
(quote-syntax _)))
|
||||
(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'neg-stx)
|
||||
(quote-syntax _)))
|
||||
arg
|
||||
...))]
|
||||
[_
|
||||
(identifier? (syntax _))
|
||||
(syntax
|
||||
(begin-lifted
|
||||
(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'neg-stx)
|
||||
(quote-syntax _))))])))))
|
||||
(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'neg-stx)
|
||||
(quote-syntax _))))])))))
|
||||
|
||||
;; (define/contract id contract expr)
|
||||
;; defines `id' with `contract'; initially binding
|
||||
|
|
@ -556,7 +558,8 @@ add struct contracts for immutable structs?
|
|||
[pos-stx (datum->syntax-object provide-stx 'here)]
|
||||
[id id]
|
||||
[ctrct (syntax-property ctrct 'inferred-name id)]
|
||||
[external-name (or user-rename-id id)])
|
||||
[external-name (or user-rename-id id)]
|
||||
[where-stx stx])
|
||||
(with-syntax ([code
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
|
|
@ -578,9 +581,6 @@ add struct contracts for immutable structs?
|
|||
(begin
|
||||
bodies ...))))]))
|
||||
|
||||
|
||||
|
||||
|
||||
(define (test-proc/flat-contract f x)
|
||||
(if (flat-contract? f)
|
||||
((flat-contract-predicate f) x)
|
||||
|
|
@ -634,16 +634,68 @@ add struct contracts for immutable structs?
|
|||
name))
|
||||
(((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract))
|
||||
name)))
|
||||
|
||||
(define-syntax (-contract/pos stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a-contract to-check blame-e)
|
||||
(with-syntax ([src-loc (syntax/loc stx here)])
|
||||
(syntax/loc stx
|
||||
(contract/one/proc contract-pos-proc a-contract to-check blame-e (quote-syntax src-loc))))]
|
||||
[(_ a-contract-e to-check blame-e src-info-e)
|
||||
(syntax/loc stx
|
||||
(contract/one/proc contract-pos-proc a-contract-e to-check blame-e src-info-e))]))
|
||||
|
||||
(define-syntax (-contract/neg stx)
|
||||
(syntax-case stx ()
|
||||
[(_ a-contract to-check blame-e)
|
||||
(with-syntax ([src-loc (syntax/loc stx here)])
|
||||
(syntax/loc stx
|
||||
(contract/one/proc contract-neg-proc a-contract to-check blame-e (quote-syntax src-loc))))]
|
||||
[(_ a-contract-e to-check blame-e src-info-e)
|
||||
(syntax/loc stx
|
||||
(contract/one/proc contract-neg-proc a-contract-e to-check blame-e src-info-e))]))
|
||||
|
||||
(define (contract/one/proc contract-to-proc a-contract-raw name blame src-info)
|
||||
(unless (or (contract? a-contract-raw)
|
||||
(and (procedure? a-contract-raw)
|
||||
(procedure-arity-includes? a-contract-raw 1)))
|
||||
(error 'contract/pos "expected a contract or a procedure of arity 1 as first argument, given: ~e, other args ~e ~e ~e"
|
||||
a-contract-raw
|
||||
name
|
||||
blame
|
||||
src-info))
|
||||
(let ([a-contract (if (contract? a-contract-raw)
|
||||
a-contract-raw
|
||||
(flat-contract a-contract-raw))])
|
||||
(unless (symbol? blame)
|
||||
(error 'contract
|
||||
"expected symbol as name for assigning blame, given: ~e, other args ~e ~e ~e"
|
||||
blame
|
||||
a-contract-raw
|
||||
name
|
||||
src-info))
|
||||
(unless (syntax? src-info)
|
||||
(error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e"
|
||||
src-info
|
||||
blame
|
||||
a-contract-raw
|
||||
name))
|
||||
(((contract-to-proc a-contract) blame src-info (contract-name a-contract))
|
||||
name)))
|
||||
|
||||
(define-syntax (recursive-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ arg)
|
||||
(syntax (make-contract
|
||||
(syntax (make-pair-proj-contract
|
||||
'(recursive-contract arg)
|
||||
(λ (pos neg src str)
|
||||
(let ([proc (contract-proc arg)])
|
||||
(λ (blame src str)
|
||||
(let ([proc (contract-pos-proc arg)])
|
||||
(λ (val)
|
||||
((proc pos neg src str) val))))))]))
|
||||
((proc blame src str) val))))
|
||||
(λ (blame src str)
|
||||
(let ([proc (contract-neg-proc arg)])
|
||||
(λ (val)
|
||||
((proc blame src str) val))))))]))
|
||||
|
||||
(define (check-contract ctc)
|
||||
(unless (contract? ctc)
|
||||
|
|
@ -798,18 +850,32 @@ add struct contracts for immutable structs?
|
|||
(make-flat-or/c flat-contracts)]))))
|
||||
|
||||
(define-struct/prop or/c (flat-ctcs ho-ctc)
|
||||
((proj-prop (λ (ctc)
|
||||
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(or/c-flat-ctcs ctc))])
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos neg src-info orig-str)])
|
||||
(lambda (val)
|
||||
(cond
|
||||
[(ormap (lambda (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(partial-contract val)])))))))
|
||||
((pos-proj-prop (λ (ctc)
|
||||
(let ([c-proc ((pos-proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(or/c-flat-ctcs ctc))])
|
||||
(lambda (pos src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos src-info orig-str)])
|
||||
(lambda (val)
|
||||
(cond
|
||||
[(ormap (lambda (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(partial-contract val)])))))))
|
||||
(neg-proj-prop
|
||||
(λ (ctc)
|
||||
(let ([c-proc ((neg-proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(or/c-flat-ctcs ctc))])
|
||||
(lambda (pos src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos src-info orig-str)])
|
||||
(lambda (val)
|
||||
(cond
|
||||
[(ormap (lambda (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(partial-contract val)])))))))
|
||||
|
||||
(name-prop (λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
|
|
@ -828,7 +894,8 @@ add struct contracts for immutable structs?
|
|||
that-ctcs)))))))))
|
||||
|
||||
(define-struct/prop flat-or/c (flat-ctcs)
|
||||
((proj-prop flat-proj)
|
||||
((pos-proj-prop flat-pos-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
'or/c
|
||||
|
|
@ -895,7 +962,8 @@ add struct contracts for immutable structs?
|
|||
(printable? (unbox x))))))))
|
||||
|
||||
(define-struct/prop between/c (low high)
|
||||
((proj-prop flat-proj)
|
||||
((pos-proj-prop flat-pos-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(let ([n (between/c-low ctc)]
|
||||
[m (between/c-high ctc)])
|
||||
|
|
@ -995,23 +1063,28 @@ add struct contracts for immutable structs?
|
|||
[fill-name fill])
|
||||
(lambda (input)
|
||||
(let* ([ctc (coerce-contract name input)]
|
||||
[p (contract-proc ctc)])
|
||||
(make-contract
|
||||
[p-proj (contract-pos-proc ctc)]
|
||||
[n-proj (contract-neg-proc ctc)])
|
||||
(make-pair-proj-contract
|
||||
(build-compound-type-name 'name ctc)
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([p-app (p pos neg src-info orig-str)])
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([p-app (p-proj blame src-info orig-str)])
|
||||
(lambda (val)
|
||||
(unless (predicate?-name val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
blame
|
||||
'ignored
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
val))
|
||||
(fill-name p-app val)))))))))]))
|
||||
(fill-name p-app val))))
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([n-app (n-proj blame src-info orig-str)])
|
||||
(lambda (val)
|
||||
(fill-name n-app val)))))))))]))
|
||||
|
||||
(define (map-immutable f lst)
|
||||
(let loop ([lst lst])
|
||||
|
|
@ -1094,31 +1167,40 @@ add struct contracts for immutable structs?
|
|||
(eq? #f (syntax-object->datum (syntax arb?)))
|
||||
(with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(procs ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(pos-procs ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(neg-procs ...) (generate-temporaries (syntax (selectors ...)))]
|
||||
[(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
|
||||
(syntax
|
||||
(let ([predicate?-name predicate?]
|
||||
[constructor-name constructor]
|
||||
[selector-names selectors] ...)
|
||||
(lambda (params ...)
|
||||
(let ([procs (coerce/select-contract name params)] ...)
|
||||
(make-contract
|
||||
(build-compound-type-name 'name (proc/ctc->ctc params) ...)
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([p-apps (procs pos neg src-info orig-str)] ...)
|
||||
(lambda (v)
|
||||
(if (and (immutable? v)
|
||||
(predicate?-name v))
|
||||
(constructor-name (p-apps (selector-names v)) ...)
|
||||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
v)))))))))))]
|
||||
(let ([ctc-x (coerce-contract name params)] ...)
|
||||
(let ([pos-procs (contract-pos-proc ctc-x)]
|
||||
...
|
||||
[neg-procs (contract-neg-proc ctc-x)] ...)
|
||||
(make-pair-proj-contract
|
||||
(build-compound-type-name 'name (proc/ctc->ctc params) ...)
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([p-apps (pos-procs blame src-info orig-str)] ...)
|
||||
(lambda (v)
|
||||
(if (and (immutable? v)
|
||||
(predicate?-name v))
|
||||
(constructor-name (p-apps (selector-names v)) ...)
|
||||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
blame
|
||||
'ignored
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
v)))))
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([p-apps (neg-procs blame src-info orig-str)] ...)
|
||||
(lambda (v)
|
||||
(constructor-name (p-apps (selector-names v)) ...)))))))))))]
|
||||
[(_ predicate? constructor (arb? selector) correct-size type-name name)
|
||||
(eq? #t (syntax-object->datum (syntax arb?)))
|
||||
(syntax
|
||||
|
|
@ -1126,33 +1208,46 @@ add struct contracts for immutable structs?
|
|||
[constructor-name constructor]
|
||||
[selector-name selector])
|
||||
(lambda params
|
||||
(let ([procs (map (lambda (param) (coerce/select-contract name param)) params)])
|
||||
(make-contract
|
||||
(apply build-compound-type-name 'name (map proc/ctc->ctc params))
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([p-apps (map (lambda (proc) (proc pos neg src-info orig-str)) procs)]
|
||||
[count (length params)])
|
||||
(lambda (v)
|
||||
(if (and (immutable? v)
|
||||
(predicate?-name v)
|
||||
(correct-size count v))
|
||||
(apply constructor-name
|
||||
(let loop ([p-apps p-apps]
|
||||
[i 0])
|
||||
(cond
|
||||
[(null? p-apps) null]
|
||||
[else (let ([p-app (car p-apps)])
|
||||
(cons (p-app (selector-name v i))
|
||||
(loop (cdr p-apps) (+ i 1))))])))
|
||||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
v))))))))))]))
|
||||
(let ([ctcs (map (lambda (param) (coerce-contract name param)) params)])
|
||||
(let ([pos-procs (map contract-pos-proc ctcs)]
|
||||
[neg-procs (map contract-neg-proc ctcs)])
|
||||
(make-pair-proj-contract
|
||||
(apply build-compound-type-name 'name (map proc/ctc->ctc params))
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([p-apps (map (lambda (proc) (proc blame src-info orig-str)) pos-procs)]
|
||||
[count (length params)])
|
||||
(lambda (v)
|
||||
(if (and (immutable? v)
|
||||
(predicate?-name v)
|
||||
(correct-size count v))
|
||||
(apply constructor-name
|
||||
(let loop ([p-apps p-apps]
|
||||
[i 0])
|
||||
(cond
|
||||
[(null? p-apps) null]
|
||||
[else (let ([p-app (car p-apps)])
|
||||
(cons (p-app (selector-name v i))
|
||||
(loop (cdr p-apps) (+ i 1))))])))
|
||||
(raise-contract-error
|
||||
v
|
||||
src-info
|
||||
blame
|
||||
'ignored
|
||||
orig-str
|
||||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
v)))))
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([p-apps (map (lambda (proc) (proc blame src-info orig-str)) neg-procs)])
|
||||
(lambda (v)
|
||||
(apply constructor-name
|
||||
(let loop ([p-apps p-apps]
|
||||
[i 0])
|
||||
(cond
|
||||
[(null? p-apps) null]
|
||||
[else (let ([p-app (car p-apps)])
|
||||
(cons (p-app (selector-name v i))
|
||||
(loop (cdr p-apps) (+ i 1))))]))))))))))))]))
|
||||
|
||||
(define cons-immutable/c (*-immutable/c pair? cons-immutable (#f car cdr) immutable-cons cons-immutable/c))
|
||||
(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
|
||||
|
|
@ -1208,21 +1303,26 @@ add struct contracts for immutable structs?
|
|||
(define promise/c
|
||||
(lambda (ctc-in)
|
||||
(let* ([ctc (coerce-contract promise/c ctc-in)]
|
||||
[ctc-proc (contract-proc ctc)])
|
||||
(make-contract
|
||||
[pos-ctc-proc (contract-pos-proc ctc)]
|
||||
[neg-ctc-proc (contract-neg-proc ctc)])
|
||||
(make-pair-proj-contract
|
||||
(build-compound-type-name 'promise/c ctc)
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([p-app (ctc-proc pos neg src-info orig-str)])
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([p-app (pos-ctc-proc blame src-info orig-str)])
|
||||
(lambda (val)
|
||||
(unless (promise? val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
pos
|
||||
neg
|
||||
blame
|
||||
'ignored
|
||||
orig-str
|
||||
"expected <promise>, given: ~e"
|
||||
val))
|
||||
(delay (p-app (force val))))))
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([p-app (neg-ctc-proc blame src-info orig-str)])
|
||||
(lambda (val)
|
||||
(delay (p-app (force val))))))))))
|
||||
|
||||
#|
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user