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

extended or/c to support multiple higher-order contracts

Browse Source 
svn: r3606
This commit is contained in:
Robby Findler 2006-07-06 02:08:12 +00:00
parent 8fa40a972a
commit 79ae279b79
7 changed files with 778 additions and 286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mzlib/contract.ss
View File

@ -9,5 +9,7 @@
(all-from "private/contract-ds.ss") (all-from "private/contract-ds.ss")
(all-from "private/contract-arrow.ss") (all-from "private/contract-arrow.ss")
(all-from-except "private/contract-guts.ss" (all-from-except "private/contract-guts.ss"
build-compound-type-name) build-compound-type-name
first-order-prop
first-order-get)
(all-from "private/contract.ss"))) (all-from "private/contract.ss")))

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

@ -32,10 +32,10 @@
(raise-syntax-error 'any "Use any out of an arrow contract" stx)) (raise-syntax-error 'any "Use any out of an arrow contract" stx))
;; FIXME: need to pass in the name of the contract combinator. ;; FIXME: need to pass in the name of the contract combinator.
(define (build--> doms doms-rest rngs rng-any? func) (define (build--> name doms doms-rest rngs rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract -> dom)) doms)] (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
[rngs/c (map (λ (rng) (coerce-contract -> rng)) rngs)] [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
[doms-rest/c (and doms-rest (coerce-contract -> doms-rest))]) [doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
(make--> rng-any? doms/c doms-rest/c rngs/c func))) (make--> rng-any? doms/c doms-rest/c rngs/c func)))
(define-struct/prop -> (rng-any? doms dom-rest rngs func) (define-struct/prop -> (rng-any? doms dom-rest rngs func)
@ -79,6 +79,16 @@
(->-dom-rest ctc) (->-dom-rest ctc)
(->-rng-any? ctc) (->-rng-any? ctc)
(->-rngs ctc)))) (->-rngs ctc))))
(first-order-prop
(λ (ctc)
(let ([l (length (->-doms ctc))])
(if (->-dom-rest ctc)
(λ (x)
(and (procedure? x)
(procedure-accepts-and-more? x l)))
(λ (x)
(and (procedure? x)
(procedure-arity-includes? x l)))))))
(stronger-prop (stronger-prop
(λ (this that) (λ (this that)
(and (->? that) (and (->? that)
@ -137,7 +147,8 @@
(chk val) (chk val)
inner-lambda)))]) inner-lambda)))])
(values (values
(syntax (build--> (list dom-ctcs ...) (syntax (build--> '->
(list dom-ctcs ...)
#f #f
(list rng-ctcs ...) (list rng-ctcs ...)
use-any? use-any?
@ -213,7 +224,8 @@
(lambda (val) (lambda (val)
(chk val) (chk val)
inner-lambda)))]) inner-lambda)))])
(values (syntax (build--> (list doms ...) (values (syntax (build--> '->*
(list doms ...)
rst rst
(list rngs ...) (list rngs ...)
#f #f
@ -238,7 +250,8 @@
(lambda (val) (lambda (val)
(chk val) (chk val)
inner-lambda)))]) inner-lambda)))])
(values (syntax (build--> (list doms ...) (values (syntax (build--> '->*
(list doms ...)
rst rst
(list any/c) (list any/c)
#t #t
@ -246,6 +259,9 @@
inner-args/body inner-args/body
(syntax (dom-x ... rst-x)))))))]))) (syntax (dom-x ... rst-x)))))))])))
(define empty-case-lambda/c
(flat-named-contract '(case->)
(λ (x) (and (procedure? x) (null? (procedure-arity x))))))
(define-syntax-set (->/real ->*/real ->d ->d* ->r ->pp ->pp-rest case-> object-contract opt-> opt->*) (define-syntax-set (->/real ->*/real ->d ->d* ->r ->pp ->pp-rest case-> object-contract opt-> opt->*)
@ -278,7 +294,10 @@
;; syntax ;; syntax
;; -> (syntax -> syntax) ;; -> (syntax -> syntax)
(define (make-/proc method-proc? /h stx) (define (make-/proc method-proc? /h stx)
(let-values ([(arguments-check build-pos-proj build-neg-proj check-val pos-wrapper neg-wrapper) (/h method-proc? stx)]) (let-values ([(arguments-check build-pos-proj build-neg-proj
check-val first-order-check
pos-wrapper neg-wrapper)
(/h method-proc? stx)])
(let ([outer-args (syntax (val blame src-info orig-str name-id))]) (let ([outer-args (syntax (val blame src-info orig-str name-id))])
(with-syntax ([inner-check (check-val outer-args)] (with-syntax ([inner-check (check-val outer-args)]
[(val blame src-info orig-str name-id) outer-args] [(val blame src-info orig-str name-id) outer-args]
@ -302,7 +321,8 @@
(lambda (val) (lambda (val)
inner-neg-lambda))]) inner-neg-lambda))])
(with-syntax ([pos-proj-code (build-pos-proj outer-args inner-pos-lambda-w/err-check)] (with-syntax ([pos-proj-code (build-pos-proj outer-args inner-pos-lambda-w/err-check)]
[neg-proj-code (build-neg-proj outer-args inner-neg-lambda)]) [neg-proj-code (build-neg-proj outer-args inner-neg-lambda)]
[first-order-check first-order-check])
(arguments-check (arguments-check
outer-args outer-args
(syntax/loc stx (syntax/loc stx
@ -311,16 +331,22 @@
(lambda (blame src-info orig-str) (lambda (blame src-info orig-str)
pos-proj-code) pos-proj-code)
(lambda (blame src-info orig-str) (lambda (blame src-info orig-str)
neg-proj-code))))))))))) neg-proj-code)
first-order-check))))))))))
(define (make-case->/proc method-proc? stx inferred-name-stx) (define (make-case->/proc method-proc? stx inferred-name-stx)
(syntax-case stx () (syntax-case stx ()
;; if there are no cases, this contract should only accept the "empty" case-lambda.
[(_) (syntax empty-case-lambda/c)]
;; if there is only a single case, just skip it. ;; if there is only a single case, just skip it.
[(_ case) (syntax case)] [(_ case) (syntax case)]
[(_ cases ...) [(_ cases ...)
(let-values ([(arguments-check build-pos-projs build-neg-projs check-val pos-wrapper neg-wrapper) (let-values ([(arguments-check build-pos-projs build-neg-projs
check-val first-order-check
pos-wrapper neg-wrapper)
(case->/h method-proc? stx (syntax->list (syntax (cases ...))))]) (case->/h method-proc? stx (syntax->list (syntax (cases ...))))])
(let ([outer-args (syntax (val blame src-info orig-str name-id))]) (let ([outer-args (syntax (val blame src-info orig-str name-id))])
(with-syntax ([(inner-check ...) (check-val outer-args)] (with-syntax ([(inner-check ...) (check-val outer-args)]
@ -342,7 +368,8 @@
inner-pos-lambda))] inner-pos-lambda))]
[inner-neg-lambda (syntax (lambda (val) inner-neg-lambda))]) [inner-neg-lambda (syntax (lambda (val) inner-neg-lambda))])
(with-syntax ([pos-proj-code (build-pos-projs outer-args inner-pos-lambda-w/err-check)] (with-syntax ([pos-proj-code (build-pos-projs outer-args inner-pos-lambda-w/err-check)]
[neg-proj-code (build-neg-projs outer-args inner-neg-lambda)]) [neg-proj-code (build-neg-projs outer-args inner-neg-lambda)]
[first-order-check first-order-check])
(arguments-check (arguments-check
outer-args outer-args
(syntax/loc stx (syntax/loc stx
@ -351,7 +378,8 @@
(lambda (blame src-info orig-str) (lambda (blame src-info orig-str)
pos-proj-code) pos-proj-code)
(lambda (blame src-info orig-str) (lambda (blame src-info orig-str)
neg-proj-code))))))))))])) neg-proj-code)
first-order-check)))))))))]))
(define (make-opt->/proc method-proc? stx) (define (make-opt->/proc method-proc? stx)
(syntax-case stx (any) (syntax-case stx (any)
@ -506,14 +534,19 @@
(lambda (x y) y) (lambda (x y) y)
(lambda (x y) y) (lambda (x y) y)
(lambda (args) (syntax ())) (lambda (args) (syntax ()))
(syntax (lambda (x) #t))
(lambda (args) (syntax ())) (lambda (args) (syntax ()))
(lambda (args) (syntax ())))] (lambda (args) (syntax ())))]
[else [else
(let ([/h (select/h (car cases) 'case-> orig-stx)] (let ([/h (select/h (car cases) 'case-> orig-stx)]
[new-id (car (generate-temporaries (syntax (case->name-id))))]) [new-id (car (generate-temporaries (syntax (case->name-id))))])
(let-values ([(arguments-checks build-pos-projs build-neg-projs check-vals pos-wrappers neg-wrappers) (let-values ([(arguments-checks build-pos-projs build-neg-projs
check-vals first-order-checks
pos-wrappers neg-wrappers)
(loop (cdr cases) (cons new-id name-ids))] (loop (cdr cases) (cons new-id name-ids))]
[(arguments-check build-pos-proj build-neg-proj check-val pos-wrapper neg-wrapper) [(arguments-check build-pos-proj build-neg-proj
check-val first-order-check
pos-wrapper neg-wrapper)
(/h method-proc? (car cases))]) (/h method-proc? (car cases))])
(values (values
(lambda (outer-args x) (lambda (outer-args x)
@ -530,6 +563,9 @@
(with-syntax ([checks (check-vals args)] (with-syntax ([checks (check-vals args)]
[check (check-val args)]) [check (check-val args)])
(syntax (check . checks)))) (syntax (check . checks))))
(with-syntax ([checks first-order-checks]
[check first-order-check])
(syntax (lambda (x) (and (checks x) (check x)))))
(lambda (args) (lambda (args)
(with-syntax ([case (pos-wrapper args)] (with-syntax ([case (pos-wrapper args)]
[cases (pos-wrappers args)]) [cases (pos-wrappers args)])
@ -820,7 +856,7 @@
(syntax (syntax
(let ([method-ctc-var method-ctc-stx] (let ([method-ctc-var method-ctc-stx]
... ...
[field-ctc-var (coerce-contract object-contract field-ctc-stx)] [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...) ...)
(let ([method-pos-var (contract-pos-proc method-ctc-var)] (let ([method-pos-var (contract-pos-proc method-ctc-var)]
... ...
@ -877,7 +913,8 @@
val val
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ... (field/app-var (get-field field-name val)) ...
)))))))))))))])) ))))))
#f)))))))]))
;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void ;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void
(define (ensure-no-duplicates stx form-name names) (define (ensure-no-duplicates stx form-name names)
@ -933,6 +970,9 @@
;; - [check-val] ;; - [check-val]
;; code that does error checking on the contract'd value itself ;; code that does error checking on the contract'd value itself
;; (is it a function of the right arity?) ;; (is it a function of the right arity?)
;; - [first-order-check]
;; predicate function that does the first order check and returns a boolean
;; (is it a function of the right arity?)
;; - [pos-wrapper] ;; - [pos-wrapper]
;; a piece of syntax that has the arguments to the wrapper ;; a piece of syntax that has the arguments to the wrapper
;; and the body of the wrapper. ;; and the body of the wrapper.
@ -982,7 +1022,7 @@
(with-syntax ([body body] (with-syntax ([body body]
[(val blame src-info orig-str name-id) outer-args]) [(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(let ([dom-contract-x (coerce-contract -> dom)] ...) (let ([dom-contract-x (coerce-contract '-> dom)] ...)
(let ([dom-pos-x (contract-pos-proc dom-contract-x)] (let ([dom-pos-x (contract-pos-proc dom-contract-x)]
... ...
[dom-neg-x (contract-neg-proc dom-contract-x)] ...) [dom-neg-x (contract-neg-proc dom-contract-x)] ...)
@ -1009,7 +1049,7 @@
(with-syntax ([(val blame src-info orig-str name-id) outer-args]) (with-syntax ([(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length src-info blame orig-str)))) (check-procedure val dom-length src-info blame orig-str))))
(syntax (check-procedure? dom-length))
wrap wrap
wrap))] wrap))]
[(values rng ...) [(values rng ...)
@ -1034,9 +1074,9 @@
(with-syntax ([body body] (with-syntax ([body body]
[(val blame src-info orig-str name-id) outer-args]) [(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(let ([dom-contract-x (coerce-contract -> dom)] (let ([dom-contract-x (coerce-contract '-> dom)]
... ...
[rng-contract-x (coerce-contract -> rng)] ...) [rng-contract-x (coerce-contract '-> rng)] ...)
(let ([dom-pos-x (contract-pos-proc dom-contract-x)] (let ([dom-pos-x (contract-pos-proc dom-contract-x)]
... ...
[dom-neg-x (contract-neg-proc dom-contract-x)] [dom-neg-x (contract-neg-proc dom-contract-x)]
@ -1075,7 +1115,7 @@
(with-syntax ([(val blame src-info orig-str name-id) outer-args]) (with-syntax ([(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length src-info blame orig-str)))) (check-procedure val dom-length src-info blame orig-str))))
(syntax (check-procedure? dom-length))
wrap wrap
wrap)))] wrap)))]
[rng [rng
@ -1097,9 +1137,9 @@
(with-syntax ([body body] (with-syntax ([body body]
[(val blame src-info orig-str name-id) outer-args]) [(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(let ([dom-contract-x (coerce-contract -> dom)] (let ([dom-contract-x (coerce-contract '-> dom)]
... ...
[rng-contract-x (coerce-contract -> rng)]) [rng-contract-x (coerce-contract '-> rng)])
(let ([dom-pos-x (contract-pos-proc dom-contract-x)] (let ([dom-pos-x (contract-pos-proc dom-contract-x)]
... ...
[dom-neg-x (contract-neg-proc dom-contract-x)] [dom-neg-x (contract-neg-proc dom-contract-x)]
@ -1133,7 +1173,7 @@
(with-syntax ([(val blame src-info orig-str name-id) outer-args]) (with-syntax ([(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length src-info blame orig-str)))) (check-procedure val dom-length src-info blame orig-str))))
(syntax (check-procedure? dom-length))
wrap wrap
wrap)))])))])) wrap)))])))]))
@ -1188,9 +1228,10 @@
(syntax (dom-contract-x ...)))) (syntax (dom-contract-x ...))))
(syntax (dom-contract-x ...)))]) (syntax (dom-contract-x ...)))])
(syntax (syntax
(let ([dom-contract-x (coerce-contract ->* dom)] ... (let ([dom-contract-x (coerce-contract '->* dom)]
[dom-rest-contract-x (coerce-contract ->* rest)] ...
[rng-contract-x (coerce-contract ->* rng)] ...) [dom-rest-contract-x (coerce-contract '->* rest)]
[rng-contract-x (coerce-contract '->* rng)] ...)
(let ([dom-pos-x (contract-pos-proc dom-contract-x)] (let ([dom-pos-x (contract-pos-proc dom-contract-x)]
... ...
[dom-neg-x (contract-neg-proc dom-contract-x)] [dom-neg-x (contract-neg-proc dom-contract-x)]
@ -1234,7 +1275,7 @@
(with-syntax ([(val blame src-info orig-str name-id) outer-args]) (with-syntax ([(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure/more val dom-length src-info blame orig-str)))) (check-procedure/more val dom-length src-info blame orig-str))))
(syntax (check-procedure/more? dom-length))
wrap wrap
wrap)))] wrap)))]
[(_ (dom ...) rest any) [(_ (dom ...) rest any)
@ -1273,9 +1314,9 @@
(syntax (dom-contract-x ...)))) (syntax (dom-contract-x ...))))
(syntax (dom-contract-x ...)))]) (syntax (dom-contract-x ...)))])
(syntax (syntax
(let ([dom-contract-x (coerce-contract ->* dom)] (let ([dom-contract-x (coerce-contract '->* dom)]
... ...
[dom-rest-contract-x (coerce-contract ->* rest)]) [dom-rest-contract-x (coerce-contract '->* rest)])
(let ([dom-pos-x (contract-pos-proc dom-contract-x)] (let ([dom-pos-x (contract-pos-proc dom-contract-x)]
... ...
[dom-neg-x (contract-neg-proc dom-contract-x)] [dom-neg-x (contract-neg-proc dom-contract-x)]
@ -1312,6 +1353,7 @@
(with-syntax ([(val blame src-info orig-str name-id) outer-args]) (with-syntax ([(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure/more val dom-length src-info blame orig-str)))) (check-procedure/more val dom-length src-info blame orig-str))))
(syntax (check-procedure/more? dom-length))
wrap wrap
wrap)))])) wrap)))]))
@ -1338,7 +1380,7 @@
(syntax (dom-contract-x ...)))) (syntax (dom-contract-x ...))))
(syntax (dom-contract-x ...)))]) (syntax (dom-contract-x ...)))])
(syntax (syntax
(let ([dom-contract-x (coerce-contract ->d dom)] ...) (let ([dom-contract-x (coerce-contract '->d dom)] ...)
(let ([dom-pos-x (contract-pos-proc dom-contract-x)] (let ([dom-pos-x (contract-pos-proc dom-contract-x)]
... ...
[dom-neg-x (contract-neg-proc dom-contract-x)] ... [dom-neg-x (contract-neg-proc dom-contract-x)] ...
@ -1368,6 +1410,8 @@
(syntax (syntax
(check-procedure val arity src-info blame orig-str)))) (check-procedure val arity src-info blame orig-str))))
(syntax (check-procedure? arity))
;; pos ;; pos
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val blame src-info orig-str name-id) outer-args]) (with-syntax ([(val blame src-info orig-str name-id) outer-args])
@ -1375,7 +1419,7 @@
((arg-x ...) ((arg-x ...)
(let ([arg-x (dom-projection-x arg-x)] ...) (let ([arg-x (dom-projection-x arg-x)] ...)
(let ([rng-contract (rng-x arg-x ...)]) (let ([rng-contract (rng-x arg-x ...)])
(((contract-pos-proc (coerce-contract ->d rng-contract)) (((contract-pos-proc (coerce-contract '->d rng-contract))
blame blame
src-info src-info
orig-str) orig-str)
@ -1388,7 +1432,7 @@
((arg-x ...) ((arg-x ...)
(let ([arg-x (dom-projection-x arg-x)] ...) (let ([arg-x (dom-projection-x arg-x)] ...)
(let ([rng-contract (rng-x arg-x ...)]) (let ([rng-contract (rng-x arg-x ...)])
(((contract-neg-proc (coerce-contract ->d rng-contract)) (((contract-neg-proc (coerce-contract '->d rng-contract))
blame blame
src-info src-info
orig-str) orig-str)
@ -1423,7 +1467,7 @@
(apply (apply
values values
(map (lambda (rng-contract result) (map (lambda (rng-contract result)
(((extract-proc (coerce-contract ->d* rng-contract)) (((extract-proc (coerce-contract '->d* rng-contract))
blame blame
src-info src-info
orig-str) orig-str)
@ -1441,7 +1485,7 @@
(syntax (dom-contract-x ...)))) (syntax (dom-contract-x ...))))
(syntax (dom-contract-x ...)))]) (syntax (dom-contract-x ...)))])
(syntax (syntax
(let ([dom-contract-x (coerce-contract ->d* dom)] ...) (let ([dom-contract-x (coerce-contract '->d* dom)] ...)
(let ([dom-pos-x (contract-pos-proc dom-contract-x)] (let ([dom-pos-x (contract-pos-proc dom-contract-x)]
... ...
[dom-neg-x (contract-neg-proc dom-contract-x)] ... [dom-neg-x (contract-neg-proc dom-contract-x)] ...
@ -1473,7 +1517,7 @@
(with-syntax ([(val blame src-info orig-str name-id) outer-args]) (with-syntax ([(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length src-info blame orig-str)))) (check-procedure val dom-length src-info blame orig-str))))
(syntax (check-procedure? dom-length))
(mk-wrap (syntax contract-pos-proc)) (mk-wrap (syntax contract-pos-proc))
(mk-wrap (syntax contract-neg-proc)))))] (mk-wrap (syntax contract-neg-proc)))))]
[(_ (dom ...) rest rng-mk) [(_ (dom ...) rest rng-mk)
@ -1510,7 +1554,7 @@
(apply (apply
values values
(map (lambda (rng-contract result) (map (lambda (rng-contract result)
(((extract-proj (coerce-contract ->d* rng-contract)) (((extract-proj (coerce-contract '->d* rng-contract))
blame blame
src-info src-info
orig-str) orig-str)
@ -1528,9 +1572,9 @@
(syntax (dom-contract-x ...)))) (syntax (dom-contract-x ...))))
(syntax (dom-contract-x ...)))]) (syntax (dom-contract-x ...)))])
(syntax (syntax
(let ([dom-contract-x (coerce-contract ->d* dom)] (let ([dom-contract-x (coerce-contract '->d* dom)]
... ...
[dom-rest-contract-x (coerce-contract ->d* rest)]) [dom-rest-contract-x (coerce-contract '->d* rest)])
(let ([dom-pos-x (contract-pos-proc dom-contract-x)] (let ([dom-pos-x (contract-pos-proc dom-contract-x)]
... ...
[dom-neg-x (contract-neg-proc dom-contract-x)] ... [dom-neg-x (contract-neg-proc dom-contract-x)] ...
@ -1569,6 +1613,7 @@
(with-syntax ([(val blame src-info orig-str name-id) outer-args]) (with-syntax ([(val blame src-info orig-str name-id) outer-args])
(syntax (syntax
(check-procedure/more val arity src-info blame orig-str)))) (check-procedure/more val arity src-info blame orig-str))))
(syntax (check-procedure/more? arity))
(mk-wrap (syntax contract-pos-proc)) (mk-wrap (syntax contract-pos-proc))
(mk-wrap (syntax contract-neg-proc)))))])) (mk-wrap (syntax contract-neg-proc)))))]))
@ -1633,6 +1678,9 @@
(syntax (syntax
(begin (begin
(check-procedure/kind val arity 'kind-of-thing src-info blame orig-str))))) (check-procedure/kind val arity 'kind-of-thing src-info blame orig-str)))))
(syntax (check-procedure? arity))
;; pos ;; pos
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val blame src-info orig-str name-id) outer-args]) (with-syntax ([(val blame src-info orig-str name-id) outer-args])
@ -1640,7 +1688,7 @@
[(any) [(any)
(syntax (syntax
((x ...) ((x ...)
(let ([dom-id ((contract-neg-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-neg-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
...) ...)
(val (dom-id x) ...))))] (val (dom-id x) ...))))]
[((values (rng-ids rng-ctc) ...) post-expr) [((values (rng-ids rng-ctc) ...) post-expr)
@ -1650,11 +1698,11 @@
(syntax (syntax
((x ...) ((x ...)
(begin (begin
(let ([dom-id ((contract-neg-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-neg-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
...) ...)
(let-values ([(rng-ids ...) (val (dom-id x) ...)]) (let-values ([(rng-ids ...) (val (dom-id x) ...)])
(check-post-expr->pp/h val post-expr src-info blame orig-str) (check-post-expr->pp/h val post-expr src-info blame orig-str)
(let ([rng-ids-x ((contract-pos-proc (coerce-contract stx-name rng-ctc)) (let ([rng-ids-x ((contract-pos-proc (coerce-contract 'stx-name rng-ctc))
blame src-info orig-str)] ...) blame src-info orig-str)] ...)
(values (rng-ids-x rng-ids) ...))))))))] (values (rng-ids-x rng-ids) ...))))))))]
[((values (rng-ids rng-ctc) ...) post-expr) [((values (rng-ids rng-ctc) ...) post-expr)
@ -1671,9 +1719,9 @@
[(rng res-id post-expr) [(rng res-id post-expr)
(syntax (syntax
((x ...) ((x ...)
(let ([dom-id ((contract-neg-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-neg-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
... ...
[rng-id ((contract-pos-proc (coerce-contract stx-name rng)) blame src-info orig-str)]) [rng-id ((contract-pos-proc (coerce-contract 'stx-name rng)) blame src-info orig-str)])
(let ([res-id (rng-id (val (dom-id x) ...))]) (let ([res-id (rng-id (val (dom-id x) ...))])
(check-post-expr->pp/h val post-expr src-info blame orig-str) (check-post-expr->pp/h val post-expr src-info blame orig-str)
res-id))))] res-id))))]
@ -1689,7 +1737,7 @@
((x ...) ((x ...)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info blame orig-str) (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(let ([dom-id ((contract-pos-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-pos-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
...) ...)
(val (dom-id x) ...)))))] (val (dom-id x) ...)))))]
[((values (rng-ids rng-ctc) ...) post-expr) [((values (rng-ids rng-ctc) ...) post-expr)
@ -1700,10 +1748,10 @@
((x ...) ((x ...)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info blame orig-str) (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(let ([dom-id ((contract-pos-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-pos-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
...) ...)
(let-values ([(rng-ids ...) (val (dom-id x) ...)]) (let-values ([(rng-ids ...) (val (dom-id x) ...)])
(let ([rng-ids-x ((contract-neg-proc (coerce-contract stx-name rng-ctc)) (let ([rng-ids-x ((contract-neg-proc (coerce-contract 'stx-name rng-ctc))
blame src-info orig-str)] ...) blame src-info orig-str)] ...)
(values (rng-ids-x rng-ids) ...))))))))] (values (rng-ids-x rng-ids) ...))))))))]
[((values (rng-ids rng-ctc) ...) post-expr) [((values (rng-ids rng-ctc) ...) post-expr)
@ -1722,9 +1770,9 @@
((x ...) ((x ...)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info blame orig-str) (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(let ([dom-id ((contract-pos-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-pos-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
... ...
[rng-id ((contract-neg-proc (coerce-contract stx-name rng)) blame src-info orig-str)]) [rng-id ((contract-neg-proc (coerce-contract 'stx-name rng)) blame src-info orig-str)])
(rng-id (val (dom-id x) ...))))))] (rng-id (val (dom-id x) ...))))))]
[_ [_
(raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))]
@ -1785,6 +1833,7 @@
(syntax (syntax
(begin (begin
(check-procedure/more/kind val arity 'kind-of-thing src-info blame orig-str))))) (check-procedure/more/kind val arity 'kind-of-thing src-info blame orig-str)))))
(syntax (check-procedure/more? arity))
;; pos ;; pos
(lambda (outer-args) (lambda (outer-args)
@ -1793,9 +1842,9 @@
[(any) [(any)
(syntax (syntax
((x ... . rest-x) ((x ... . rest-x)
(let ([dom-id ((contract-neg-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-neg-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
... ...
[rest-id ((contract-neg-proc (coerce-contract stx-name rest-dom)) blame src-info orig-str)]) [rest-id ((contract-neg-proc (coerce-contract 'stx-name rest-dom)) blame src-info orig-str)])
(apply val (dom-id x) ... (rest-id rest-x)))))] (apply val (dom-id x) ... (rest-id rest-x)))))]
[(any . x) [(any . x)
(raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))] (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))]
@ -1805,12 +1854,12 @@
(with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))]) (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))])
(syntax (syntax
((x ... . rest-x) ((x ... . rest-x)
(let ([dom-id ((contract-neg-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-neg-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
... ...
[rest-id ((contract-neg-proc (coerce-contract stx-name rest-dom)) blame src-info orig-str)]) [rest-id ((contract-neg-proc (coerce-contract 'stx-name rest-dom)) blame src-info orig-str)])
(let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))]) (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))])
(check-post-expr->pp/h val post-expr src-info blame orig-str) (check-post-expr->pp/h val post-expr src-info blame orig-str)
(let ([rng-ids-x ((contract-pos-proc (coerce-contract stx-name rng-ctc)) (let ([rng-ids-x ((contract-pos-proc (coerce-contract 'stx-name rng-ctc))
blame src-info orig-str)] ...) blame src-info orig-str)] ...)
(values (rng-ids-x rng-ids) ...)))))))] (values (rng-ids-x rng-ids) ...)))))))]
[((values (rng-ids rng-ctc) ...) . whatever) [((values (rng-ids rng-ctc) ...) . whatever)
@ -1832,10 +1881,10 @@
(identifier? (syntax res-id)) (identifier? (syntax res-id))
(syntax (syntax
((x ... . rest-x) ((x ... . rest-x)
(let ([dom-id ((contract-neg-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-neg-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
... ...
[rest-id ((contract-neg-proc (coerce-contract stx-name rest-dom)) blame src-info orig-str)] [rest-id ((contract-neg-proc (coerce-contract 'stx-name rest-dom)) blame src-info orig-str)]
[rng-id ((contract-pos-proc (coerce-contract stx-name rng)) blame src-info orig-str)]) [rng-id ((contract-pos-proc (coerce-contract 'stx-name rng)) blame src-info orig-str)])
(let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))]) (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))])
(check-post-expr->pp/h val post-expr src-info blame orig-str) (check-post-expr->pp/h val post-expr src-info blame orig-str)
res-id))))] res-id))))]
@ -1854,9 +1903,9 @@
((x ... . rest-x) ((x ... . rest-x)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info blame orig-str) (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(let ([dom-id ((contract-pos-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-pos-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
... ...
[rest-id ((contract-pos-proc (coerce-contract stx-name rest-dom)) blame src-info orig-str)]) [rest-id ((contract-pos-proc (coerce-contract 'stx-name rest-dom)) blame src-info orig-str)])
(apply val (dom-id x) ... (rest-id rest-x))))))] (apply val (dom-id x) ... (rest-id rest-x))))))]
[(any . x) [(any . x)
(raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))] (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))]
@ -1868,11 +1917,11 @@
((x ... . rest-x) ((x ... . rest-x)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info blame orig-str) (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(let ([dom-id ((contract-pos-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-pos-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
... ...
[rest-id ((contract-pos-proc (coerce-contract stx-name rest-dom)) blame src-info orig-str)]) [rest-id ((contract-pos-proc (coerce-contract 'stx-name rest-dom)) blame src-info orig-str)])
(let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))]) (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))])
(let ([rng-ids-x ((contract-neg-proc (coerce-contract stx-name rng-ctc)) (let ([rng-ids-x ((contract-neg-proc (coerce-contract 'stx-name rng-ctc))
blame src-info orig-str)] ...) blame src-info orig-str)] ...)
(values (rng-ids-x rng-ids) ...))))))))] (values (rng-ids-x rng-ids) ...))))))))]
[((values (rng-ids rng-ctc) ...) . whatever) [((values (rng-ids rng-ctc) ...) . whatever)
@ -1896,10 +1945,10 @@
((x ... . rest-x) ((x ... . rest-x)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info blame orig-str) (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(let ([dom-id ((contract-pos-proc (coerce-contract stx-name dom)) blame src-info orig-str)] (let ([dom-id ((contract-pos-proc (coerce-contract 'stx-name dom)) blame src-info orig-str)]
... ...
[rest-id ((contract-pos-proc (coerce-contract stx-name rest-dom)) blame src-info orig-str)] [rest-id ((contract-pos-proc (coerce-contract 'stx-name rest-dom)) blame src-info orig-str)]
[rng-id ((contract-neg-proc (coerce-contract stx-name rng)) blame src-info orig-str)]) [rng-id ((contract-neg-proc (coerce-contract 'stx-name rng)) blame src-info orig-str)])
(rng-id (apply val (dom-id x) ... (rest-id rest-x)))))))] (rng-id (apply val (dom-id x) ... (rest-id rest-x)))))))]
[(rng res-id post-expr) [(rng res-id post-expr)
(not (identifier? (syntax res-id))) (not (identifier? (syntax res-id)))
@ -2054,6 +2103,14 @@
"expected a procedure that accepts ~a arguments, given: ~e" "expected a procedure that accepts ~a arguments, given: ~e"
dom-length dom-length
val))) val)))
(define ((check-procedure? arity) val)
(and (procedure? val)
(procedure-arity-includes? val arity)))
(define ((check-procedure/more? arity) val)
(and (procedure? val)
(procedure-accepts-and-more? val arity)))
(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str) (define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val) (unless (procedure? val)

4
collects/mzlib/private/contract-ds-helpers.ss
View File

@ -67,7 +67,7 @@ which are then called when the contract's fields are explored
(syntax (x ...)) (syntax (x ...))
field-names) field-names)
#,(defeat-inlining #,(defeat-inlining
#`(#,coerce-contract #,name ctc-exp)))]) #`(#,coerce-contract '#,name ctc-exp)))])
(loop (cdr clauses) (loop (cdr clauses)
(cdr ac-ids) (cdr ac-ids)
(cons (car ac-ids) prior-ac-ids) (cons (car ac-ids) prior-ac-ids)
@ -84,7 +84,7 @@ which are then called when the contract's fields are explored
(loop (cdr clauses) (loop (cdr clauses)
(cdr ac-ids) (cdr ac-ids)
(cons (car ac-ids) prior-ac-ids) (cons (car ac-ids) prior-ac-ids)
(cons #`(#,coerce-contract #,name ctc-exp) maker-args))] (cons #`(#,coerce-contract '#,name ctc-exp) maker-args))]
[(id ctc-exp) [(id ctc-exp)
(raise-syntax-error name "expected identifier" stx (syntax id))]))])))) (raise-syntax-error name "expected identifier" stx (syntax id))]))]))))

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

@ -193,7 +193,7 @@ it around flattened out.
#f])) #f]))
(define (struct/c ctc-x ...) (define (struct/c ctc-x ...)
(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 (selectors x) (burrow-in x 'selectors selector-indicies)) ... (define (selectors x) (burrow-in x 'selectors selector-indicies)) ...
@ -233,6 +233,7 @@ it around flattened out.
(list (cons pos-proj-prop lazy-contract-pos-proj) (list (cons pos-proj-prop lazy-contract-pos-proj)
(cons neg-proj-prop lazy-contract-neg-proj) (cons neg-proj-prop lazy-contract-neg-proj)
(cons name-prop lazy-contract-name) (cons name-prop lazy-contract-name)
(cons first-order-prop (λ (ctc) predicate))
(cons stronger-prop stronger-lazy-contract?)))))))])) (cons stronger-prop stronger-lazy-contract?)))))))]))
(define-struct contract/info (contract pos neg src-info orig-str)) (define-struct contract/info (contract pos neg src-info orig-str))

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

