From 79ae279b79dba87c058d4ac6a610c1d50fa32932 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 6 Jul 2006 02:08:12 +0000 Subject: [PATCH] extended or/c to support multiple higher-order contracts svn: r3606 --- collects/mzlib/contract.ss | 4 +- collects/mzlib/private/contract-arrow.ss | 189 +++++--- collects/mzlib/private/contract-ds-helpers.ss | 4 +- collects/mzlib/private/contract-ds.ss | 3 +- collects/mzlib/private/contract-guts.ss | 141 +++--- collects/mzlib/private/contract.ss | 434 +++++++++++------- collects/tests/mzscheme/contract-test.ss | 289 ++++++++++++ 7 files changed, 778 insertions(+), 286 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 902719f243..dc8244a675 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -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"))) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index d33816528d..99b09ef096 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.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))) @@ -2054,6 +2103,14 @@ "expected a procedure that accepts ~a arguments, given: ~e" 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) diff --git a/collects/mzlib/private/contract-ds-helpers.ss b/collects/mzlib/private/contract-ds-helpers.ss index 607e77aba2..12156d0453 100644 --- a/collects/mzlib/private/contract-ds-helpers.ss +++ b/collects/mzlib/private/contract-ds-helpers.ss @@ -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))]))])))) diff --git a/collects/mzlib/private/contract-ds.ss b/collects/mzlib/private/contract-ds.ss index b49796a3af..853f71e883 100644 --- a/collects/mzlib/private/contract-ds.ss +++ b/collects/mzlib/private/contract-ds.ss @@ -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)) diff --git a/collects/mzlib/private/contract-guts.ss b/collects/mzlib/private/contract-guts.ss index 79150114ba..49caec6c48 100644 --- a/collects/mzlib/private/contract-guts.ss +++ b/collects/mzlib/private/contract-guts.ss @@ -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 @@ -32,6 +33,8 @@ define-struct/prop contract-stronger? + + contract-first-order-passes? proj-pred? proj-get pos-proj-prop pos-proj-pred? pos-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 @@ -94,12 +100,26 @@ (make-struct-type-property 'contract-stronger-than)) (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? @@ -375,7 +373,38 @@ (let ([mk-sub-name (contract-name sub)]) `(,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) diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index 6217f11a5a..66c0375148 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -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)]))))))) @@ -881,18 +909,101 @@ add struct contracts for immutable structs? (apply build-compound-type-name 'or/c (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 (λ (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 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 , 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)) + (*-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 , 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)) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index e96cfe5035..79433d596d 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -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)