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

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

Browse Source 
svn: r2524
This commit is contained in:
Robby Findler 2006-03-28 00:38:43 +00:00
parent 5d2e3756c6
commit cf86c57215
5 changed files with 1346 additions and 841 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1704
collects/mzlib/private/contract-arrow.ss
View File

File diff suppressed because it is too large Load Diff

67
collects/mzlib/private/contract-ds.ss
View File

@ -8,12 +8,13 @@
(define-syntax (define-contract-struct stx) (define-syntax (define-contract-struct stx)
(syntax-case stx () (syntax-case stx ()
[(_ name (fields ...)) [(_ name (fields ...))
(syntax (define-contract-struct name (fields ...) (current-inspector)))] (syntax (define-contract-struct name (fields ...) (current-inspector)))]
[(_ name (fields ...) inspector) [(_ name (fields ...) inspector)
(and (identifier? (syntax name)) (and (identifier? (syntax name))
(andmap identifier? (syntax->list (syntax (fields ...))))) (andmap identifier? (syntax->list (syntax (fields ...)))))
(let* ([add-suffix (let* ([mutable? (syntax-e (syntax mutable?))]
[add-suffix
(λ (suffix) (λ (suffix)
(datum->syntax-object (syntax name) (datum->syntax-object (syntax name)
(string->symbol (string->symbol
@ -110,15 +111,20 @@
(wrap-get stct i+1))) (wrap-get stct i+1)))
(define (rewrite-fields contract/info ctc-x ...) (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) (let ([ctc (if (procedure? ctc-field)
(ctc-field f-xs ...) (ctc-field f-xs ...)
ctc-field)]) ctc-field)])
((((proj-get ctc) ctc) (contract/info-pos contract/info) (if (contract/info-pos contract/info)
(contract/info-neg contract/info) ((((pos-proj-get ctc) ctc) (contract/info-pos contract/info)
(contract/info-src-info contract/info) (contract/info-src-info contract/info)
(contract/info-orig-str contract/info)) (contract/info-orig-str contract/info))
ctc-x)))] ...) 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 ...))) (values f-x ...)))
(define (stronger-lazy-contract? a b) (define (stronger-lazy-contract? a b)
@ -127,33 +133,49 @@
(contract-get a selector-indicies) (contract-get a selector-indicies)
(contract-get b selector-indicies)) ...)) (contract-get b selector-indicies)) ...))
(define (lazy-contract-proj ctc) (define (lazy-contract-pos-proj ctc)
(λ (pos neg src-info orig-str) (λ (blame src-info orig-str)
(let ([contract/info (make-contract/info ctc pos neg src-info orig-str)]) (let ([contract/info (make-contract/info ctc blame #f src-info orig-str)])
(λ (val) (λ (val)
(unless (or (wrap-predicate val) (unless (or (wrap-predicate val)
(raw-predicate val)) (raw-predicate val))
(raise-contract-error (raise-contract-error
val val
src-info src-info
pos blame
neg 'ignored
orig-str orig-str
"expected <~a>, got ~e" 'name val)) "expected <~a>, got ~e" 'name val))
(cond (cond
[(already-there? ctc val lazy-depth-to-look) [(already-there? contract/info val lazy-depth-to-look)
val] val]
[else [else
(wrap-maker val contract/info)]))))) (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 (cond
[(raw-predicate val) #f] [(raw-predicate val) #f]
[(zero? depth) #f] [(zero? depth) #f]
[(wrap-get val 0) [(wrap-get val 0)
(if (contract-stronger? (contract/info-contract (wrap-get val 1)) ctc) (let ([old-contract/info (wrap-get val 1)])
#t (if (and (eq? (contract/info-pos new-contract/info)
(already-there? ctc (wrap-get val 0) (- depth 1)))] (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 [else
;; when the zeroth field is cleared out, we don't ;; when the zeroth field is cleared out, we don't
;; have a contract to compare to anymore. ;; have a contract to compare to anymore.
@ -163,10 +185,6 @@
(let ([ctc-x (coerce-contract struct/c ctc-x)] ...) (let ([ctc-x (coerce-contract struct/c ctc-x)] ...)
(contract-maker 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 (selectors x) (burrow-in x 'selectors selector-indicies)) ...
(define (burrow-in struct selector-name i) (define (burrow-in struct selector-name i)
@ -201,7 +219,8 @@
field-count field-count
0 ;; auto-field-k 0 ;; auto-field-k
'() ;; auto-field-v '() ;; 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 name-prop lazy-contract-name)
(cons stronger-prop stronger-lazy-contract?)))))))])) (cons stronger-prop stronger-lazy-contract?)))))))]))
@ -212,7 +231,7 @@
(define (check-sub-contract? x y) (define (check-sub-contract? x y)
(cond (cond
[(and (proj-pred? x) (proj-pred? y)) [(and (stronger-pred? x) (stronger-pred? y))
(contract-stronger? x y)] (contract-stronger? x y)]
[(and (procedure? x) (procedure? y)) [(and (procedure? x) (procedure? y))
(procedure-closure-contents-eq? x y)] (procedure-closure-contents-eq? x y)]

109
collects/mzlib/private/contract-guts.ss
View File

@ -24,18 +24,23 @@
contract? contract?
contract-name contract-name
contract-proc contract-proc
make-contract contract-pos-proc
contract-neg-proc
make-pair-proj-contract
build-flat-contract build-flat-contract
define-struct/prop define-struct/prop
contract-stronger? 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 name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-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 ;; define-struct/prop is a define-struct-like macro that
@ -101,13 +106,14 @@
(raw-proj-get ctc)] (raw-proj-get ctc)]
[(and (neg-proj-pred? ctc) [(and (neg-proj-pred? ctc)
(pos-proj-pred? ctc)) (pos-proj-pred? ctc))
(let ([pos-abs (pos-proj-get ctc)] (let ([pos-abs ((pos-proj-get ctc) ctc)]
[neg-abs (pos-proj-get ctc)]) [neg-abs ((neg-proj-get ctc) ctc)])
(λ (pos neg src-info str) (λ (ctc)
(let ([p-proj (pos-abs pos src-info str)] (λ (pos neg src-info str)
[n-proj (neg-abs neg src-info str)]) (let ([p-proj (pos-abs pos src-info str)]
(lambda (v) [n-proj (neg-abs neg src-info str)])
(n-proj (p-proj v))))))] (lambda (v)
(n-proj (p-proj v)))))))]
[else (error 'proj-get "unknown ~e" ctc)])) [else (error 'proj-get "unknown ~e" ctc)]))
;; contract-stronger? : contract contract -> boolean ;; contract-stronger? : contract contract -> boolean
@ -179,7 +185,7 @@
exn:fail:contract2? exn:fail:contract2?
(lambda (x) (get x 0))))) (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)] (let ([blame-src (src-info-as-string src-info)]
[formatted-contract-sexp [formatted-contract-sexp
(let ([one-line (format "~s" contract-sexp)]) (let ([one-line (format "~s" contract-sexp)])
@ -194,13 +200,12 @@
[specific-blame [specific-blame
(let ([datum (syntax-object->datum src-info)]) (let ([datum (syntax-object->datum src-info)])
(if (symbol? datum) (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 blame-src
to-blame to-blame
formatted-contract-sexp formatted-contract-sexp
other-party
specific-blame) specific-blame)
msg))) msg)))
@ -213,7 +218,6 @@
((contract-violation->string) val ((contract-violation->string) val
src-info src-info
to-blame to-blame
other-party
contract-sexp contract-sexp
(apply format fmt args))) (apply format fmt args)))
(current-continuation-marks) (current-continuation-marks)
@ -291,24 +295,50 @@
val val
src-info src-info
pos pos
neg '???
orig-str orig-str
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
name name
val)))))) 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 (define-values (make-flat-contract
make-contract) make-pair-proj-contract)
(let () (let ()
(define-struct/prop contract (the-name the-proc) (define-struct/prop pair-proj-contract (the-name pos-proc neg-proc)
((proj-prop (λ (ctc) (contract-the-proc ctc))) ((pos-proj-prop (λ (ctc) (pair-proj-contract-pos-proc ctc)))
(name-prop (λ (ctc) (contract-the-name ctc))) (neg-proj-prop (λ (ctc) (pair-proj-contract-neg-proc ctc)))
(name-prop (λ (ctc) (pair-proj-contract-the-name ctc)))
(stronger-prop (λ (this that) (stronger-prop (λ (this that)
(and (contract? that) (and (pair-proj-contract? that)
(procedure-closure-contents-eq? (contract-the-proc this) (procedure-closure-contents-eq?
(contract-the-proc that))))))) (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) (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) (stronger-prop (λ (this that)
(and (flat-contract? that) (and (flat-contract? that)
(procedure-closure-contents-eq? (flat-contract-predicate this) (procedure-closure-contents-eq? (flat-contract-predicate this)
@ -316,7 +346,7 @@
(name-prop (λ (ctc) (flat-contract-the-name ctc))) (name-prop (λ (ctc) (flat-contract-the-name ctc)))
(flat-prop (λ (ctc) (flat-contract-predicate ctc))))) (flat-prop (λ (ctc) (flat-contract-predicate ctc)))))
(values make-flat-contract (values make-flat-contract
make-contract))) make-pair-proj-contract)))
(define (flat-contract-predicate x) (define (flat-contract-predicate x)
(unless (flat-contract? x) (unless (flat-contract? x)
@ -324,8 +354,10 @@
((flat-get x) x)) ((flat-get x) x))
(define (flat-contract? x) (flat-pred? x)) (define (flat-contract? x) (flat-pred? x))
(define (contract-name ctc) ((name-get ctc) ctc)) (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-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) (define (flat-contract predicate)
(unless (and (procedure? predicate) (unless (and (procedure? predicate)
@ -395,15 +427,27 @@
(not (flat-contract? x)))) (not (flat-contract? x))))
fs)] fs)]
[contracts (map (lambda (x) (if (contract? x) x (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) (unless (or (null? non-flats)
(null? (cdr non-flats))) (null? (cdr non-flats)))
(error 'and/c "expected at most one non-flat contract as argument")) (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) (apply build-compound-type-name 'and/c contracts)
(lambda (pos neg src-info orig-str) (lambda (blame src-info orig-str)
(let ([partial-contracts (map (lambda (contract/proc) (contract/proc pos neg src-info orig-str)) (let ([partial-contracts (map (lambda (contract/proc) (contract/proc blame src-info orig-str))
contract/procs)]) 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)] (let loop ([ctct (car partial-contracts)]
[rest (cdr partial-contracts)]) [rest (cdr partial-contracts)])
(cond (cond
@ -414,7 +458,8 @@
(cdr rest)))]))))))])) (cdr rest)))]))))))]))
(define-struct/prop any/c () (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))) (stronger-prop (λ (this that) (any/c? that)))
(name-prop (λ (ctc) 'any/c)) (name-prop (λ (ctc) 'any/c))
(flat-prop (λ (ctc) (λ (x) #t))))) (flat-prop (λ (ctc) (λ (x) #t)))))

25
collects/mzlib/private/contract-helpers.scm
View File

@ -2,8 +2,18 @@
(provide module-source-as-symbol build-src-loc-string mangle-id (provide module-source-as-symbol build-src-loc-string mangle-id
build-struct-names 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 ;; mangle-id : syntax string syntax ... -> syntax
;; constructs a mangled name of an identifier from an identifier ;; constructs a mangled name of an identifier from an identifier
;; the name isn't fresh, so `id' combined with `ids' must already be unique. ;; the name isn't fresh, so `id' combined with `ids' must already be unique.
@ -23,6 +33,19 @@
(format "-~a" (syntax-object->datum id))) (format "-~a" (syntax-object->datum id)))
ids))))))) 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) ;; build-src-loc-string : syntax -> (union #f string)
(define (build-src-loc-string stx) (define (build-src-loc-string stx)
(let ([source (syntax-source stx)] (let ([source (syntax-source stx)]

282
collects/mzlib/private/contract.ss
View File

@ -10,6 +10,8 @@ add struct contracts for immutable structs?
(module contract mzscheme (module contract mzscheme
(provide (rename -contract contract) (provide (rename -contract contract)
(rename -contract/pos contract/pos)
(rename -contract/neg contract/neg)
recursive-contract recursive-contract
provide/contract provide/contract
define/contract) define/contract)
@ -94,22 +96,22 @@ add struct contracts for immutable structs?
[(_ arg ...) [(_ arg ...)
(syntax (syntax
((begin-lifted ((begin-lifted
(-contract contract-id (-contract contract-id
id id
pos-module-source pos-module-source
(module-source-as-symbol #'neg-stx) (module-source-as-symbol #'neg-stx)
(quote-syntax _))) (quote-syntax _)))
arg arg
...))] ...))]
[_ [_
(identifier? (syntax _)) (identifier? (syntax _))
(syntax (syntax
(begin-lifted (begin-lifted
(-contract contract-id (-contract contract-id
id id
pos-module-source pos-module-source
(module-source-as-symbol #'neg-stx) (module-source-as-symbol #'neg-stx)
(quote-syntax _))))]))))) (quote-syntax _))))])))))
;; (define/contract id contract expr) ;; (define/contract id contract expr)
;; defines `id' with `contract'; initially binding ;; defines `id' with `contract'; initially binding
@ -556,7 +558,8 @@ add struct contracts for immutable structs?
[pos-stx (datum->syntax-object provide-stx 'here)] [pos-stx (datum->syntax-object provide-stx 'here)]
[id id] [id id]
[ctrct (syntax-property ctrct 'inferred-name 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 (with-syntax ([code
(syntax/loc stx (syntax/loc stx
(begin (begin
@ -578,9 +581,6 @@ add struct contracts for immutable structs?
(begin (begin
bodies ...))))])) bodies ...))))]))
(define (test-proc/flat-contract f x) (define (test-proc/flat-contract f x)
(if (flat-contract? f) (if (flat-contract? f)
((flat-contract-predicate f) x) ((flat-contract-predicate f) x)
@ -634,16 +634,68 @@ add struct contracts for immutable structs?
name)) name))
(((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract)) (((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract))
name))) 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) (define-syntax (recursive-contract stx)
(syntax-case stx () (syntax-case stx ()
[(_ arg) [(_ arg)
(syntax (make-contract (syntax (make-pair-proj-contract
'(recursive-contract arg) '(recursive-contract arg)
(λ (pos neg src str) (λ (blame src str)
(let ([proc (contract-proc arg)]) (let ([proc (contract-pos-proc arg)])
(λ (val) (λ (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) (define (check-contract ctc)
(unless (contract? ctc) (unless (contract? ctc)
@ -798,18 +850,32 @@ add struct contracts for immutable structs?
(make-flat-or/c flat-contracts)])))) (make-flat-or/c flat-contracts)]))))
(define-struct/prop or/c (flat-ctcs ho-ctc) (define-struct/prop or/c (flat-ctcs ho-ctc)
((proj-prop (λ (ctc) ((pos-proj-prop (λ (ctc)
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))] (let ([c-proc ((pos-proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
[predicates (map (λ (x) ((flat-get x) x)) [predicates (map (λ (x) ((flat-get x) x))
(or/c-flat-ctcs ctc))]) (or/c-flat-ctcs ctc))])
(lambda (pos neg src-info orig-str) (lambda (pos src-info orig-str)
(let ([partial-contract (c-proc pos neg src-info orig-str)]) (let ([partial-contract (c-proc pos src-info orig-str)])
(lambda (val) (lambda (val)
(cond (cond
[(ormap (lambda (pred) (pred val)) predicates) [(ormap (lambda (pred) (pred val)) predicates)
val] val]
[else [else
(partial-contract val)]))))))) (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) (name-prop (λ (ctc)
(apply build-compound-type-name (apply build-compound-type-name
'or/c 'or/c
@ -828,7 +894,8 @@ add struct contracts for immutable structs?
that-ctcs))))))))) that-ctcs)))))))))
(define-struct/prop flat-or/c (flat-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) (name-prop (λ (ctc)
(apply build-compound-type-name (apply build-compound-type-name
'or/c 'or/c
@ -895,7 +962,8 @@ add struct contracts for immutable structs?
(printable? (unbox x)))))))) (printable? (unbox x))))))))
(define-struct/prop between/c (low high) (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) (name-prop (λ (ctc)
(let ([n (between/c-low ctc)] (let ([n (between/c-low ctc)]
[m (between/c-high ctc)]) [m (between/c-high ctc)])
@ -995,23 +1063,28 @@ add struct contracts for immutable structs?
[fill-name fill]) [fill-name fill])
(lambda (input) (lambda (input)
(let* ([ctc (coerce-contract name input)] (let* ([ctc (coerce-contract name input)]
[p (contract-proc ctc)]) [p-proj (contract-pos-proc ctc)]
(make-contract [n-proj (contract-neg-proc ctc)])
(make-pair-proj-contract
(build-compound-type-name 'name ctc) (build-compound-type-name 'name ctc)
(lambda (pos neg src-info orig-str) (lambda (blame src-info orig-str)
(let ([p-app (p pos neg src-info orig-str)]) (let ([p-app (p-proj blame src-info orig-str)])
(lambda (val) (lambda (val)
(unless (predicate?-name val) (unless (predicate?-name val)
(raise-contract-error (raise-contract-error
val val
src-info src-info
pos blame
neg 'ignored
orig-str orig-str
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
'type-name 'type-name
val)) 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) (define (map-immutable f lst)
(let loop ([lst lst]) (let loop ([lst lst])
@ -1094,31 +1167,40 @@ add struct contracts for immutable structs?
(eq? #f (syntax-object->datum (syntax arb?))) (eq? #f (syntax-object->datum (syntax arb?)))
(with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))] (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
[(p-apps ...) (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 ...)))]) [(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
(syntax (syntax
(let ([predicate?-name predicate?] (let ([predicate?-name predicate?]
[constructor-name constructor] [constructor-name constructor]
[selector-names selectors] ...) [selector-names selectors] ...)
(lambda (params ...) (lambda (params ...)
(let ([procs (coerce/select-contract name params)] ...) (let ([ctc-x (coerce-contract name params)] ...)
(make-contract (let ([pos-procs (contract-pos-proc ctc-x)]
(build-compound-type-name 'name (proc/ctc->ctc params) ...) ...
(lambda (pos neg src-info orig-str) [neg-procs (contract-neg-proc ctc-x)] ...)
(let ([p-apps (procs pos neg src-info orig-str)] ...) (make-pair-proj-contract
(lambda (v) (build-compound-type-name 'name (proc/ctc->ctc params) ...)
(if (and (immutable? v) (lambda (blame src-info orig-str)
(predicate?-name v)) (let ([p-apps (pos-procs blame src-info orig-str)] ...)
(constructor-name (p-apps (selector-names v)) ...) (lambda (v)
(raise-contract-error (if (and (immutable? v)
v (predicate?-name v))
src-info (constructor-name (p-apps (selector-names v)) ...)
pos (raise-contract-error
neg v
orig-str src-info
"expected <~a>, given: ~e" blame
'type-name 'ignored
v)))))))))))] 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) [(_ predicate? constructor (arb? selector) correct-size type-name name)
(eq? #t (syntax-object->datum (syntax arb?))) (eq? #t (syntax-object->datum (syntax arb?)))
(syntax (syntax
@ -1126,33 +1208,46 @@ add struct contracts for immutable structs?
[constructor-name constructor] [constructor-name constructor]
[selector-name selector]) [selector-name selector])
(lambda params (lambda params
(let ([procs (map (lambda (param) (coerce/select-contract name param)) params)]) (let ([ctcs (map (lambda (param) (coerce-contract name param)) params)])
(make-contract (let ([pos-procs (map contract-pos-proc ctcs)]
(apply build-compound-type-name 'name (map proc/ctc->ctc params)) [neg-procs (map contract-neg-proc ctcs)])
(lambda (pos neg src-info orig-str) (make-pair-proj-contract
(let ([p-apps (map (lambda (proc) (proc pos neg src-info orig-str)) procs)] (apply build-compound-type-name 'name (map proc/ctc->ctc params))
[count (length params)]) (lambda (blame src-info orig-str)
(lambda (v) (let ([p-apps (map (lambda (proc) (proc blame src-info orig-str)) pos-procs)]
(if (and (immutable? v) [count (length params)])
(predicate?-name v) (lambda (v)
(correct-size count v)) (if (and (immutable? v)
(apply constructor-name (predicate?-name v)
(let loop ([p-apps p-apps] (correct-size count v))
[i 0]) (apply constructor-name
(cond (let loop ([p-apps p-apps]
[(null? p-apps) null] [i 0])
[else (let ([p-app (car p-apps)]) (cond
(cons (p-app (selector-name v i)) [(null? p-apps) null]
(loop (cdr p-apps) (+ i 1))))]))) [else (let ([p-app (car p-apps)])
(raise-contract-error (cons (p-app (selector-name v i))
v (loop (cdr p-apps) (+ i 1))))])))
src-info (raise-contract-error
pos v
neg src-info
orig-str blame
"expected <~a>, given: ~e" 'ignored
'type-name orig-str
v))))))))))])) "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 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)) (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 (define promise/c
(lambda (ctc-in) (lambda (ctc-in)
(let* ([ctc (coerce-contract promise/c ctc-in)] (let* ([ctc (coerce-contract promise/c ctc-in)]
[ctc-proc (contract-proc ctc)]) [pos-ctc-proc (contract-pos-proc ctc)]
(make-contract [neg-ctc-proc (contract-neg-proc ctc)])
(make-pair-proj-contract
(build-compound-type-name 'promise/c ctc) (build-compound-type-name 'promise/c ctc)
(lambda (pos neg src-info orig-str) (lambda (blame src-info orig-str)
(let ([p-app (ctc-proc pos neg src-info orig-str)]) (let ([p-app (pos-ctc-proc blame src-info orig-str)])
(lambda (val) (lambda (val)
(unless (promise? val) (unless (promise? val)
(raise-contract-error (raise-contract-error
val val
src-info src-info
pos blame
neg 'ignored
orig-str orig-str
"expected <promise>, given: ~e" "expected <promise>, given: ~e"
val)) 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)))))))))) (delay (p-app (force val))))))))))
#| #|