@ -8,7 +8,6 @@
(provide raise-contract-error (provide raise-contract-error
contract-violation->string contract-violation->string
coerce-contract coerce-contract
coerce/select-contract
flat-contract/predicate? flat-contract/predicate?
flat-contract? flat-contract?
@ -20,6 +19,8 @@
and/c and/c
any/c any/c
none/c
make-none/c
contract? contract?
contract-name contract-name
@ -32,6 +33,8 @@
define-struct/prop define-struct/prop
contract-stronger? contract-stronger?
contract-first-order-passes?
proj-pred? proj-get proj-pred? proj-get
pos-proj-prop pos-proj-pred? pos-proj-get pos-proj-prop pos-proj-pred? pos-proj-get
@ -40,7 +43,10 @@
stronger-prop stronger-pred? stronger-get stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get flat-prop flat-pred? flat-get
any-curried-proj any-curried-proj
flat-pos-proj) flat-pos-proj
first-order-prop
first-order-get)
;; define-struct/prop is a define-struct-like macro that ;; define-struct/prop is a define-struct-like macro that
@ -94,12 +100,26 @@
(make-struct-type-property 'contract-stronger-than)) (make-struct-type-property 'contract-stronger-than))
(define-values (flat-prop flat-pred? flat-get) (define-values (flat-prop flat-pred? flat-get)
(make-struct-type-property 'contract-flat)) (make-struct-type-property 'contract-flat))
(define-values (first-order-prop first-order-pred? first-order-get)
(make-struct-type-property 'contract-first-order))
(define-values (pos-proj-prop pos-proj-pred? pos-proj-get) (define-values (pos-proj-prop pos-proj-pred? pos-proj-get)
(make-struct-type-property 'contract-positive-projection)) (make-struct-type-property 'contract-positive-projection))
(define-values (neg-proj-prop neg-proj-pred? neg-proj-get) (define-values (neg-proj-prop neg-proj-pred? neg-proj-get)
(make-struct-type-property 'contract-negative-projection)) (make-struct-type-property 'contract-negative-projection))
(define (contract-first-order-passes? c v)
(cond
[(first-order-pred? c) (((first-order-get c) c) v)]
[(and (procedure? c)
(procedure-arity-includes? c 1))
;; flat contract as a predicate
(c v)]
[(flat-pred? c) (((flat-get c) c) v)]
[else (error 'contract-first-order-passes?
"expected a contract as first argument, got ~e, other arg ~e" c v)]))
(define (proj-get ctc) (define (proj-get ctc)
(cond (cond
[(proj-pred? ctc) [(proj-pred? ctc)
@ -120,40 +140,16 @@
;; indicates if one contract is stronger (ie, likes fewer values) than another ;; indicates if one contract is stronger (ie, likes fewer values) than another
;; this is not a total order. ;; this is not a total order.
(define (contract-stronger? a b) (define (contract-stronger? a b)
(let ([a-ctc (coerce-contract contract-stronger? a)] (let ([a-ctc (coerce-contract 'contract-stronger? a)]
[b-ctc (coerce-contract contract-stronger? b)]) [b-ctc (coerce-contract 'contract-stronger? b)])
((stronger-get a-ctc) a-ctc b-ctc))) ((stronger-get a-ctc) a-ctc b-ctc)))
;; coerce/select-contract : id (union contract? procedure-arity-1) -> contract-proc
;; contract-proc = sym sym stx -> alpha -> alpha
;; returns the procedure for the contract after extracting it from the
;; struct. Coerces the argument to a flat contract if it is procedure, but first.
(define-syntax (coerce/select-contract stx)
(syntax-case stx ()
[(_ name val)
(syntax (coerce/select-contract/proc 'name val))]))
(define (coerce/select-contract/proc name x)
(cond
[(contract? x)
(contract-proc x)]
[(and (procedure? x) (procedure-arity-includes? x 1))
(contract-proc (flat-contract x))]
[else
(error name
"expected contract or procedure of arity 1, got ~e"
x)]))
;; coerce-contract : id (union contract? procedure-arity-1) -> contract ;; coerce-contract : id (union contract? procedure-arity-1) -> contract
;; contract-proc = sym sym stx -> alpha -> alpha ;; contract-proc = sym sym stx -> alpha -> alpha
;; returns the procedure for the contract after extracting it from the ;; returns the procedure for the contract after extracting it from the
;; struct. Coerces the argument to a flat contract if it is procedure, but first. ;; struct. Coerces the argument to a flat contract if it is procedure, but first.
(define-syntax (coerce-contract stx) (define (coerce-contract name x)
(syntax-case stx ()
[(_ name val)
(syntax (coerce-contract/proc 'name val))]))
(define (coerce-contract/proc name x)
(cond (cond
[(contract? x) x] [(contract? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1)) [(and (procedure? x) (procedure-arity-includes? x 1))
@ -307,10 +303,12 @@
(define-values (make-flat-contract (define-values (make-flat-contract
make-pair-proj-contract) make-pair-proj-contract)
(let () (let ()
(define-struct/prop pair-proj-contract (the-name pos-proc neg-proc) (define-struct/prop pair-proj-contract (the-name pos-proc neg-proc first-order-proc)
((pos-proj-prop (λ (ctc) (pair-proj-contract-pos-proc ctc))) ((pos-proj-prop (λ (ctc) (pair-proj-contract-pos-proc ctc)))
(neg-proj-prop (λ (ctc) (pair-proj-contract-neg-proc ctc))) (neg-proj-prop (λ (ctc) (pair-proj-contract-neg-proc ctc)))
(name-prop (λ (ctc) (pair-proj-contract-the-name ctc))) (name-prop (λ (ctc) (pair-proj-contract-the-name ctc)))
(first-order-prop (λ (ctc) (or (pair-proj-contract-first-order-proc ctc)
(λ (x) #t))))
(stronger-prop (λ (this that) (stronger-prop (λ (this that)
(and (pair-proj-contract? that) (and (pair-proj-contract? that)
(procedure-closure-contents-eq? (procedure-closure-contents-eq?
@ -375,7 +373,38 @@
(let ([mk-sub-name (contract-name sub)]) (let ([mk-sub-name (contract-name sub)])
`(,mk-sub-name ,@(loop (cdr subs))))] `(,mk-sub-name ,@(loop (cdr subs))))]
[else `(,sub ,@(loop (cdr subs)))]))]))) [else `(,sub ,@(loop (cdr subs)))]))])))
(define (make-and-proj proj-get)
(λ (ctc)
(let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))])
(lambda (pos src-info orig-str)
(let ([projs (map (λ (c) (c pos src-info orig-str)) mk-pos-projs)])
(let loop ([projs (cdr projs)]
[proj (car projs)])
(cond
[(null? projs) proj]
[else (loop (cdr projs)
(let ([f (car projs)])
(λ (v) (proj (f v)))))])))))))
(define-struct/prop and/c (ctcs)
((pos-proj-prop (make-and-proj pos-proj-get))
(neg-proj-prop (make-and-proj neg-proj-get))
(name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc))))
(first-order-prop (λ (ctc)
(let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))])
(λ (x)
(andmap (λ (f) (f x)) tests)))))
(stronger-prop
(λ (this that)
(and (and/c? that)
(let ([this-ctcs (and/c-ctcs this)]
[that-ctcs (and/c-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs))))))))
(define (and/c . fs) (define (and/c . fs)
(for-each (for-each
(lambda (x) (lambda (x)
@ -405,43 +434,41 @@
(cdr preds)))]))]) (cdr preds)))]))])
(flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))] (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
[else [else
(let* ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)] (let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)])
[pos-contract/procs (map contract-pos-proc contracts)] (make-and/c contracts))]))
[neg-contract/procs (map contract-neg-proc contracts)])
(make-pair-proj-contract
(apply build-compound-type-name 'and/c contracts)
(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
[(null? rest) ctct]
[else
(let ([fst (car rest)])
(loop (lambda (x) (fst (ctct x)))
(cdr rest)))]))))))]))
(define-struct/prop any/c () (define-struct/prop any/c ()
((pos-proj-prop any-curried-proj) ((pos-proj-prop any-curried-proj)
(neg-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))
(first-order-prop (λ (ctc) (λ (val) #t)))
(flat-prop (λ (ctc) (λ (x) #t))))) (flat-prop (λ (ctc) (λ (x) #t)))))
(define any/c (make-any/c)) (define any/c (make-any/c))
(define (none-curried-proj ctc)
(λ (pos src-info orig-str)
(λ (val)
(raise-contract-error
val
src-info
pos
orig-str
"~s accepts no values, given: ~e"
(none/c-name ctc)
val))))
(define-struct/prop none/c (name)
((pos-proj-prop none-curried-proj)
(neg-proj-prop none-curried-proj)
(stronger-prop (λ (this that) #t))
(name-prop (λ (ctc) (none/c-name ctc)))
(first-order-prop (λ (ctc) (λ (val) #f)))
(flat-prop (λ (ctc) (λ (x) #f)))))
(define none/c (make-none/c 'none/c))
(define (flat-contract/predicate? pred) (define (flat-contract/predicate? pred)
(or (flat-contract? pred) (or (flat-contract? pred)
(and (procedure? pred) (and (procedure? pred)

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

@ -53,7 +53,7 @@ add struct contracts for immutable structs?
(define-for-syntax (make-define/contract-transformer contract-id id) (define-for-syntax (make-define/contract-transformer contract-id id)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (λ (stx)
(with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")] (with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")]
[contract-id contract-id] [contract-id contract-id]
[id id]) [id id])
@ -83,7 +83,7 @@ add struct contracts for immutable structs?
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (λ (stx)
(with-syntax ([neg-stx (datum->syntax-object stx 'here)] (with-syntax ([neg-stx (datum->syntax-object stx 'here)]
[contract-id contract-id] [contract-id contract-id]
[id id] [id id]
@ -215,7 +215,7 @@ add struct contracts for immutable structs?
provide-stx provide-stx
(syntax name))] (syntax name))]
[(struct name (fields ...)) [(struct name (fields ...))
(for-each (lambda (field) (for-each (λ (field)
(syntax-case field () (syntax-case field ()
[(x y) [(x y)
(identifier? (syntax x)) (identifier? (syntax x))
@ -272,8 +272,8 @@ add struct contracts for immutable structs?
[(a b) (syntax a)] [(a b) (syntax a)]
[else struct-name-position])] [else struct-name-position])]
[super-id (syntax-case struct-name-position () [super-id (syntax-case struct-name-position ()
[(a b) (syntax b)] [(a b) (syntax b)]
[else #t])] [else #t])]
[struct-info (extract-struct-info struct-name-position)] [struct-info (extract-struct-info struct-name-position)]
[constructor-id (list-ref struct-info 1)] [constructor-id (list-ref struct-info 1)]
[predicate-id (list-ref struct-info 2)] [predicate-id (list-ref struct-info 2)]
@ -291,7 +291,7 @@ add struct contracts for immutable structs?
provide-stx provide-stx
struct-name)] struct-name)]
[else (length fields)]))))] [else (length fields)]))))]
[field-contract-ids (map (lambda (field-name) [field-contract-ids (map (λ (field-name)
(a:mangle-id provide-stx (a:mangle-id provide-stx
"provide/contract-field-contract" "provide/contract-field-contract"
field-name field-name
@ -305,22 +305,28 @@ add struct contracts for immutable structs?
"struct:" "struct:"
(symbol->string (syntax-e struct-name)))))] (symbol->string (syntax-e struct-name)))))]
[-struct:struct-name
(datum->syntax-object
struct-name
(string->symbol
(string-append
"-struct:"
(symbol->string (syntax-e struct-name)))))]
[is-new-id?
[is-new-id? (λ (index)
(λ (index) (or (not parent-struct-count)
(or (not parent-struct-count) (parent-struct-count . <= . index)))])
(parent-struct-count . <= . index)))])
(let ([unknown-info (let ([unknown-info
(lambda (what names) (λ (what names)
(raise-syntax-error (raise-syntax-error
'provide/contract 'provide/contract
(format "cannot determine ~a, found ~s" what names) (format "cannot determine ~a, found ~s" what names)
provide-stx provide-stx
struct-name))] struct-name))]
[is-id-ok? [is-id-ok?
(lambda (id i) (λ (id i)
(if (or (not parent-struct-count) (if (or (not parent-struct-count)
(parent-struct-count . <= . i)) (parent-struct-count . <= . i))
id id
@ -330,13 +336,13 @@ add struct contracts for immutable structs?
(unless predicate-id (unknown-info "predicate" predicate-id)) (unless predicate-id (unknown-info "predicate" predicate-id))
(unless (andmap/count is-id-ok? selector-ids) (unless (andmap/count is-id-ok? selector-ids)
(unknown-info "selectors" (unknown-info "selectors"
(map (lambda (x) (if (syntax? x) (map (λ (x) (if (syntax? x)
(syntax-object->datum x) (syntax-object->datum x)
x)) x))
selector-ids))) selector-ids)))
(unless (andmap/count is-id-ok? mutator-ids) (unless (andmap/count is-id-ok? mutator-ids)
(unknown-info "mutators" (unknown-info "mutators"
(map (lambda (x) (if (syntax? x) (map (λ (x) (if (syntax? x)
(syntax-object->datum x) (syntax-object->datum x)
x)) x))
mutator-ids)))) mutator-ids))))
@ -360,8 +366,8 @@ add struct contracts for immutable structs?
(with-syntax ([((selector-codes selector-new-names) ...) (with-syntax ([((selector-codes selector-new-names) ...)
(filter (filter
(lambda (x) x) (λ (x) x)
(map/count (lambda (selector-id field-contract-id index) (map/count (λ (selector-id field-contract-id index)
(if (is-new-id? index) (if (is-new-id? index)
(code-for-one-id/new-name (code-for-one-id/new-name
stx stx
@ -376,16 +382,16 @@ add struct contracts for immutable structs?
[(rev-selector-old-names ...) [(rev-selector-old-names ...)
(reverse (reverse
(filter (filter
(lambda (x) x) (λ (x) x)
(map/count (lambda (selector-id index) (map/count (λ (selector-id index)
(if (not (is-new-id? index)) (if (not (is-new-id? index))
selector-id selector-id
#f)) #f))
selector-ids)))] selector-ids)))]
[((mutator-codes mutator-new-names) ...) [((mutator-codes mutator-new-names) ...)
(filter (filter
(lambda (x) x) (λ (x) x)
(map/count (lambda (mutator-id field-contract-id index) (map/count (λ (mutator-id field-contract-id index)
(if (is-new-id? index) (if (is-new-id? index)
(code-for-one-id/new-name stx (code-for-one-id/new-name stx
mutator-id mutator-id
@ -399,8 +405,8 @@ add struct contracts for immutable structs?
[(rev-mutator-old-names ...) [(rev-mutator-old-names ...)
(reverse (reverse
(filter (filter
(lambda (x) x) (λ (x) x)
(map/count (lambda (mutator-id index) (map/count (λ (mutator-id index)
(if (not (is-new-id? index)) (if (not (is-new-id? index))
mutator-id mutator-id
#f)) #f))
@ -424,7 +430,7 @@ add struct contracts for immutable structs?
"provide/contract-struct-expandsion-info-id" "provide/contract-struct-expandsion-info-id"
struct-name)] struct-name)]
[struct-name struct-name] [struct-name struct-name]
[struct:struct-name struct:struct-name] [-struct:struct-name -struct:struct-name]
[super-id (if (boolean? super-id) [super-id (if (boolean? super-id)
super-id super-id
(with-syntax ([super-id super-id]) (with-syntax ([super-id super-id])
@ -432,7 +438,7 @@ add struct contracts for immutable structs?
(syntax (begin (syntax (begin
(provide (rename id-rename struct-name)) (provide (rename id-rename struct-name))
(define-syntax id-rename (define-syntax id-rename
(list-immutable ((syntax-local-certifier) #'struct:struct-name) (list-immutable ((syntax-local-certifier) #'-struct:struct-name)
((syntax-local-certifier) #'constructor-new-name) ((syntax-local-certifier) #'constructor-new-name)
((syntax-local-certifier) #'predicate-new-name) ((syntax-local-certifier) #'predicate-new-name)
(list-immutable ((syntax-local-certifier) #'rev-selector-new-names) ... (list-immutable ((syntax-local-certifier) #'rev-selector-new-names) ...
@ -440,7 +446,10 @@ add struct contracts for immutable structs?
(list-immutable ((syntax-local-certifier) #'rev-mutator-new-names) ... (list-immutable ((syntax-local-certifier) #'rev-mutator-new-names) ...
((syntax-local-certifier) #'rev-mutator-old-names) ...) ((syntax-local-certifier) #'rev-mutator-old-names) ...)
super-id)))))] super-id)))))]
[struct:struct-name struct:struct-name]) [struct:struct-name struct:struct-name]
[-struct:struct-name -struct:struct-name]
[struct-name struct-name]
[(selector-ids ...) selector-ids])
(syntax/loc stx (syntax/loc stx
(begin (begin
struct-code struct-code
@ -449,7 +458,23 @@ add struct contracts for immutable structs?
mutator-codes ... mutator-codes ...
predicate-code predicate-code
constructor-code constructor-code
(provide struct:struct-name)))))))) (define -struct:struct-name
(let-values ([(struct:struct-name _make _pred _get _set)
(make-struct-type 'struct-name
struct:struct-name
0 ;; init
0 ;; auto
#f ;; auto-v
'() ;; props
#f ;; inspector
#f ;; proc-spec
'
() ;; immutable-k-list
(λ (selector-ids ... ignore)
(values (-contract field-contract-ids selector-ids 'guess1 'guess2)
...)))])
struct:struct-name))
(provide (rename -struct:struct-name struct:struct-name)))))))))
;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z) ;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
#; #;
@ -491,7 +516,7 @@ add struct contracts for immutable structs?
[(a b) [(a b)
(syntax-local-value (syntax-local-value
(syntax b) (syntax b)
(lambda () (λ ()
(raise-syntax-error 'provide/contract (raise-syntax-error 'provide/contract
"expected a struct name" "expected a struct name"
provide-stx provide-stx
@ -505,7 +530,7 @@ add struct contracts for immutable structs?
[_ stx])]) [_ stx])])
(syntax-local-value (syntax-local-value
id id
(lambda () (λ ()
(raise-syntax-error 'provide/contract (raise-syntax-error 'provide/contract
"expected a struct name" "expected a struct name"
provide-stx provide-stx
@ -519,14 +544,14 @@ add struct contracts for immutable structs?
(field-contract-ids (field-contract-ids
... ...
. -> . . -> .
(let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id))))) (let ([predicate-id (λ (x) (predicate-id x))]) predicate-id)))))
;; build-selector-contract : syntax syntax -> syntax ;; build-selector-contract : syntax syntax -> syntax
;; constructs the contract for a selector ;; constructs the contract for a selector
(define (build-selector-contract struct-name predicate-id field-contract-id) (define (build-selector-contract struct-name predicate-id field-contract-id)
(with-syntax ([field-contract-id field-contract-id] (with-syntax ([field-contract-id field-contract-id]
[predicate-id predicate-id]) [predicate-id predicate-id])
(syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id) (syntax ((let ([predicate-id (λ (x) (predicate-id x))]) predicate-id)
. -> . . -> .
field-contract-id)))) field-contract-id))))
@ -535,7 +560,7 @@ add struct contracts for immutable structs?
(define (build-mutator-contract struct-name predicate-id field-contract-id) (define (build-mutator-contract struct-name predicate-id field-contract-id)
(with-syntax ([field-contract-id field-contract-id] (with-syntax ([field-contract-id field-contract-id]
[predicate-id predicate-id]) [predicate-id predicate-id])
(syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id) (syntax ((let ([predicate-id (λ (x) (predicate-id x))]) predicate-id)
field-contract-id field-contract-id
. -> . . -> .
void?)))) void?))))
@ -696,7 +721,8 @@ add struct contracts for immutable structs?
(λ (blame src str) (λ (blame src str)
(let ([proc (contract-neg-proc arg)]) (let ([proc (contract-neg-proc arg)])
(λ (val) (λ (val)
((proc blame src str) val))))))])) ((proc blame src str) val))))
#f))]))
(define (check-contract ctc) (define (check-contract ctc)
(unless (contract? ctc) (unless (contract? ctc)
@ -751,15 +777,15 @@ add struct contracts for immutable structs?
(with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))] (with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))]
[(pred-id ...) (generate-temporaries (syntax (ctc ...)))]) [(pred-id ...) (generate-temporaries (syntax (ctc ...)))])
(syntax (syntax
(let* ([pred (lambda (x) (error 'flat-rec-contract "applied too soon"))] (let* ([pred (λ (x) (error 'flat-rec-contract "applied too soon"))]
[name (flat-contract (let ([name (lambda (x) (pred x))]) name))]) [name (flat-contract (let ([name (λ (x) (pred x))]) name))])
(let ([ctc-id (coerce-contract flat-rec-contract ctc)] ...) (let ([ctc-id (coerce-contract 'flat-rec-contract ctc)] ...)
(unless (flat-contract? ctc-id) (unless (flat-contract? ctc-id)
(error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id)) (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
... ...
(set! pred (set! pred
(let ([pred-id (flat-contract-predicate ctc-id)] ...) (let ([pred-id (flat-contract-predicate ctc-id)] ...)
(lambda (x) (λ (x)
(or (pred-id x) ...)))) (or (pred-id x) ...))))
name))))] name))))]
[(_ name ctc ...) [(_ name ctc ...)
@ -775,9 +801,9 @@ add struct contracts for immutable structs?
[((pred-arm-id ...) ...) (map generate-temporaries [((pred-arm-id ...) ...) (map generate-temporaries
(syntax->list (syntax ((ctc ...) ...))))]) (syntax->list (syntax ((ctc ...) ...))))])
(syntax (syntax
(let* ([pred-id (lambda (x) (error 'flat-murec-contract "applied too soon"))] ... (let* ([pred-id (λ (x) (error 'flat-murec-contract "applied too soon"))] ...
[name (flat-contract (let ([name (lambda (x) (pred-id x))]) name))] ...) [name (flat-contract (let ([name (λ (x) (pred-id x))]) name))] ...)
(let-values ([(ctc-id ...) (values (coerce-contract flat-rec-contract ctc) ...)] ...) (let-values ([(ctc-id ...) (values (coerce-contract 'flat-rec-contract ctc) ...)] ...)
(begin (begin
(void) (void)
(unless (flat-contract? ctc-id) (unless (flat-contract? ctc-id)
@ -785,12 +811,12 @@ add struct contracts for immutable structs?
...) ... ...) ...
(set! pred-id (set! pred-id
(let ([pred-arm-id (flat-contract-predicate ctc-id)] ...) (let ([pred-arm-id (flat-contract-predicate ctc-id)] ...)
(lambda (x) (λ (x)
(or (pred-arm-id x) ...)))) ... (or (pred-arm-id x) ...)))) ...
body1 body1
body ...))))] body ...))))]
[(_ ([name ctc ...] ...) body1 body ...) [(_ ([name ctc ...] ...) body1 body ...)
(for-each (lambda (name) (for-each (λ (name)
(unless (identifier? name) (unless (identifier? name)
(raise-syntax-error 'flat-rec-contract (raise-syntax-error 'flat-rec-contract
"expected an identifier" stx name))) "expected an identifier" stx name)))
@ -815,51 +841,53 @@ add struct contracts for immutable structs?
[(_ args ...) (syntax (or/c args ...))] [(_ args ...) (syntax (or/c args ...))]
[id (syntax or/c)]))) [id (syntax or/c)])))
(define (or/c . args) (define or/c
(for-each (case-lambda
(lambda (x) [() (make-none/c '(or/c))]
(unless (or (contract? x) [args
(and (procedure? x) (for-each
(procedure-arity-includes? x 1))) (λ (x)
(error 'or/c "expected procedures of arity 1 or contracts, given: ~e" x))) (unless (or (contract? x)
args) (and (procedure? x)
(let-values ([(contract fc/predicates) (procedure-arity-includes? x 1)))
(let loop ([contract #f] (error 'or/c "expected procedures of arity 1 or contracts, given: ~e" x)))
[fc/predicates null] args)
[args args]) (let-values ([(ho-contracts fc/predicates)
(cond (let loop ([ho-contracts '()]
[(null? args) (values contract (reverse fc/predicates))] [fc/predicates null]
[else [args args])
(let ([arg (car args)]) (cond
(cond [(null? args) (values ho-contracts (reverse fc/predicates))]
[(or (flat-contract? arg) [else
(not (contract? arg))) (let ([arg (car args)])
(loop contract (cons arg fc/predicates) (cdr args))] (cond
[contract [(and (contract? arg)
(error 'or/c "expected at most one non-flat contract, given ~e and ~e" (not (flat-contract? arg)))
contract (loop (cons arg ho-contracts) fc/predicates (cdr args))]
arg)] [else
[else (loop arg fc/predicates (cdr args))]))]))]) (loop ho-contracts (cons arg fc/predicates) (cdr args))]))]))])
(let ([flat-contracts (map (lambda (x) (if (flat-contract? x) (let ([flat-contracts (map (λ (x) (if (flat-contract? x)
x x
(flat-contract x))) (flat-contract x)))
fc/predicates)]) fc/predicates)])
(cond (cond
[contract [(null? ho-contracts)
(make-or/c flat-contracts contract)] (make-flat-or/c flat-contracts)]
[else [(null? (cdr ho-contracts))
(make-flat-or/c flat-contracts)])))) (make-or/c flat-contracts (car ho-contracts))]
[else
(make-multi-or/c flat-contracts ho-contracts)])))]))
(define-struct/prop or/c (flat-ctcs ho-ctc) (define-struct/prop or/c (flat-ctcs ho-ctc)
((pos-proj-prop (λ (ctc) ((pos-proj-prop (λ (ctc)
(let ([c-proc ((pos-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 src-info orig-str) (λ (pos src-info orig-str)
(let ([partial-contract (c-proc pos src-info orig-str)]) (let ([partial-contract (c-proc pos src-info orig-str)])
(lambda (val) (λ (val)
(cond (cond
[(ormap (lambda (pred) (pred val)) predicates) [(ormap (λ (pred) (pred val)) predicates)
val] val]
[else [else
(partial-contract val)]))))))) (partial-contract val)])))))))
@ -868,11 +896,11 @@ add struct contracts for immutable structs?
(let ([c-proc ((neg-proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))] (let ([c-proc ((neg-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 src-info orig-str) (λ (pos src-info orig-str)
(let ([partial-contract (c-proc pos src-info orig-str)]) (let ([partial-contract (c-proc pos src-info orig-str)])
(lambda (val) (λ (val)
(cond (cond
[(ormap (lambda (pred) (pred val)) predicates) [(ormap (λ (pred) (pred val)) predicates)
val] val]
[else [else
(partial-contract val)]))))))) (partial-contract val)])))))))
@ -881,18 +909,101 @@ add struct contracts for immutable structs?
(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))))
(first-order-prop
(λ (ctc)
(let ([flats (map (λ (x) ((flat-get x) x)) (or/c-flat-ctcs ctc))]
[ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))])
(λ (x)
(or (ho x)
(ormap (λ (f) (f x)) flats))))))
(stronger-prop (stronger-prop
(λ (this that) (λ (this that)
(and (or/c? that) (and (or/c? that)
(and (contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that))
(contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that)) (let ([this-ctcs (or/c-flat-ctcs this)]
(let ([this-ctcs (or/c-flat-ctcs this)] [that-ctcs (or/c-flat-ctcs that)])
[that-ctcs (or/c-flat-ctcs that)]) (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 (make-multi-or/c-proj pos-proj-get)
(λ (ctc)
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
[c-procs (map (λ (x) ((pos-proj-get x) x)) ho-contracts)]
[first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)]
[predicates (map (λ (x) ((flat-get x) x))
(multi-or/c-flat-ctcs ctc))])
(λ (pos src-info orig-str)
(let ([partial-contracts (map (λ (c-proc) (c-proc pos src-info orig-str)) c-procs)])
(λ (val)
(cond
[(ormap (λ (pred) (pred val)) predicates)
val]
[else
(let loop ([checks first-order-checks]
[procs partial-contracts]
[contracts ho-contracts]
[candidate-proc #f]
[candidate-contract #f])
(cond
[(null? checks)
(if candidate-proc
(candidate-proc val)
(raise-contract-error val src-info pos orig-str
"none of the branches of the or/c matched"))]
[((car checks) val)
(if candidate-proc
(error 'or/c "two arguments, ~s and ~s, might both match ~s"
(contract-name candidate-contract)
(contract-name (car contracts))
val)
(loop (cdr checks)
(cdr procs)
(cdr contracts)
(car procs)
(car contracts)))]
[else
(loop (cdr checks)
(cdr procs)
(cdr contracts)
candidate-proc
candidate-contract)]))])))))))
(define-struct/prop multi-or/c (flat-ctcs ho-ctcs)
((pos-proj-prop (make-multi-or/c-proj pos-proj-get))
(neg-proj-prop (make-multi-or/c-proj neg-proj-get))
(name-prop (λ (ctc)
(apply build-compound-type-name
'or/c
(append
(multi-or/c-ho-ctcs ctc)
(multi-or/c-flat-ctcs ctc)))))
(first-order-prop
(λ (ctc)
(let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))]
[hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))])
(λ (x)
(or (ormap (λ (f) (f x)) hos)
(ormap (λ (f) (f x)) flats))))))
(stronger-prop
(λ (this that)
(and (multi-or/c? that)
(let ([this-ctcs (multi-or/c-ho-ctcs this)]
[that-ctcs (multi-or/c-ho-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))
(let ([this-ctcs (multi-or/c-flat-ctcs this)]
[that-ctcs (multi-or/c-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs))))))))
(define-struct/prop flat-or/c (flat-ctcs) (define-struct/prop flat-or/c (flat-ctcs)
((pos-proj-prop flat-pos-proj) ((pos-proj-prop flat-pos-proj)
@ -919,14 +1030,14 @@ add struct contracts for immutable structs?
(define false/c (define false/c
(flat-named-contract (flat-named-contract
'false/c 'false/c
(lambda (x) (not x)))) (λ (x) (not x))))
(define (string/len n) (define (string/len n)
(unless (number? n) (unless (number? n)
(error 'string/len "expected a number as argument, got ~e" n)) (error 'string/len "expected a number as argument, got ~e" n))
(flat-named-contract (flat-named-contract
`(string/len ,n) `(string/len ,n)
(lambda (x) (λ (x)
(and (string? x) (and (string? x)
((string-length x) . < . n))))) ((string-length x) . < . n)))))
@ -935,7 +1046,7 @@ add struct contracts for immutable structs?
(error 'symbols "expected at least one argument")) (error 'symbols "expected at least one argument"))
(unless (andmap symbol? ss) (unless (andmap symbol? ss)
(error 'symbols "expected symbols as arguments, given: ~a" (error 'symbols "expected symbols as arguments, given: ~a"
(apply string-append (map (lambda (x) (format "~e " x)) ss)))) (apply string-append (map (λ (x) (format "~e " x)) ss))))
(make-one-of/c ss)) (make-one-of/c ss))
(define atomic-value? (define atomic-value?
@ -979,7 +1090,7 @@ add struct contracts for immutable structs?
(define printable/c (define printable/c
(flat-named-contract (flat-named-contract
'printable/c 'printable/c
(lambda (x) (λ (x)
(let printable? ([x x]) (let printable? ([x x])
(or (symbol? x) (or (symbol? x)
(string? x) (string? x)
@ -1027,16 +1138,16 @@ add struct contracts for immutable structs?
(define (</c x) (define (</c x)
(flat-named-contract (flat-named-contract
`(</c ,x) `(</c ,x)
(lambda (y) (and (number? y) (< y x))))) (λ (y) (and (number? y) (< y x)))))
(define (>/c x) (define (>/c x)
(flat-named-contract (flat-named-contract
`(>/c ,x) `(>/c ,x)
(lambda (y) (and (number? y) (> y x))))) (λ (y) (and (number? y) (> y x)))))
(define natural-number/c (define natural-number/c
(flat-named-contract (flat-named-contract
'natural-number/c 'natural-number/c
(lambda (x) (λ (x)
(and (number? x) (and (number? x)
(integer? x) (integer? x)
(x . >= . 0))))) (x . >= . 0)))))
@ -1047,7 +1158,7 @@ add struct contracts for immutable structs?
(error 'integer-in "expected two integers as arguments, got ~e and ~e" start end)) (error 'integer-in "expected two integers as arguments, got ~e and ~e" start end))
(flat-named-contract (flat-named-contract
`(integer-in ,start ,end) `(integer-in ,start ,end)
(lambda (x) (λ (x)
(and (integer? x) (and (integer? x)
(<= start x end))))) (<= start x end)))))
@ -1059,7 +1170,7 @@ add struct contracts for immutable structs?
(error 'integer-in "expected two exact integers as arguments, got ~e and ~e" start end)) (error 'integer-in "expected two exact integers as arguments, got ~e and ~e" start end))
(flat-named-contract (flat-named-contract
`(exact-integer-in ,start ,end) `(exact-integer-in ,start ,end)
(lambda (x) (λ (x)
(and (integer? x) (and (integer? x)
(exact? x) (exact? x)
(<= start x end))))) (<= start x end)))))
@ -1070,7 +1181,7 @@ add struct contracts for immutable structs?
(error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end)) (error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end))
(flat-named-contract (flat-named-contract
`(real-in ,start ,end) `(real-in ,start ,end)
(lambda (x) (λ (x)
(and (real? x) (and (real? x)
(<= start x end))))) (<= start x end)))))
@ -1079,34 +1190,34 @@ add struct contracts for immutable structs?
(error 'not/c "expected a procedure of arity 1 or <flat-named-contract>, given: ~e" f)) (error 'not/c "expected a procedure of arity 1 or <flat-named-contract>, given: ~e" f))
(build-flat-contract (build-flat-contract
(build-compound-type-name 'not/c (proc/ctc->ctc f)) (build-compound-type-name 'not/c (proc/ctc->ctc f))
(lambda (x) (not (test-proc/flat-contract f x))))) (λ (x) (not (test-proc/flat-contract f x)))))
(define (listof p) (define (listof p)
(unless (flat-contract/predicate? p) (unless (flat-contract/predicate? p)
(error 'listof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p)) (error 'listof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
(build-flat-contract (build-flat-contract
(build-compound-type-name 'listof (proc/ctc->ctc p)) (build-compound-type-name 'listof (proc/ctc->ctc p))
(lambda (v) (λ (v)
(and (list? v) (and (list? v)
(andmap (lambda (ele) (test-proc/flat-contract p ele)) (andmap (λ (ele) (test-proc/flat-contract p ele))
v))))) v)))))
(define-syntax (*-immutableof stx) (define-syntax (*-immutableof stx)
(syntax-case stx () (syntax-case stx ()
[(_ predicate? fill type-name name) [(_ predicate? fill type-name name)
(identifier? (syntax predicate?))
(syntax (syntax
(let ([predicate?-name predicate?] (let ([fill-name fill])
[fill-name fill]) (λ (input)
(lambda (input) (let* ([ctc (coerce-contract 'name input)]
(let* ([ctc (coerce-contract name input)]
[p-proj (contract-pos-proc ctc)] [p-proj (contract-pos-proc ctc)]
[n-proj (contract-neg-proc ctc)]) [n-proj (contract-neg-proc ctc)])
(make-pair-proj-contract (make-pair-proj-contract
(build-compound-type-name 'name ctc) (build-compound-type-name 'name ctc)
(lambda (blame src-info orig-str) (λ (blame src-info orig-str)
(let ([p-app (p-proj blame src-info orig-str)]) (let ([p-app (p-proj blame src-info orig-str)])
(lambda (val) (λ (val)
(unless (predicate?-name val) (unless (predicate? val)
(raise-contract-error (raise-contract-error
val val
src-info src-info
@ -1116,10 +1227,11 @@ add struct contracts for immutable structs?
'type-name 'type-name
val)) val))
(fill-name p-app val)))) (fill-name p-app val))))
(lambda (blame src-info orig-str) (λ (blame src-info orig-str)
(let ([n-app (n-proj blame src-info orig-str)]) (let ([n-app (n-proj blame src-info orig-str)])
(lambda (val) (λ (val)
(fill-name n-app val)))))))))])) (fill-name n-app val))))
predicate?)))))]))
(define (map-immutable f lst) (define (map-immutable f lst)
(let loop ([lst lst]) (let loop ([lst lst])
@ -1129,20 +1241,21 @@ add struct contracts for immutable structs?
(loop (cdr lst)))] (loop (cdr lst)))]
[(null? lst) null]))) [(null? lst) null])))
(define (immutable-list? lst) (define (immutable-list? val)
(cond (let loop ([v val])
[(and (pair? lst) (or (and (pair? v)
(immutable? lst)) (immutable? v)
(immutable-list? (cdr lst))] (loop (cdr v)))
[(null? lst) #t] (null? v))))
[else #f]))
(define list-immutableof (define list-immutableof
(*-immutableof immutable-list? map-immutable immutable-list list-immutableof)) (*-immutableof immutable-list? map-immutable immutable-list list-immutableof))
(define (immutable-vector? val) (and (immutable? val) (vector? val)))
(define vector-immutableof (define vector-immutableof
(*-immutableof (lambda (x) (and (vector? x) (immutable? x))) (*-immutableof immutable-vector?
(lambda (f v) (apply vector-immutable (map f (vector->list v)))) (λ (f v) (apply vector-immutable (map f (vector->list v))))
immutable-vector immutable-vector
vector-immutableof)) vector-immutableof))
@ -1151,9 +1264,9 @@ add struct contracts for immutable structs?
(error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p)) (error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
(build-flat-contract (build-flat-contract
(build-compound-type-name 'vectorof (proc/ctc->ctc p)) (build-compound-type-name 'vectorof (proc/ctc->ctc p))
(lambda (v) (λ (v)
(and (vector? v) (and (vector? v)
(andmap (lambda (ele) (test-proc/flat-contract p ele)) (andmap (λ (ele) (test-proc/flat-contract p ele))
(vector->list v)))))) (vector->list v))))))
(define (vector/c . args) (define (vector/c . args)
@ -1169,7 +1282,7 @@ add struct contracts for immutable structs?
(let ([largs (length args)]) (let ([largs (length args)])
(build-flat-contract (build-flat-contract
(apply build-compound-type-name 'vector/c (map proc/ctc->ctc args)) (apply build-compound-type-name 'vector/c (map proc/ctc->ctc args))
(lambda (v) (λ (v)
(and (vector? v) (and (vector? v)
(= (vector-length v) largs) (= (vector-length v) largs)
(andmap test-proc/flat-contract (andmap test-proc/flat-contract
@ -1181,7 +1294,7 @@ add struct contracts for immutable structs?
(error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred)) (error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred))
(build-flat-contract (build-flat-contract
(build-compound-type-name 'box/c (proc/ctc->ctc pred)) (build-compound-type-name 'box/c (proc/ctc->ctc pred))
(lambda (x) (λ (x)
(and (box? x) (and (box? x)
(test-proc/flat-contract pred (unbox x)))))) (test-proc/flat-contract pred (unbox x))))))
@ -1191,7 +1304,7 @@ add struct contracts for immutable structs?
(error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" hdp tlp)) (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" hdp tlp))
(build-flat-contract (build-flat-contract
(build-compound-type-name 'cons/c (proc/ctc->ctc hdp) (proc/ctc->ctc tlp)) (build-compound-type-name 'cons/c (proc/ctc->ctc hdp) (proc/ctc->ctc tlp))
(lambda (x) (λ (x)
(and (pair? x) (and (pair? x)
(test-proc/flat-contract hdp (car x)) (test-proc/flat-contract hdp (car x))
(test-proc/flat-contract tlp (cdr x)))))) (test-proc/flat-contract tlp (cdr x))))))
@ -1210,16 +1323,16 @@ add struct contracts for immutable structs?
(let ([predicate?-name predicate?] (let ([predicate?-name predicate?]
[constructor-name constructor] [constructor-name constructor]
[selector-names selectors] ...) [selector-names selectors] ...)
(lambda (params ...) (λ (params ...)
(let ([ctc-x (coerce-contract name params)] ...) (let ([ctc-x (coerce-contract 'name params)] ...)
(let ([pos-procs (contract-pos-proc ctc-x)] (let ([pos-procs (contract-pos-proc ctc-x)]
... ...
[neg-procs (contract-neg-proc ctc-x)] ...) [neg-procs (contract-neg-proc ctc-x)] ...)
(make-pair-proj-contract (make-pair-proj-contract
(build-compound-type-name 'name (proc/ctc->ctc params) ...) (build-compound-type-name 'name (proc/ctc->ctc params) ...)
(lambda (blame src-info orig-str) (λ (blame src-info orig-str)
(let ([p-apps (pos-procs blame src-info orig-str)] ...) (let ([p-apps (pos-procs blame src-info orig-str)] ...)
(lambda (v) (λ (v)
(if (and (immutable? v) (if (and (immutable? v)
(predicate?-name v)) (predicate?-name v))
(constructor-name (p-apps (selector-names v)) ...) (constructor-name (p-apps (selector-names v)) ...)
@ -1231,26 +1344,27 @@ add struct contracts for immutable structs?
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
'type-name 'type-name
v))))) v)))))
(lambda (blame src-info orig-str) (λ (blame src-info orig-str)
(let ([p-apps (neg-procs blame src-info orig-str)] ...) (let ([p-apps (neg-procs blame src-info orig-str)] ...)
(lambda (v) (λ (v)
(constructor-name (p-apps (selector-names v)) ...)))))))))))] (constructor-name (p-apps (selector-names v)) ...))))
#f)))))))]
[(_ 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
(let ([predicate?-name predicate?] (let ([predicate?-name predicate?]
[constructor-name constructor] [constructor-name constructor]
[selector-name selector]) [selector-name selector])
(lambda params (λ params
(let ([ctcs (map (lambda (param) (coerce-contract name param)) params)]) (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
(let ([pos-procs (map contract-pos-proc ctcs)] (let ([pos-procs (map contract-pos-proc ctcs)]
[neg-procs (map contract-neg-proc ctcs)]) [neg-procs (map contract-neg-proc ctcs)])
(make-pair-proj-contract (make-pair-proj-contract
(apply build-compound-type-name 'name (map proc/ctc->ctc params)) (apply build-compound-type-name 'name (map proc/ctc->ctc params))
(lambda (blame src-info orig-str) (λ (blame src-info orig-str)
(let ([p-apps (map (lambda (proc) (proc blame src-info orig-str)) pos-procs)] (let ([p-apps (map (λ (proc) (proc blame src-info orig-str)) pos-procs)]
[count (length params)]) [count (length params)])
(lambda (v) (λ (v)
(if (and (immutable? v) (if (and (immutable? v)
(predicate?-name v) (predicate?-name v)
(correct-size count v)) (correct-size count v))
@ -1270,9 +1384,9 @@ add struct contracts for immutable structs?
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
'type-name 'type-name
v))))) v)))))
(lambda (blame src-info orig-str) (λ (blame src-info orig-str)
(let ([p-apps (map (lambda (proc) (proc blame src-info orig-str)) neg-procs)]) (let ([p-apps (map (λ (proc) (proc blame src-info orig-str)) neg-procs)])
(lambda (v) (λ (v)
(apply constructor-name (apply constructor-name
(let loop ([p-apps p-apps] (let loop ([p-apps p-apps]
[i 0]) [i 0])
@ -1280,14 +1394,15 @@ add struct contracts for immutable structs?
[(null? p-apps) null] [(null? p-apps) null]
[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))))]))))))
#f))))))]))
(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))
(define vector-immutable/c (*-immutable/c vector? (define vector-immutable/c (*-immutable/c vector?
vector-immutable vector-immutable
(#t (lambda (v i) (vector-ref v i))) (#t (λ (v i) (vector-ref v i)))
(lambda (n v) (= n (vector-length v))) (λ (n v) (= n (vector-length v)))
immutable-vector immutable-vector
vector-immutable/c)) vector-immutable/c))
@ -1307,7 +1422,7 @@ add struct contracts for immutable structs?
[else (cons/c (car args) (loop (cdr args)))]))) [else (cons/c (car args) (loop (cdr args)))])))
(define (list-immutable/c . args) (define (list-immutable/c . args)
(unless (andmap (lambda (x) (or (contract? x) (unless (andmap (λ (x) (or (contract? x)
(and (procedure? x) (and (procedure? x)
(procedure-arity-includes? x 1)))) (procedure-arity-includes? x 1))))
args) args)
@ -1325,24 +1440,24 @@ add struct contracts for immutable structs?
[else (cons-immutable/c (car args) (loop (cdr args)))]))) [else (cons-immutable/c (car args) (loop (cdr args)))])))
(define (syntax/c ctc-in) (define (syntax/c ctc-in)
(let ([ctc (coerce-contract syntax/c ctc-in)]) (let ([ctc (coerce-contract 'syntax/c ctc-in)])
(build-flat-contract (build-flat-contract
(build-compound-type-name 'syntax/c ctc) (build-compound-type-name 'syntax/c ctc)
(let ([pred (flat-contract-predicate ctc)]) (let ([pred (flat-contract-predicate ctc)])
(lambda (val) (λ (val)
(and (syntax? val) (and (syntax? val)
(pred (syntax-e val)))))))) (pred (syntax-e val))))))))
(define promise/c (define promise/c
(lambda (ctc-in) (λ (ctc-in)
(let* ([ctc (coerce-contract promise/c ctc-in)] (let* ([ctc (coerce-contract 'promise/c ctc-in)]
[pos-ctc-proc (contract-pos-proc ctc)] [pos-ctc-proc (contract-pos-proc ctc)]
[neg-ctc-proc (contract-neg-proc ctc)]) [neg-ctc-proc (contract-neg-proc ctc)])
(make-pair-proj-contract (make-pair-proj-contract
(build-compound-type-name 'promise/c ctc) (build-compound-type-name 'promise/c ctc)
(lambda (blame src-info orig-str) (λ (blame src-info orig-str)
(let ([p-app (pos-ctc-proc blame src-info orig-str)]) (let ([p-app (pos-ctc-proc blame src-info orig-str)])
(lambda (val) (λ (val)
(unless (promise? val) (unless (promise? val)
(raise-contract-error (raise-contract-error
val val
@ -1353,10 +1468,11 @@ add struct contracts for immutable structs?
"expected <promise>, given: ~e" "expected <promise>, given: ~e"
val)) val))
(delay (p-app (force val)))))) (delay (p-app (force val))))))
(lambda (blame src-info orig-str) (λ (blame src-info orig-str)
(let ([p-app (neg-ctc-proc blame src-info orig-str)]) (let ([p-app (neg-ctc-proc blame src-info orig-str)])
(lambda (val) (λ (val)
(delay (p-app (force val)))))))))) (delay (p-app (force val))))))
promise?))))
#| #|
as with copy-struct in struct.ss, this first begin0 as with copy-struct in struct.ss, this first begin0
@ -1372,7 +1488,7 @@ add struct contracts for immutable structs?
(syntax-case stx () (syntax-case stx ()
[(_ struct-name args ...) [(_ struct-name args ...)
(and (identifier? (syntax struct-name)) (and (identifier? (syntax struct-name))
(syntax-local-value (syntax struct-name) (lambda () #f))) (syntax-local-value (syntax struct-name) (λ () #f)))
(with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))] (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-name-x ...) (generate-temporaries (syntax (args ...)))] [(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))] [(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
@ -1392,7 +1508,7 @@ add struct contracts for immutable structs?
(syntax-local-value (syntax struct-name))]) (syntax-local-value (syntax struct-name))])
(with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))]) (with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))])
(syntax (syntax
(let ([ctc-x (coerce-contract struct/c args)] ...) (let ([ctc-x (coerce-contract 'struct/c args)] ...)
(unless predicate-id (unless predicate-id
(error 'struct/c "could not determine predicate for ~s" 'struct-name)) (error 'struct/c "could not determine predicate for ~s" 'struct-name))

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

@ -128,6 +128,9 @@
(test/no-error '(listof any/c)) (test/no-error '(listof any/c))
(test/no-error '(listof (lambda (x) #t))) (test/no-error '(listof (lambda (x) #t)))
(test/spec-passed/result 'any/c '(contract any/c 1 'pos 'neg) 1)
(test/pos-blame 'none/c '(contract none/c 1 'pos 'neg))
(test/spec-passed (test/spec-passed
'contract-arrow-star0a 'contract-arrow-star0a
'(contract (->* (integer?) (integer?)) '(contract (->* (integer?) (integer?))
@ -1134,6 +1137,34 @@
'neg) 'neg)
1)) 1))
(test/pos-blame
'contract-case->0a
'(contract (case->)
(lambda (x) x)
'pos
'neg))
(test/pos-blame
'contract-case->0b
'(contract (case->)
(lambda () 1)
'pos
'neg))
(test/pos-blame
'contract-case->0c
'(contract (case->)
1
'pos
'neg))
(test/spec-passed
'contract-case->0d
'(contract (case->)
(case-lambda)
'pos
'neg))
(test/pos-blame (test/pos-blame
'contract-case->1 'contract-case->1
'(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?)) '(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
@ -1335,6 +1366,47 @@
#f) #f)
#f) #f)
(test/spec-passed/result
'or/c9
'((contract (or/c (-> string?) (-> integer? integer?))
(λ () "x")
'pos
'neg))
"x")
(test/spec-passed/result
'or/c10
'((contract (or/c (-> string?) (-> integer? integer?))
(λ (x) x)
'pos
'neg)
1)
1)
(test/pos-blame
'or/c11
'(contract (or/c (-> string?) (-> integer? integer?))
1
'pos
'neg))
(test/pos-blame
'or/c12
'((contract (or/c (-> string?) (-> integer? integer?))
1
'pos
'neg)
'x))
(test 1 'or/c-not-error-early
(begin (or/c (-> integer? integer?) (-> boolean? boolean?))
1))
(error-test #'(contract (or/c (-> integer? integer?) (-> boolean? boolean?))
(λ (x) x)
'pos
'neg)
exn:fail?)
(test (test
'(1 2) '(1 2)
'or/c-ordering 'or/c-ordering
@ -1365,6 +1437,20 @@
'neg) 'neg)
x)) x))
(test
(reverse '(1 3 4 2))
'ho-and/c-ordering
(let ([x '()])
((contract (and/c (-> (lambda (y) (set! x (cons 1 x)) #t)
(lambda (y) (set! x (cons 2 x)) #t))
(-> (lambda (y) (set! x (cons 3 x)) #t)
(lambda (y) (set! x (cons 4 x)) #t)))
(λ (x) x)
'pos
'neg)
1)
x))
(test/spec-passed (test/spec-passed
'define/contract1 'define/contract1
'(let () '(let ()
@ -3964,6 +4050,7 @@
(-> integer? integer? integer?)) (-> integer? integer? integer?))
(case-> (->r ((x number?) (y boolean?) (z pair?)) number?) (case-> (->r ((x number?) (y boolean?) (z pair?)) number?)
(-> integer? integer? integer?))) (-> integer? integer? integer?)))
(test-name '(case->) (case->))
(test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?)) (test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?))
(case-> (-> integer? integer?) (-> integer? integer? integer?))) (case-> (-> integer? integer?) (-> integer? integer? integer?)))
@ -4151,6 +4238,28 @@
(test #f contract-stronger? (symbols 'z 'x 'y) (symbols 'x 'y)) (test #f contract-stronger? (symbols 'z 'x 'y) (symbols 'x 'y))
(test #t contract-stronger? (one-of/c (expt 2 100)) (one-of/c (expt 2 100) 12)) (test #t contract-stronger? (one-of/c (expt 2 100)) (one-of/c (expt 2 100) 12))
(test #t contract-stronger?
(or/c (-> (>=/c 3) (>=/c 3)) (-> string?))
(or/c (-> (>=/c 4) (>=/c 3)) (-> string?)))
(test #f contract-stronger?
(or/c (-> string?) (-> integer? integer?))
(or/c (-> string?) (-> any/c integer?)))
(test #f contract-stronger?
(or/c (-> string?) (-> any/c integer?))
(or/c (-> string?) (-> integer? integer?)))
(test #t contract-stronger?
(or/c (-> string?) (-> integer? integer?) integer? boolean?)
(or/c (-> string?) (-> integer? integer?) integer? boolean?))
(test #f contract-stronger?
(or/c (-> string?) (-> integer? integer?) integer? char?)
(or/c (-> string?) (-> integer? integer?) integer? boolean?))
(test #f contract-stronger?
(or/c (-> string?) (-> integer? integer?) integer?)
(or/c (-> string?) (-> integer? integer?) integer? boolean?))
(test #f contract-stronger?
(or/c (-> string?) (-> integer? integer?) integer?)
(or/c (-> integer? integer?) integer?))
(let () (let ()
(define-contract-struct couple (hd tl)) (define-contract-struct couple (hd tl))
(define (non-zero? x) (not (zero? x))) (define (non-zero? x) (not (zero? x)))
@ -4194,5 +4303,185 @@
(test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5)) (test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5))
(test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4))) (test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; first-order tests
;;
(test #t contract-first-order-passes? (flat-contract integer?) 1)
(test #f contract-first-order-passes? (flat-contract integer?) 'x)
(test #t contract-first-order-passes? (flat-contract boolean?) #t)
(test #f contract-first-order-passes? (flat-contract boolean?) 'x)
(test #t contract-first-order-passes? any/c 1)
(test #t contract-first-order-passes? any/c #t)
(test #t contract-first-order-passes? (-> integer? integer?) (λ (x) #t))
(test #f contract-first-order-passes? (-> integer? integer?) (λ (x y) #t))
(test #f contract-first-order-passes? (-> integer? integer?) 'x)
(test #t contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y) #t))
(test #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x) #t))
(test #f contract-first-order-passes? (-> integer? boolean? integer?) (λ (x y z) #t))
(test #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x . y) #f))
(test #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x y . z) #f))
(test #f contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ (x) #f))
(test #t contract-first-order-passes? (->* (integer?) boolean? (char? any/c)) (λ x #f))
(test #t contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y) x))
(test #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x) x))
(test #f contract-first-order-passes? (->d integer? boolean? (lambda (x y) char?)) (λ (x y z) x))
(test #t contract-first-order-passes? (list-immutableof integer?) (list-immutable 1))
(test #f contract-first-order-passes? (list-immutableof integer?) (list 1))
(test #f contract-first-order-passes? (list-immutableof integer?) #f)
(test #t contract-first-order-passes? (vector-immutableof integer?) (vector->immutable-vector (vector 1)))
(test #f contract-first-order-passes? (vector-immutableof integer?) 'x)
(test #f contract-first-order-passes? (vector-immutableof integer?) '())
(test #t contract-first-order-passes? (promise/c integer?) (delay 1))
(test #f contract-first-order-passes? (promise/c integer?) 1)
(test #t contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y) #t))
(test #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x) #t))
(test #f contract-first-order-passes? (->d* (integer? boolean?) (lambda (x y) char?)) (λ (x y z) #t))
(test #t contract-first-order-passes?
(->d* (integer? boolean?) any/c (lambda (x y . z) char?))
(λ (x y . z) z))
(test #t contract-first-order-passes?
(->d* (integer? boolean?) any/c (lambda (x y . z) char?))
(λ (y . z) z))
(test #t contract-first-order-passes?
(->d* (integer? boolean?) any/c (lambda (x y . z) char?))
(λ z z))
(test #f contract-first-order-passes?
(->d* (integer? boolean?) any/c (lambda (x y . z) char?))
(λ (x y z . w) 1))
(test #f contract-first-order-passes?
(->d* (integer? boolean?) any/c (lambda (x y . z) char?))
(λ (x y) 1))
(test #t contract-first-order-passes? (->r ((x number?)) number?) (λ (x) 1))
(test #f contract-first-order-passes? (->r ((x number?)) number?) (λ (x y) 1))
(test #f contract-first-order-passes? (->r ((x number?)) number?) (λ () 1))
(test #t contract-first-order-passes? (->r ((x number?)) number?) (λ args 1))
(test #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x) 1))
(test #f contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ () 1))
(test #t contract-first-order-passes? (->pp ((x number?)) #t number? blech #t) (λ (x . y) 1))
(test #f contract-first-order-passes?
(case-> (-> integer? integer?)
(-> integer? integer? integer?))
(λ () 1))
(test #f contract-first-order-passes?
(case-> (-> integer? integer?)
(-> integer? integer? integer?))
(λ (x) 1))
(test #f contract-first-order-passes?
(case-> (-> integer? integer?)
(-> integer? integer? integer?))
(λ (x y) 1))
(test #f contract-first-order-passes?
(case->)
1)
(test #t contract-first-order-passes?
(case->)
(case-lambda))
(test #t contract-first-order-passes?
(case-> (-> integer? integer?)
(-> integer? integer? integer?))
(case-lambda [(x) x] [(x y) x]))
(test #t contract-first-order-passes?
(case-> (-> integer? integer?)
(-> integer? integer? integer?))
(case-lambda [() 1] [(x) x] [(x y) x]))
(test #t contract-first-order-passes?
(case-> (-> integer? integer?)
(-> integer? integer? integer?))
(case-lambda [() 1] [(x) x] [(x y) x] [(x y z) x]))
(test #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) (λ (x) x))
(test #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) values)
(test #f contract-first-order-passes? (and/c (-> integer?) (-> integer? integer?)) (λ (x) x))
(test #t contract-first-order-passes?
(cons-immutable/c boolean? (-> integer? integer?))
(list*-immutable #t (λ (x) x)))
(test #t contract-first-order-passes?
(cons-immutable/c boolean? (-> integer? integer?))
(list*-immutable 1 2))
(test #f contract-first-order-passes? (flat-rec-contract the-name) 1)
(test #t contract-first-order-passes?
(object-contract (m (-> integer? integer?)))
(new object%))
(test #t contract-first-order-passes?
(object-contract (m (-> integer? integer?)))
1)
(let ()
(define-contract-struct couple (hd tl))
(test #t contract-first-order-passes?
(couple/c any/c any/c)
(make-couple 1 2))
(test #f contract-first-order-passes?
(couple/c any/c any/c)
2)
(test #t contract-first-order-passes?
(couple/dc [hd any/c] [tl any/c])
(make-couple 1 2))
(test #f contract-first-order-passes?
(couple/dc [hd any/c] [tl any/c])
1)
(test #t contract-first-order-passes?
(couple/dc [hd any/c] [tl (hd) any/c])
(make-couple 1 2))
(test #f contract-first-order-passes?
(couple/dc [hd any/c] [tl (hd) any/c])
1))
(test #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) #t)
(test #t contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) (λ (x) x))
(test #f contract-first-order-passes? (or/c (-> (>=/c 5) (>=/c 5)) boolean?) 'x)
(test #t contract-first-order-passes?
(or/c (-> integer? integer? integer?)
(-> integer? integer?))
(λ (x) x))
(test #t contract-first-order-passes?
(or/c (-> integer? integer? integer?)
(-> integer? integer?))
(λ (x y) x))
(test #f contract-first-order-passes?
(or/c (-> integer? integer? integer?)
(-> integer? integer?))
(λ () x))
(test #f contract-first-order-passes?
(or/c (-> integer? integer? integer?)
(-> integer? integer?))
1)
(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?)
(or/c (flat-contract integer?)
(flat-contract boolean?)))
(test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(or/c (-> (>=/c 5) (>=/c 5)) boolean?))
(test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(or/c boolean? (-> (>=/c 5) (>=/c 5))))
)) ))
(report-errs) (report-errs)