extended or/c to support multiple higher-order contracts
svn: r3606
This commit is contained in:
Robby Findler
parent
8fa40a972a
commit
79ae279b79
|
|
@ -9,5 +9,7 @@
|
|||
(all-from "private/contract-ds.ss")
|
||||
(all-from "private/contract-arrow.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")))
|
||||
|
|
|
|||
|
|
@ -32,10 +32,10 @@
|
|||
(raise-syntax-error 'any "Use any out of an arrow contract" stx))
|
||||
|
||||
;; FIXME: need to pass in the name of the contract combinator.
|
||||
(define (build--> doms doms-rest rngs rng-any? func)
|
||||
(let ([doms/c (map (λ (dom) (coerce-contract -> dom)) doms)]
|
||||
[rngs/c (map (λ (rng) (coerce-contract -> rng)) rngs)]
|
||||
[doms-rest/c (and doms-rest (coerce-contract -> doms-rest))])
|
||||
(define (build--> name doms doms-rest rngs rng-any? func)
|
||||
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
|
||||
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
|
||||
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
|
||||
(make--> rng-any? doms/c doms-rest/c rngs/c func)))
|
||||
|
||||
(define-struct/prop -> (rng-any? doms dom-rest rngs func)
|
||||
|
|
@ -79,6 +79,16 @@
|
|||
(->-dom-rest ctc)
|
||||
(->-rng-any? 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
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
|
|
@ -137,7 +147,8 @@
|
|||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values
|
||||
(syntax (build--> (list dom-ctcs ...)
|
||||
(syntax (build--> '->
|
||||
(list dom-ctcs ...)
|
||||
#f
|
||||
(list rng-ctcs ...)
|
||||
use-any?
|
||||
|
|
@ -213,7 +224,8 @@
|
|||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> (list doms ...)
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list rngs ...)
|
||||
#f
|
||||
|
|
@ -238,7 +250,8 @@
|
|||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> (list doms ...)
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list any/c)
|
||||
#t
|
||||
|
|
@ -246,6 +259,9 @@
|
|||
inner-args/body
|
||||
(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->*)
|
||||
|
||||
|
|
@ -278,7 +294,10 @@
|
|||
;; syntax
|
||||
;; -> (syntax -> syntax)
|
||||
(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))])
|
||||
(with-syntax ([inner-check (check-val outer-args)]
|
||||
[(val blame src-info orig-str name-id) outer-args]
|
||||
|
|
@ -302,7 +321,8 @@
|
|||
(lambda (val)
|
||||
inner-neg-lambda))])
|
||||
(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
|
||||
outer-args
|
||||
(syntax/loc stx
|
||||
|
|
@ -311,16 +331,22 @@
|
|||
(lambda (blame src-info orig-str)
|
||||
pos-proj-code)
|
||||
(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)
|
||||
(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.
|
||||
[(_ case) (syntax case)]
|
||||
|
||||
[(_ 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 ...))))])
|
||||
(let ([outer-args (syntax (val blame src-info orig-str name-id))])
|
||||
(with-syntax ([(inner-check ...) (check-val outer-args)]
|
||||
|
|
@ -342,7 +368,8 @@
|
|||
inner-pos-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)]
|
||||
[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
|
||||
outer-args
|
||||
(syntax/loc stx
|
||||
|
|
@ -351,7 +378,8 @@
|
|||
(lambda (blame src-info orig-str)
|
||||
pos-proj-code)
|
||||
(lambda (blame src-info orig-str)
|
||||
neg-proj-code))))))))))]))
|
||||
neg-proj-code)
|
||||
first-order-check)))))))))]))
|
||||
|
||||
(define (make-opt->/proc method-proc? stx)
|
||||
(syntax-case stx (any)
|
||||
|
|
@ -506,14 +534,19 @@
|
|||
(lambda (x y) y)
|
||||
(lambda (x y) y)
|
||||
(lambda (args) (syntax ()))
|
||||
(syntax (lambda (x) #t))
|
||||
(lambda (args) (syntax ()))
|
||||
(lambda (args) (syntax ())))]
|
||||
[else
|
||||
(let ([/h (select/h (car cases) 'case-> orig-stx)]
|
||||
[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))]
|
||||
[(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))])
|
||||
(values
|
||||
(lambda (outer-args x)
|
||||
|
|
@ -530,6 +563,9 @@
|
|||
(with-syntax ([checks (check-vals args)]
|
||||
[check (check-val args)])
|
||||
(syntax (check . checks))))
|
||||
(with-syntax ([checks first-order-checks]
|
||||
[check first-order-check])
|
||||
(syntax (lambda (x) (and (checks x) (check x)))))
|
||||
(lambda (args)
|
||||
(with-syntax ([case (pos-wrapper args)]
|
||||
[cases (pos-wrappers args)])
|
||||
|
|
@ -820,7 +856,7 @@
|
|||
(syntax
|
||||
(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)]
|
||||
...
|
||||
|
|
@ -877,7 +913,8 @@
|
|||
val
|
||||
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
|
||||
(field/app-var (get-field field-name val)) ...
|
||||
)))))))))))))]))
|
||||
))))))
|
||||
#f)))))))]))
|
||||
|
||||
;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void
|
||||
(define (ensure-no-duplicates stx form-name names)
|
||||
|
|
@ -933,6 +970,9 @@
|
|||
;; - [check-val]
|
||||
;; code that does error checking on the contract'd value itself
|
||||
;; (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]
|
||||
;; a piece of syntax that has the arguments to the wrapper
|
||||
;; and the body of the wrapper.
|
||||
|
|
@ -982,7 +1022,7 @@
|
|||
(with-syntax ([body body]
|
||||
[(val blame src-info orig-str name-id) outer-args])
|
||||
(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)]
|
||||
...
|
||||
[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])
|
||||
(syntax
|
||||
(check-procedure val dom-length src-info blame orig-str))))
|
||||
|
||||
(syntax (check-procedure? dom-length))
|
||||
wrap
|
||||
wrap))]
|
||||
[(values rng ...)
|
||||
|
|
@ -1034,9 +1074,9 @@
|
|||
(with-syntax ([body body]
|
||||
[(val blame src-info orig-str name-id) outer-args])
|
||||
(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)]
|
||||
...
|
||||
[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])
|
||||
(syntax
|
||||
(check-procedure val dom-length src-info blame orig-str))))
|
||||
|
||||
(syntax (check-procedure? dom-length))
|
||||
wrap
|
||||
wrap)))]
|
||||
[rng
|
||||
|
|
@ -1097,9 +1137,9 @@
|
|||
(with-syntax ([body body]
|
||||
[(val blame src-info orig-str name-id) outer-args])
|
||||
(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)]
|
||||
...
|
||||
[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])
|
||||
(syntax
|
||||
(check-procedure val dom-length src-info blame orig-str))))
|
||||
|
||||
(syntax (check-procedure? dom-length))
|
||||
wrap
|
||||
wrap)))])))]))
|
||||
|
||||
|
|
@ -1188,9 +1228,10 @@
|
|||
(syntax (dom-contract-x ...))))
|
||||
(syntax (dom-contract-x ...)))])
|
||||
(syntax
|
||||
(let ([dom-contract-x (coerce-contract ->* dom)] ...
|
||||
[dom-rest-contract-x (coerce-contract ->* rest)]
|
||||
[rng-contract-x (coerce-contract ->* rng)] ...)
|
||||
(let ([dom-contract-x (coerce-contract '->* dom)]
|
||||
...
|
||||
[dom-rest-contract-x (coerce-contract '->* rest)]
|
||||
[rng-contract-x (coerce-contract '->* rng)] ...)
|
||||
(let ([dom-pos-x (contract-pos-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])
|
||||
(syntax
|
||||
(check-procedure/more val dom-length src-info blame orig-str))))
|
||||
|
||||
(syntax (check-procedure/more? dom-length))
|
||||
wrap
|
||||
wrap)))]
|
||||
[(_ (dom ...) rest any)
|
||||
|
|
@ -1273,9 +1314,9 @@
|
|||
(syntax (dom-contract-x ...))))
|
||||
(syntax (dom-contract-x ...)))])
|
||||
(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)]
|
||||
...
|
||||
[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])
|
||||
(syntax
|
||||
(check-procedure/more val dom-length src-info blame orig-str))))
|
||||
(syntax (check-procedure/more? dom-length))
|
||||
wrap
|
||||
wrap)))]))
|
||||
|
||||
|
|
@ -1338,7 +1380,7 @@
|
|||
(syntax (dom-contract-x ...))))
|
||||
(syntax (dom-contract-x ...)))])
|
||||
(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)]
|
||||
...
|
||||
[dom-neg-x (contract-neg-proc dom-contract-x)] ...
|
||||
|
|
@ -1368,6 +1410,8 @@
|
|||
(syntax
|
||||
(check-procedure val arity src-info blame orig-str))))
|
||||
|
||||
(syntax (check-procedure? arity))
|
||||
|
||||
;; pos
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val blame src-info orig-str name-id) outer-args])
|
||||
|
|
@ -1375,7 +1419,7 @@
|
|||
((arg-x ...)
|
||||
(let ([arg-x (dom-projection-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
|
||||
src-info
|
||||
orig-str)
|
||||
|
|
@ -1388,7 +1432,7 @@
|
|||
((arg-x ...)
|
||||
(let ([arg-x (dom-projection-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
|
||||
src-info
|
||||
orig-str)
|
||||
|
|
@ -1423,7 +1467,7 @@
|
|||
(apply
|
||||
values
|
||||
(map (lambda (rng-contract result)
|
||||
(((extract-proc (coerce-contract ->d* rng-contract))
|
||||
(((extract-proc (coerce-contract '->d* rng-contract))
|
||||
blame
|
||||
src-info
|
||||
orig-str)
|
||||
|
|
@ -1441,7 +1485,7 @@
|
|||
(syntax (dom-contract-x ...))))
|
||||
(syntax (dom-contract-x ...)))])
|
||||
(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)]
|
||||
...
|
||||
[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])
|
||||
(syntax
|
||||
(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-neg-proc)))))]
|
||||
[(_ (dom ...) rest rng-mk)
|
||||
|
|
@ -1510,7 +1554,7 @@
|
|||
(apply
|
||||
values
|
||||
(map (lambda (rng-contract result)
|
||||
(((extract-proj (coerce-contract ->d* rng-contract))
|
||||
(((extract-proj (coerce-contract '->d* rng-contract))
|
||||
blame
|
||||
src-info
|
||||
orig-str)
|
||||
|
|
@ -1528,9 +1572,9 @@
|
|||
(syntax (dom-contract-x ...))))
|
||||
(syntax (dom-contract-x ...)))])
|
||||
(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)]
|
||||
...
|
||||
[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])
|
||||
(syntax
|
||||
(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-neg-proc)))))]))
|
||||
|
|
@ -1633,6 +1678,9 @@
|
|||
(syntax
|
||||
(begin
|
||||
(check-procedure/kind val arity 'kind-of-thing src-info blame orig-str)))))
|
||||
|
||||
(syntax (check-procedure? arity))
|
||||
|
||||
;; pos
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val blame src-info orig-str name-id) outer-args])
|
||||
|
|
@ -1640,7 +1688,7 @@
|
|||
[(any)
|
||||
(syntax
|
||||
((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) ...))))]
|
||||
[((values (rng-ids rng-ctc) ...) post-expr)
|
||||
|
|
@ -1650,11 +1698,11 @@
|
|||
(syntax
|
||||
((x ...)
|
||||
(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) ...)])
|
||||
(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)] ...)
|
||||
(values (rng-ids-x rng-ids) ...))))))))]
|
||||
[((values (rng-ids rng-ctc) ...) post-expr)
|
||||
|
|
@ -1671,9 +1719,9 @@
|
|||
[(rng res-id post-expr)
|
||||
(syntax
|
||||
((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) ...))])
|
||||
(check-post-expr->pp/h val post-expr src-info blame orig-str)
|
||||
res-id))))]
|
||||
|
|
@ -1689,7 +1737,7 @@
|
|||
((x ...)
|
||||
(begin
|
||||
(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) ...)))))]
|
||||
[((values (rng-ids rng-ctc) ...) post-expr)
|
||||
|
|
@ -1700,10 +1748,10 @@
|
|||
((x ...)
|
||||
(begin
|
||||
(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 ([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)] ...)
|
||||
(values (rng-ids-x rng-ids) ...))))))))]
|
||||
[((values (rng-ids rng-ctc) ...) post-expr)
|
||||
|
|
@ -1722,9 +1770,9 @@
|
|||
((x ...)
|
||||
(begin
|
||||
(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) ...))))))]
|
||||
[_
|
||||
(raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))]
|
||||
|
|
@ -1785,6 +1833,7 @@
|
|||
(syntax
|
||||
(begin
|
||||
(check-procedure/more/kind val arity 'kind-of-thing src-info blame orig-str)))))
|
||||
(syntax (check-procedure/more? arity))
|
||||
|
||||
;; pos
|
||||
(lambda (outer-args)
|
||||
|
|
@ -1793,9 +1842,9 @@
|
|||
[(any)
|
||||
(syntax
|
||||
((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)))))]
|
||||
[(any . x)
|
||||
(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 ...)))])
|
||||
(syntax
|
||||
((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))])
|
||||
(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)] ...)
|
||||
(values (rng-ids-x rng-ids) ...)))))))]
|
||||
[((values (rng-ids rng-ctc) ...) . whatever)
|
||||
|
|
@ -1832,10 +1881,10 @@
|
|||
(identifier? (syntax res-id))
|
||||
(syntax
|
||||
((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)]
|
||||
[rng-id ((contract-pos-proc (coerce-contract stx-name rng)) 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)])
|
||||
(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)
|
||||
res-id))))]
|
||||
|
|
@ -1854,9 +1903,9 @@
|
|||
((x ... . rest-x)
|
||||
(begin
|
||||
(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))))))]
|
||||
[(any . x)
|
||||
(raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))]
|
||||
|
|
@ -1868,11 +1917,11 @@
|
|||
((x ... . rest-x)
|
||||
(begin
|
||||
(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 ([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)] ...)
|
||||
(values (rng-ids-x rng-ids) ...))))))))]
|
||||
[((values (rng-ids rng-ctc) ...) . whatever)
|
||||
|
|
@ -1896,10 +1945,10 @@
|
|||
((x ... . rest-x)
|
||||
(begin
|
||||
(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)]
|
||||
[rng-id ((contract-neg-proc (coerce-contract stx-name rng)) 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 (apply val (dom-id x) ... (rest-id rest-x)))))))]
|
||||
[(rng res-id post-expr)
|
||||
(not (identifier? (syntax res-id)))
|
||||
|
|
@ -2055,6 +2104,14 @@
|
|||
dom-length
|
||||
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)
|
||||
(unless (procedure? val)
|
||||
(raise-contract-error val
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ which are then called when the contract's fields are explored
|
|||
(syntax (x ...))
|
||||
field-names)
|
||||
#,(defeat-inlining
|
||||
#`(#,coerce-contract #,name ctc-exp)))])
|
||||
#`(#,coerce-contract '#,name ctc-exp)))])
|
||||
(loop (cdr clauses)
|
||||
(cdr 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)
|
||||
(cdr 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)
|
||||
(raise-syntax-error name "expected identifier" stx (syntax id))]))]))))
|
||||
|
||||
|
|
|
|||
|
|
@ -193,7 +193,7 @@ it around flattened out.
|
|||
#f]))
|
||||
|
||||
(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 ...)))
|
||||
|
||||
(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)
|
||||
(cons neg-proj-prop lazy-contract-neg-proj)
|
||||
(cons name-prop lazy-contract-name)
|
||||
(cons first-order-prop (λ (ctc) predicate))
|
||||
(cons stronger-prop stronger-lazy-contract?)))))))]))
|
||||
|
||||
(define-struct contract/info (contract pos neg src-info orig-str))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@
|
|||
(provide raise-contract-error
|
||||
contract-violation->string
|
||||
coerce-contract
|
||||
coerce/select-contract
|
||||
|
||||
flat-contract/predicate?
|
||||
flat-contract?
|
||||
|
|
@ -20,6 +19,8 @@
|
|||
|
||||
and/c
|
||||
any/c
|
||||
none/c
|
||||
make-none/c
|
||||
|
||||
contract?
|
||||
contract-name
|
||||
|
|
@ -33,6 +34,8 @@
|
|||
|
||||
contract-stronger?
|
||||
|
||||
contract-first-order-passes?
|
||||
|
||||
proj-pred? proj-get
|
||||
pos-proj-prop pos-proj-pred? pos-proj-get
|
||||
neg-proj-prop neg-proj-pred? neg-proj-get
|
||||
|
|
@ -40,7 +43,10 @@
|
|||
stronger-prop stronger-pred? stronger-get
|
||||
flat-prop flat-pred? flat-get
|
||||
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
|
||||
|
|
@ -95,11 +101,25 @@
|
|||
(define-values (flat-prop flat-pred? flat-get)
|
||||
(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)
|
||||
(make-struct-type-property 'contract-positive-projection))
|
||||
(define-values (neg-proj-prop neg-proj-pred? neg-proj-get)
|
||||
(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)
|
||||
(cond
|
||||
[(proj-pred? ctc)
|
||||
|
|
@ -120,40 +140,16 @@
|
|||
;; indicates if one contract is stronger (ie, likes fewer values) than another
|
||||
;; this is not a total order.
|
||||
(define (contract-stronger? a b)
|
||||
(let ([a-ctc (coerce-contract contract-stronger? a)]
|
||||
[b-ctc (coerce-contract contract-stronger? b)])
|
||||
(let ([a-ctc (coerce-contract 'contract-stronger? a)]
|
||||
[b-ctc (coerce-contract 'contract-stronger? b)])
|
||||
((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
|
||||
;; 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-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name val)
|
||||
(syntax (coerce-contract/proc 'name val))]))
|
||||
|
||||
(define (coerce-contract/proc name x)
|
||||
(define (coerce-contract name x)
|
||||
(cond
|
||||
[(contract? x) x]
|
||||
[(and (procedure? x) (procedure-arity-includes? x 1))
|
||||
|
|
@ -307,10 +303,12 @@
|
|||
(define-values (make-flat-contract
|
||||
make-pair-proj-contract)
|
||||
(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)))
|
||||
(neg-proj-prop (λ (ctc) (pair-proj-contract-neg-proc 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)
|
||||
(and (pair-proj-contract? that)
|
||||
(procedure-closure-contents-eq?
|
||||
|
|
@ -376,6 +374,37 @@
|
|||
`(,mk-sub-name ,@(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)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
|
|
@ -405,43 +434,41 @@
|
|||
(cdr preds)))]))])
|
||||
(flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
|
||||
[else
|
||||
(let* ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
|
||||
[pos-contract/procs (map contract-pos-proc 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)))]))))))]))
|
||||
(let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)])
|
||||
(make-and/c contracts))]))
|
||||
|
||||
(define-struct/prop any/c ()
|
||||
((pos-proj-prop any-curried-proj)
|
||||
(neg-proj-prop any-curried-proj)
|
||||
(stronger-prop (λ (this that) (any/c? that)))
|
||||
(name-prop (λ (ctc) 'any/c))
|
||||
(first-order-prop (λ (ctc) (λ (val) #t)))
|
||||
(flat-prop (λ (ctc) (λ (x) #t)))))
|
||||
|
||||
(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)
|
||||
(or (flat-contract? pred)
|
||||
(and (procedure? pred)
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ add struct contracts for immutable structs?
|
|||
|
||||
(define-for-syntax (make-define/contract-transformer contract-id id)
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(λ (stx)
|
||||
(with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")]
|
||||
[contract-id contract-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)
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(λ (stx)
|
||||
(with-syntax ([neg-stx (datum->syntax-object stx 'here)]
|
||||
[contract-id contract-id]
|
||||
[id id]
|
||||
|
|
@ -215,7 +215,7 @@ add struct contracts for immutable structs?
|
|||
provide-stx
|
||||
(syntax name))]
|
||||
[(struct name (fields ...))
|
||||
(for-each (lambda (field)
|
||||
(for-each (λ (field)
|
||||
(syntax-case field ()
|
||||
[(x y)
|
||||
(identifier? (syntax x))
|
||||
|
|
@ -272,8 +272,8 @@ add struct contracts for immutable structs?
|
|||
[(a b) (syntax a)]
|
||||
[else struct-name-position])]
|
||||
[super-id (syntax-case struct-name-position ()
|
||||
[(a b) (syntax b)]
|
||||
[else #t])]
|
||||
[(a b) (syntax b)]
|
||||
[else #t])]
|
||||
[struct-info (extract-struct-info struct-name-position)]
|
||||
[constructor-id (list-ref struct-info 1)]
|
||||
[predicate-id (list-ref struct-info 2)]
|
||||
|
|
@ -291,7 +291,7 @@ add struct contracts for immutable structs?
|
|||
provide-stx
|
||||
struct-name)]
|
||||
[else (length fields)]))))]
|
||||
[field-contract-ids (map (lambda (field-name)
|
||||
[field-contract-ids (map (λ (field-name)
|
||||
(a:mangle-id provide-stx
|
||||
"provide/contract-field-contract"
|
||||
field-name
|
||||
|
|
@ -305,22 +305,28 @@ add struct contracts for immutable structs?
|
|||
"struct:"
|
||||
(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?
|
||||
(λ (index)
|
||||
(or (not parent-struct-count)
|
||||
(parent-struct-count . <= . index)))])
|
||||
[is-new-id?
|
||||
(λ (index)
|
||||
(or (not parent-struct-count)
|
||||
(parent-struct-count . <= . index)))])
|
||||
|
||||
(let ([unknown-info
|
||||
(lambda (what names)
|
||||
(λ (what names)
|
||||
(raise-syntax-error
|
||||
'provide/contract
|
||||
(format "cannot determine ~a, found ~s" what names)
|
||||
provide-stx
|
||||
struct-name))]
|
||||
[is-id-ok?
|
||||
(lambda (id i)
|
||||
(λ (id i)
|
||||
(if (or (not parent-struct-count)
|
||||
(parent-struct-count . <= . i))
|
||||
id
|
||||
|
|
@ -330,13 +336,13 @@ add struct contracts for immutable structs?
|
|||
(unless predicate-id (unknown-info "predicate" predicate-id))
|
||||
(unless (andmap/count is-id-ok? selector-ids)
|
||||
(unknown-info "selectors"
|
||||
(map (lambda (x) (if (syntax? x)
|
||||
(map (λ (x) (if (syntax? x)
|
||||
(syntax-object->datum x)
|
||||
x))
|
||||
selector-ids)))
|
||||
(unless (andmap/count is-id-ok? mutator-ids)
|
||||
(unknown-info "mutators"
|
||||
(map (lambda (x) (if (syntax? x)
|
||||
(map (λ (x) (if (syntax? x)
|
||||
(syntax-object->datum x)
|
||||
x))
|
||||
mutator-ids))))
|
||||
|
|
@ -360,8 +366,8 @@ add struct contracts for immutable structs?
|
|||
|
||||
(with-syntax ([((selector-codes selector-new-names) ...)
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map/count (lambda (selector-id field-contract-id index)
|
||||
(λ (x) x)
|
||||
(map/count (λ (selector-id field-contract-id index)
|
||||
(if (is-new-id? index)
|
||||
(code-for-one-id/new-name
|
||||
stx
|
||||
|
|
@ -376,16 +382,16 @@ add struct contracts for immutable structs?
|
|||
[(rev-selector-old-names ...)
|
||||
(reverse
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map/count (lambda (selector-id index)
|
||||
(λ (x) x)
|
||||
(map/count (λ (selector-id index)
|
||||
(if (not (is-new-id? index))
|
||||
selector-id
|
||||
#f))
|
||||
selector-ids)))]
|
||||
[((mutator-codes mutator-new-names) ...)
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map/count (lambda (mutator-id field-contract-id index)
|
||||
(λ (x) x)
|
||||
(map/count (λ (mutator-id field-contract-id index)
|
||||
(if (is-new-id? index)
|
||||
(code-for-one-id/new-name stx
|
||||
mutator-id
|
||||
|
|
@ -399,8 +405,8 @@ add struct contracts for immutable structs?
|
|||
[(rev-mutator-old-names ...)
|
||||
(reverse
|
||||
(filter
|
||||
(lambda (x) x)
|
||||
(map/count (lambda (mutator-id index)
|
||||
(λ (x) x)
|
||||
(map/count (λ (mutator-id index)
|
||||
(if (not (is-new-id? index))
|
||||
mutator-id
|
||||
#f))
|
||||
|
|
@ -424,7 +430,7 @@ add struct contracts for immutable structs?
|
|||
"provide/contract-struct-expandsion-info-id"
|
||||
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
|
||||
(with-syntax ([super-id super-id])
|
||||
|
|
@ -432,7 +438,7 @@ add struct contracts for immutable structs?
|
|||
(syntax (begin
|
||||
(provide (rename id-rename struct-name))
|
||||
(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) #'predicate-new-name)
|
||||
(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) ...
|
||||
((syntax-local-certifier) #'rev-mutator-old-names) ...)
|
||||
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
|
||||
(begin
|
||||
struct-code
|
||||
|
|
@ -449,7 +458,23 @@ add struct contracts for immutable structs?
|
|||
mutator-codes ...
|
||||
predicate-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)
|
||||
#;
|
||||
|
|
@ -491,7 +516,7 @@ add struct contracts for immutable structs?
|
|||
[(a b)
|
||||
(syntax-local-value
|
||||
(syntax b)
|
||||
(lambda ()
|
||||
(λ ()
|
||||
(raise-syntax-error 'provide/contract
|
||||
"expected a struct name"
|
||||
provide-stx
|
||||
|
|
@ -505,7 +530,7 @@ add struct contracts for immutable structs?
|
|||
[_ stx])])
|
||||
(syntax-local-value
|
||||
id
|
||||
(lambda ()
|
||||
(λ ()
|
||||
(raise-syntax-error 'provide/contract
|
||||
"expected a struct name"
|
||||
provide-stx
|
||||
|
|
@ -519,14 +544,14 @@ add struct contracts for immutable structs?
|
|||
(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
|
||||
;; constructs the contract for a selector
|
||||
(define (build-selector-contract struct-name predicate-id field-contract-id)
|
||||
(with-syntax ([field-contract-id field-contract-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))))
|
||||
|
||||
|
|
@ -535,7 +560,7 @@ add struct contracts for immutable structs?
|
|||
(define (build-mutator-contract struct-name predicate-id field-contract-id)
|
||||
(with-syntax ([field-contract-id field-contract-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
|
||||
. -> .
|
||||
void?))))
|
||||
|
|
@ -696,7 +721,8 @@ add struct contracts for immutable structs?
|
|||
(λ (blame src str)
|
||||
(let ([proc (contract-neg-proc arg)])
|
||||
(λ (val)
|
||||
((proc blame src str) val))))))]))
|
||||
((proc blame src str) val))))
|
||||
#f))]))
|
||||
|
||||
(define (check-contract ctc)
|
||||
(unless (contract? ctc)
|
||||
|
|
@ -751,15 +777,15 @@ add struct contracts for immutable structs?
|
|||
(with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))]
|
||||
[(pred-id ...) (generate-temporaries (syntax (ctc ...)))])
|
||||
(syntax
|
||||
(let* ([pred (lambda (x) (error 'flat-rec-contract "applied too soon"))]
|
||||
[name (flat-contract (let ([name (lambda (x) (pred x))]) name))])
|
||||
(let ([ctc-id (coerce-contract flat-rec-contract ctc)] ...)
|
||||
(let* ([pred (λ (x) (error 'flat-rec-contract "applied too soon"))]
|
||||
[name (flat-contract (let ([name (λ (x) (pred x))]) name))])
|
||||
(let ([ctc-id (coerce-contract 'flat-rec-contract ctc)] ...)
|
||||
(unless (flat-contract? ctc-id)
|
||||
(error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id))
|
||||
...
|
||||
(set! pred
|
||||
(let ([pred-id (flat-contract-predicate ctc-id)] ...)
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(or (pred-id x) ...))))
|
||||
name))))]
|
||||
[(_ name ctc ...)
|
||||
|
|
@ -775,9 +801,9 @@ add struct contracts for immutable structs?
|
|||
[((pred-arm-id ...) ...) (map generate-temporaries
|
||||
(syntax->list (syntax ((ctc ...) ...))))])
|
||||
(syntax
|
||||
(let* ([pred-id (lambda (x) (error 'flat-murec-contract "applied too soon"))] ...
|
||||
[name (flat-contract (let ([name (lambda (x) (pred-id x))]) name))] ...)
|
||||
(let-values ([(ctc-id ...) (values (coerce-contract flat-rec-contract ctc) ...)] ...)
|
||||
(let* ([pred-id (λ (x) (error 'flat-murec-contract "applied too soon"))] ...
|
||||
[name (flat-contract (let ([name (λ (x) (pred-id x))]) name))] ...)
|
||||
(let-values ([(ctc-id ...) (values (coerce-contract 'flat-rec-contract ctc) ...)] ...)
|
||||
(begin
|
||||
(void)
|
||||
(unless (flat-contract? ctc-id)
|
||||
|
|
@ -785,12 +811,12 @@ add struct contracts for immutable structs?
|
|||
...) ...
|
||||
(set! pred-id
|
||||
(let ([pred-arm-id (flat-contract-predicate ctc-id)] ...)
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(or (pred-arm-id x) ...)))) ...
|
||||
body1
|
||||
body ...))))]
|
||||
[(_ ([name ctc ...] ...) body1 body ...)
|
||||
(for-each (lambda (name)
|
||||
(for-each (λ (name)
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error 'flat-rec-contract
|
||||
"expected an identifier" stx name)))
|
||||
|
|
@ -815,51 +841,53 @@ add struct contracts for immutable structs?
|
|||
[(_ args ...) (syntax (or/c args ...))]
|
||||
[id (syntax or/c)])))
|
||||
|
||||
(define (or/c . args)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (or (contract? x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x 1)))
|
||||
(error 'or/c "expected procedures of arity 1 or contracts, given: ~e" x)))
|
||||
args)
|
||||
(let-values ([(contract fc/predicates)
|
||||
(let loop ([contract #f]
|
||||
[fc/predicates null]
|
||||
[args args])
|
||||
(cond
|
||||
[(null? args) (values contract (reverse fc/predicates))]
|
||||
[else
|
||||
(let ([arg (car args)])
|
||||
(cond
|
||||
[(or (flat-contract? arg)
|
||||
(not (contract? arg)))
|
||||
(loop contract (cons arg fc/predicates) (cdr args))]
|
||||
[contract
|
||||
(error 'or/c "expected at most one non-flat contract, given ~e and ~e"
|
||||
contract
|
||||
arg)]
|
||||
[else (loop arg fc/predicates (cdr args))]))]))])
|
||||
(let ([flat-contracts (map (lambda (x) (if (flat-contract? x)
|
||||
x
|
||||
(flat-contract x)))
|
||||
fc/predicates)])
|
||||
(cond
|
||||
[contract
|
||||
(make-or/c flat-contracts contract)]
|
||||
[else
|
||||
(make-flat-or/c flat-contracts)]))))
|
||||
(define or/c
|
||||
(case-lambda
|
||||
[() (make-none/c '(or/c))]
|
||||
[args
|
||||
(for-each
|
||||
(λ (x)
|
||||
(unless (or (contract? x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x 1)))
|
||||
(error 'or/c "expected procedures of arity 1 or contracts, given: ~e" x)))
|
||||
args)
|
||||
(let-values ([(ho-contracts fc/predicates)
|
||||
(let loop ([ho-contracts '()]
|
||||
[fc/predicates null]
|
||||
[args args])
|
||||
(cond
|
||||
[(null? args) (values ho-contracts (reverse fc/predicates))]
|
||||
[else
|
||||
(let ([arg (car args)])
|
||||
(cond
|
||||
[(and (contract? arg)
|
||||
(not (flat-contract? arg)))
|
||||
(loop (cons arg ho-contracts) fc/predicates (cdr args))]
|
||||
[else
|
||||
(loop ho-contracts (cons arg fc/predicates) (cdr args))]))]))])
|
||||
(let ([flat-contracts (map (λ (x) (if (flat-contract? x)
|
||||
x
|
||||
(flat-contract x)))
|
||||
fc/predicates)])
|
||||
(cond
|
||||
[(null? ho-contracts)
|
||||
(make-flat-or/c flat-contracts)]
|
||||
[(null? (cdr ho-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)
|
||||
((pos-proj-prop (λ (ctc)
|
||||
(let ([c-proc ((pos-proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(or/c-flat-ctcs ctc))])
|
||||
(lambda (pos src-info orig-str)
|
||||
(λ (pos src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos src-info orig-str)])
|
||||
(lambda (val)
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (lambda (pred) (pred val)) predicates)
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(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))]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(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)])
|
||||
(lambda (val)
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (lambda (pred) (pred val)) predicates)
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(partial-contract val)])))))))
|
||||
|
|
@ -882,17 +910,100 @@ add struct contracts for immutable structs?
|
|||
'or/c
|
||||
(or/c-ho-ctc 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
|
||||
(λ (this that)
|
||||
(and (or/c? that)
|
||||
(and
|
||||
(contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that))
|
||||
(let ([this-ctcs (or/c-flat-ctcs this)]
|
||||
[that-ctcs (or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs)))))))))
|
||||
(contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that))
|
||||
(let ([this-ctcs (or/c-flat-ctcs this)]
|
||||
[that-ctcs (or/c-flat-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-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)
|
||||
((pos-proj-prop flat-pos-proj)
|
||||
|
|
@ -919,14 +1030,14 @@ add struct contracts for immutable structs?
|
|||
(define false/c
|
||||
(flat-named-contract
|
||||
'false/c
|
||||
(lambda (x) (not x))))
|
||||
(λ (x) (not x))))
|
||||
|
||||
(define (string/len n)
|
||||
(unless (number? n)
|
||||
(error 'string/len "expected a number as argument, got ~e" n))
|
||||
(flat-named-contract
|
||||
`(string/len ,n)
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(and (string? x)
|
||||
((string-length x) . < . n)))))
|
||||
|
||||
|
|
@ -935,7 +1046,7 @@ add struct contracts for immutable structs?
|
|||
(error 'symbols "expected at least one argument"))
|
||||
(unless (andmap symbol? ss)
|
||||
(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))
|
||||
|
||||
(define atomic-value?
|
||||
|
|
@ -979,7 +1090,7 @@ add struct contracts for immutable structs?
|
|||
(define printable/c
|
||||
(flat-named-contract
|
||||
'printable/c
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(let printable? ([x x])
|
||||
(or (symbol? x)
|
||||
(string? x)
|
||||
|
|
@ -1027,16 +1138,16 @@ add struct contracts for immutable structs?
|
|||
(define (</c x)
|
||||
(flat-named-contract
|
||||
`(</c ,x)
|
||||
(lambda (y) (and (number? y) (< y x)))))
|
||||
(λ (y) (and (number? y) (< y x)))))
|
||||
(define (>/c x)
|
||||
(flat-named-contract
|
||||
`(>/c ,x)
|
||||
(lambda (y) (and (number? y) (> y x)))))
|
||||
(λ (y) (and (number? y) (> y x)))))
|
||||
|
||||
(define natural-number/c
|
||||
(flat-named-contract
|
||||
'natural-number/c
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(and (number? x)
|
||||
(integer? x)
|
||||
(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))
|
||||
(flat-named-contract
|
||||
`(integer-in ,start ,end)
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(and (integer? x)
|
||||
(<= 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))
|
||||
(flat-named-contract
|
||||
`(exact-integer-in ,start ,end)
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(and (integer? x)
|
||||
(exact? x)
|
||||
(<= 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))
|
||||
(flat-named-contract
|
||||
`(real-in ,start ,end)
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(and (real? x)
|
||||
(<= 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))
|
||||
(build-flat-contract
|
||||
(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)
|
||||
(unless (flat-contract/predicate? p)
|
||||
(error 'listof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
|
||||
(build-flat-contract
|
||||
(build-compound-type-name 'listof (proc/ctc->ctc p))
|
||||
(lambda (v)
|
||||
(λ (v)
|
||||
(and (list? v)
|
||||
(andmap (lambda (ele) (test-proc/flat-contract p ele))
|
||||
(andmap (λ (ele) (test-proc/flat-contract p ele))
|
||||
v)))))
|
||||
|
||||
(define-syntax (*-immutableof stx)
|
||||
(syntax-case stx ()
|
||||
[(_ predicate? fill type-name name)
|
||||
(identifier? (syntax predicate?))
|
||||
(syntax
|
||||
(let ([predicate?-name predicate?]
|
||||
[fill-name fill])
|
||||
(lambda (input)
|
||||
(let* ([ctc (coerce-contract name input)]
|
||||
(let ([fill-name fill])
|
||||
(λ (input)
|
||||
(let* ([ctc (coerce-contract 'name input)]
|
||||
[p-proj (contract-pos-proc ctc)]
|
||||
[n-proj (contract-neg-proc ctc)])
|
||||
(make-pair-proj-contract
|
||||
(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)])
|
||||
(lambda (val)
|
||||
(unless (predicate?-name val)
|
||||
(λ (val)
|
||||
(unless (predicate? val)
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
|
|
@ -1116,10 +1227,11 @@ add struct contracts for immutable structs?
|
|||
'type-name
|
||||
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)])
|
||||
(lambda (val)
|
||||
(fill-name n-app val)))))))))]))
|
||||
(λ (val)
|
||||
(fill-name n-app val))))
|
||||
predicate?)))))]))
|
||||
|
||||
(define (map-immutable f lst)
|
||||
(let loop ([lst lst])
|
||||
|
|
@ -1129,20 +1241,21 @@ add struct contracts for immutable structs?
|
|||
(loop (cdr lst)))]
|
||||
[(null? lst) null])))
|
||||
|
||||
(define (immutable-list? lst)
|
||||
(cond
|
||||
[(and (pair? lst)
|
||||
(immutable? lst))
|
||||
(immutable-list? (cdr lst))]
|
||||
[(null? lst) #t]
|
||||
[else #f]))
|
||||
(define (immutable-list? val)
|
||||
(let loop ([v val])
|
||||
(or (and (pair? v)
|
||||
(immutable? v)
|
||||
(loop (cdr v)))
|
||||
(null? v))))
|
||||
|
||||
(define list-immutableof
|
||||
(*-immutableof immutable-list? map-immutable immutable-list list-immutableof))
|
||||
|
||||
(define (immutable-vector? val) (and (immutable? val) (vector? val)))
|
||||
|
||||
(define vector-immutableof
|
||||
(*-immutableof (lambda (x) (and (vector? x) (immutable? x)))
|
||||
(lambda (f v) (apply vector-immutable (map f (vector->list v))))
|
||||
(*-immutableof immutable-vector?
|
||||
(λ (f v) (apply vector-immutable (map f (vector->list v))))
|
||||
immutable-vector
|
||||
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))
|
||||
(build-flat-contract
|
||||
(build-compound-type-name 'vectorof (proc/ctc->ctc p))
|
||||
(lambda (v)
|
||||
(λ (v)
|
||||
(and (vector? v)
|
||||
(andmap (lambda (ele) (test-proc/flat-contract p ele))
|
||||
(andmap (λ (ele) (test-proc/flat-contract p ele))
|
||||
(vector->list v))))))
|
||||
|
||||
(define (vector/c . args)
|
||||
|
|
@ -1169,7 +1282,7 @@ add struct contracts for immutable structs?
|
|||
(let ([largs (length args)])
|
||||
(build-flat-contract
|
||||
(apply build-compound-type-name 'vector/c (map proc/ctc->ctc args))
|
||||
(lambda (v)
|
||||
(λ (v)
|
||||
(and (vector? v)
|
||||
(= (vector-length v) largs)
|
||||
(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))
|
||||
(build-flat-contract
|
||||
(build-compound-type-name 'box/c (proc/ctc->ctc pred))
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(and (box? 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))
|
||||
(build-flat-contract
|
||||
(build-compound-type-name 'cons/c (proc/ctc->ctc hdp) (proc/ctc->ctc tlp))
|
||||
(lambda (x)
|
||||
(λ (x)
|
||||
(and (pair? x)
|
||||
(test-proc/flat-contract hdp (car x))
|
||||
(test-proc/flat-contract tlp (cdr x))))))
|
||||
|
|
@ -1210,16 +1323,16 @@ add struct contracts for immutable structs?
|
|||
(let ([predicate?-name predicate?]
|
||||
[constructor-name constructor]
|
||||
[selector-names selectors] ...)
|
||||
(lambda (params ...)
|
||||
(let ([ctc-x (coerce-contract name params)] ...)
|
||||
(λ (params ...)
|
||||
(let ([ctc-x (coerce-contract 'name params)] ...)
|
||||
(let ([pos-procs (contract-pos-proc ctc-x)]
|
||||
...
|
||||
[neg-procs (contract-neg-proc ctc-x)] ...)
|
||||
(make-pair-proj-contract
|
||||
(build-compound-type-name 'name (proc/ctc->ctc params) ...)
|
||||
(lambda (blame src-info orig-str)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-apps (pos-procs blame src-info orig-str)] ...)
|
||||
(lambda (v)
|
||||
(λ (v)
|
||||
(if (and (immutable? v)
|
||||
(predicate?-name v))
|
||||
(constructor-name (p-apps (selector-names v)) ...)
|
||||
|
|
@ -1231,26 +1344,27 @@ add struct contracts for immutable structs?
|
|||
"expected <~a>, given: ~e"
|
||||
'type-name
|
||||
v)))))
|
||||
(lambda (blame src-info orig-str)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-apps (neg-procs blame src-info orig-str)] ...)
|
||||
(lambda (v)
|
||||
(constructor-name (p-apps (selector-names v)) ...)))))))))))]
|
||||
(λ (v)
|
||||
(constructor-name (p-apps (selector-names v)) ...))))
|
||||
#f)))))))]
|
||||
[(_ predicate? constructor (arb? selector) correct-size type-name name)
|
||||
(eq? #t (syntax-object->datum (syntax arb?)))
|
||||
(syntax
|
||||
(let ([predicate?-name predicate?]
|
||||
[constructor-name constructor]
|
||||
[selector-name selector])
|
||||
(lambda params
|
||||
(let ([ctcs (map (lambda (param) (coerce-contract name param)) params)])
|
||||
(λ params
|
||||
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
|
||||
(let ([pos-procs (map contract-pos-proc ctcs)]
|
||||
[neg-procs (map contract-neg-proc ctcs)])
|
||||
(make-pair-proj-contract
|
||||
(apply build-compound-type-name 'name (map proc/ctc->ctc params))
|
||||
(lambda (blame src-info orig-str)
|
||||
(let ([p-apps (map (lambda (proc) (proc blame src-info orig-str)) pos-procs)]
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-apps (map (λ (proc) (proc blame src-info orig-str)) pos-procs)]
|
||||
[count (length params)])
|
||||
(lambda (v)
|
||||
(λ (v)
|
||||
(if (and (immutable? v)
|
||||
(predicate?-name v)
|
||||
(correct-size count v))
|
||||
|
|
@ -1270,9 +1384,9 @@ add struct contracts for immutable structs?
|
|||
"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)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-apps (map (λ (proc) (proc blame src-info orig-str)) neg-procs)])
|
||||
(λ (v)
|
||||
(apply constructor-name
|
||||
(let loop ([p-apps p-apps]
|
||||
[i 0])
|
||||
|
|
@ -1280,14 +1394,15 @@ add struct contracts for immutable structs?
|
|||
[(null? p-apps) null]
|
||||
[else (let ([p-app (car p-apps)])
|
||||
(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 box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
|
||||
(define vector-immutable/c (*-immutable/c vector?
|
||||
vector-immutable
|
||||
(#t (lambda (v i) (vector-ref v i)))
|
||||
(lambda (n v) (= n (vector-length v)))
|
||||
(#t (λ (v i) (vector-ref v i)))
|
||||
(λ (n v) (= n (vector-length v)))
|
||||
immutable-vector
|
||||
vector-immutable/c))
|
||||
|
||||
|
|
@ -1307,7 +1422,7 @@ add struct contracts for immutable structs?
|
|||
[else (cons/c (car args) (loop (cdr args)))])))
|
||||
|
||||
(define (list-immutable/c . args)
|
||||
(unless (andmap (lambda (x) (or (contract? x)
|
||||
(unless (andmap (λ (x) (or (contract? x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x 1))))
|
||||
args)
|
||||
|
|
@ -1325,24 +1440,24 @@ add struct contracts for immutable structs?
|
|||
[else (cons-immutable/c (car args) (loop (cdr args)))])))
|
||||
|
||||
(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-compound-type-name 'syntax/c ctc)
|
||||
(let ([pred (flat-contract-predicate ctc)])
|
||||
(lambda (val)
|
||||
(λ (val)
|
||||
(and (syntax? val)
|
||||
(pred (syntax-e val))))))))
|
||||
|
||||
(define promise/c
|
||||
(lambda (ctc-in)
|
||||
(let* ([ctc (coerce-contract promise/c ctc-in)]
|
||||
(λ (ctc-in)
|
||||
(let* ([ctc (coerce-contract 'promise/c ctc-in)]
|
||||
[pos-ctc-proc (contract-pos-proc ctc)]
|
||||
[neg-ctc-proc (contract-neg-proc ctc)])
|
||||
(make-pair-proj-contract
|
||||
(build-compound-type-name 'promise/c ctc)
|
||||
(lambda (blame src-info orig-str)
|
||||
(λ (blame src-info orig-str)
|
||||
(let ([p-app (pos-ctc-proc blame src-info orig-str)])
|
||||
(lambda (val)
|
||||
(λ (val)
|
||||
(unless (promise? val)
|
||||
(raise-contract-error
|
||||
val
|
||||
|
|
@ -1353,10 +1468,11 @@ add struct contracts for immutable structs?
|
|||
"expected <promise>, given: ~e"
|
||||
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)])
|
||||
(lambda (val)
|
||||
(delay (p-app (force val))))))))))
|
||||
(λ (val)
|
||||
(delay (p-app (force val))))))
|
||||
promise?))))
|
||||
|
||||
#|
|
||||
as with copy-struct in struct.ss, this first begin0
|
||||
|
|
@ -1372,7 +1488,7 @@ add struct contracts for immutable structs?
|
|||
(syntax-case stx ()
|
||||
[(_ struct-name args ...)
|
||||
(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 ...)))]
|
||||
[(ctc-name-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))])
|
||||
(with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))])
|
||||
(syntax
|
||||
(let ([ctc-x (coerce-contract struct/c args)] ...)
|
||||
(let ([ctc-x (coerce-contract 'struct/c args)] ...)
|
||||
|
||||
(unless predicate-id
|
||||
(error 'struct/c "could not determine predicate for ~s" 'struct-name))
|
||||
|
|
|
|||
|
|
@ -128,6 +128,9 @@
|
|||
(test/no-error '(listof any/c))
|
||||
(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
|
||||
'contract-arrow-star0a
|
||||
'(contract (->* (integer?) (integer?))
|
||||
|
|
@ -1134,6 +1137,34 @@
|
|||
'neg)
|
||||
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
|
||||
'contract-case->1
|
||||
'(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
|
|
@ -1335,6 +1366,47 @@
|
|||
#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
|
||||
'(1 2)
|
||||
'or/c-ordering
|
||||
|
|
@ -1365,6 +1437,20 @@
|
|||
'neg)
|
||||
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
|
||||
'define/contract1
|
||||
'(let ()
|
||||
|
|
@ -3964,6 +4050,7 @@
|
|||
(-> integer? integer? integer?))
|
||||
(case-> (->r ((x number?) (y boolean?) (z pair?)) number?)
|
||||
(-> integer? integer? integer?)))
|
||||
(test-name '(case->) (case->))
|
||||
|
||||
(test-name '(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 #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 ()
|
||||
(define-contract-struct couple (hd tl))
|
||||
(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 #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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user