From 21cbd9ad81eb35dc4d39d6063db25fcb1cc94bbc Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 20 Apr 2011 16:49:39 -0500 Subject: [PATCH] added the racket/contract/combinator library, and documented and adjusted these libraries: racket/contract/base racket/contract/exists racket/contract/parametric (renamed from exists) racket/contract/region --- collects/mzlib/contract.rkt | 6 +- collects/mzlib/integer-set.rkt | 2 +- .../mzlib/private/contract-arr-checks.rkt | 3 +- .../private/contract-arr-obj-helpers.rkt | 1 + collects/mzlib/private/contract-arrow.rkt | 1 + collects/mzlib/private/contract-mutable.rkt | 3 +- collects/mzlib/private/contract-object.rkt | 1 + collects/mzlib/private/contract-struct.rkt | 3 +- collects/mzlib/private/unit-contract.rkt | 1 + collects/mzlib/unit.rkt | 2 + collects/racket/contract.rkt | 27 +- collects/racket/contract/base.rkt | 38 +- collects/racket/contract/combinator.rkt | 23 + collects/racket/contract/parametric.rkt | 6 + .../racket/contract/private/arr-i-old.rkt | 600 ------------------ .../racket/contract/private/arr-i-parse.rkt | 2 + collects/racket/contract/private/arr-i.rkt | 1 + collects/racket/contract/private/arrow.rkt | 1 + collects/racket/contract/private/base.rkt | 3 +- .../racket/contract/private/basic-opters.rkt | 3 +- collects/racket/contract/private/box.rkt | 3 +- collects/racket/contract/private/ds.rkt | 3 +- .../racket/contract/{ => private}/exists.rkt | 6 +- collects/racket/contract/private/guts.rkt | 200 +----- collects/racket/contract/private/hash.rkt | 3 +- collects/racket/contract/private/legacy.rkt | 2 +- collects/racket/contract/private/misc.rkt | 244 ++++++- collects/racket/contract/private/object.rkt | 3 +- collects/racket/contract/private/opt-guts.rkt | 3 +- collects/racket/contract/private/opt.rkt | 1 + collects/racket/contract/private/opters.rkt | 1 + .../racket/contract/private/parametric.rkt | 1 + collects/racket/contract/private/provide.rkt | 3 +- collects/racket/contract/private/struct.rkt | 3 +- collects/racket/contract/private/vector.rkt | 3 +- .../contract/{regions.rkt => region.rkt} | 6 +- collects/racket/dict.rkt | 8 +- collects/racket/private/class-internal.rkt | 1 + collects/scheme/exists/lang.rkt | 2 +- .../scribblings/reference/contracts.scrbl | 331 +++++----- .../syntax/parse/experimental/provide.rkt | 1 + .../syntax/parse/experimental/reflect.rkt | 1 + collects/syntax/parse/private/rep-data.rkt | 8 +- collects/typed-scheme/private/with-types.rkt | 2 +- collects/unstable/prop-contract.rkt | 3 +- collects/web-server/stuffers/stuffer.rkt | 1 - collects/xml/private/structures.rkt | 3 +- 47 files changed, 524 insertions(+), 1049 deletions(-) create mode 100644 collects/racket/contract/combinator.rkt create mode 100644 collects/racket/contract/parametric.rkt delete mode 100644 collects/racket/contract/private/arr-i-old.rkt rename collects/racket/contract/{ => private}/exists.rkt (93%) rename collects/racket/contract/{regions.rkt => region.rkt} (99%) diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index de5df8c078..b5152e0f1f 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -51,7 +51,8 @@ racket/contract/private/blame racket/contract/private/ds racket/contract/private/opt - racket/contract/private/basic-opters) + racket/contract/private/basic-opters + racket/contract/combinator) (provide opt/c define-opt/c ;(all-from "private/contract-opt.rkt") @@ -70,5 +71,6 @@ check-flat-contract check-flat-named-contract) (all-from-out racket/contract/private/prop - racket/contract/private/blame)) + racket/contract/private/blame + racket/contract/combinator)) diff --git a/collects/mzlib/integer-set.rkt b/collects/mzlib/integer-set.rkt index 6c14cb1271..c32ff58c8a 100644 --- a/collects/mzlib/integer-set.rkt +++ b/collects/mzlib/integer-set.rkt @@ -428,7 +428,7 @@ (provide well-formed-set?) - (provide/contract (struct integer-set ((contents (flat-named-contract "integer-set-list" well-formed-set?)))) + (provide/contract (struct integer-set ((contents well-formed-set?))) (make-range (->i () ((i exact-integer?) (j (i) (and/c exact-integer? (>=/c i)))) [res integer-set?])) (rename merge union (integer-set? integer-set? . -> . integer-set?)) diff --git a/collects/mzlib/private/contract-arr-checks.rkt b/collects/mzlib/private/contract-arr-checks.rkt index fbb579d97c..1bbf5d59c8 100644 --- a/collects/mzlib/private/contract-arr-checks.rkt +++ b/collects/mzlib/private/contract-arr-checks.rkt @@ -2,7 +2,8 @@ (provide (all-defined-out)) (require racket/contract/private/guts - racket/contract/private/blame) + racket/contract/private/blame + racket/contract/private/misc) (define empty-case-lambda/c (flat-named-contract '(case->) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.rkt b/collects/mzlib/private/contract-arr-obj-helpers.rkt index df53d20995..d72c58ca32 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.rkt +++ b/collects/mzlib/private/contract-arr-obj-helpers.rkt @@ -5,6 +5,7 @@ (require (for-syntax scheme/base)) (require (for-template scheme/base) (for-template racket/contract/private/guts + racket/contract/private/misc racket/contract/private/prop racket/contract/private/blame) (for-template "contract-arr-checks.rkt")) diff --git a/collects/mzlib/private/contract-arrow.rkt b/collects/mzlib/private/contract-arrow.rkt index 13da6f298f..6471de6009 100644 --- a/collects/mzlib/private/contract-arrow.rkt +++ b/collects/mzlib/private/contract-arrow.rkt @@ -4,6 +4,7 @@ racket/contract/private/blame racket/contract/private/prop racket/contract/private/opt + racket/contract/private/misc "contract-arr-checks.rkt") (require (for-syntax racket/base) (for-syntax racket/contract/private/opt-guts) diff --git a/collects/mzlib/private/contract-mutable.rkt b/collects/mzlib/private/contract-mutable.rkt index e6708f8e8f..ca1670f41a 100644 --- a/collects/mzlib/private/contract-mutable.rkt +++ b/collects/mzlib/private/contract-mutable.rkt @@ -5,7 +5,8 @@ vector-immutableof vector-immutable/c) racket/contract/private/blame racket/contract/private/guts - racket/contract/private/prop) + racket/contract/private/prop + racket/contract/private/misc) (provide box/c box-immutable/c vector/c vectorof vector-immutableof vector-immutable/c) diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index 31e4896640..57b9ee0bc2 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "contract-arrow.rkt" racket/contract/private/guts + racket/contract/private/misc racket/contract/private/prop racket/private/class-internal "contract-arr-checks.rkt") diff --git a/collects/mzlib/private/contract-struct.rkt b/collects/mzlib/private/contract-struct.rkt index 55d5d03027..42af731685 100644 --- a/collects/mzlib/private/contract-struct.rkt +++ b/collects/mzlib/private/contract-struct.rkt @@ -3,7 +3,8 @@ (require (for-syntax racket/base racket/contract/private/helpers racket/struct-info) - racket/contract/private/guts) + racket/contract/private/guts + racket/contract/private/misc) (provide struct/c) diff --git a/collects/mzlib/private/unit-contract.rkt b/collects/mzlib/private/unit-contract.rkt index f10df4bef1..f08de1081d 100644 --- a/collects/mzlib/private/unit-contract.rkt +++ b/collects/mzlib/private/unit-contract.rkt @@ -9,6 +9,7 @@ "unit-syntax.rkt") (for-meta 2 racket/base) racket/contract/base + racket/contract/combinator "unit-utils.rkt" "unit-runtime.rkt") diff --git a/collects/mzlib/unit.rkt b/collects/mzlib/unit.rkt index 0f93d85edd..a18a36e39e 100644 --- a/collects/mzlib/unit.rkt +++ b/collects/mzlib/unit.rkt @@ -17,6 +17,8 @@ (require mzlib/etc racket/contract/base + racket/contract/region + racket/contract/combinator scheme/stxparam syntax/location "private/unit-contract.rkt" diff --git a/collects/racket/contract.rkt b/collects/racket/contract.rkt index 4c5e84a9cb..c6813bd63f 100644 --- a/collects/racket/contract.rkt +++ b/collects/racket/contract.rkt @@ -1,19 +1,14 @@ #lang racket/base - -(require racket/contract/exists - racket/contract/regions +(require "contract/base.rkt" + "contract/combinator.rkt" + "contract/parametric.rkt" + "contract/region.rkt" "contract/private/basic-opters.rkt" - "contract/base.rkt" "contract/private/legacy.rkt" - "contract/private/ds.rkt" - "contract/private/parametric.rkt" - "private/define-struct.rkt") - -(provide (all-from-out "contract/base.rkt") - (all-from-out "contract/private/parametric.rkt") - (except-out (all-from-out racket/contract/exists) ∀∃?) - (all-from-out racket/contract/regions) - - (all-from-out "contract/private/legacy.rkt") - (all-from-out "contract/private/ds.rkt")) - + "contract/private/ds.rkt") +(provide (all-from-out "contract/base.rkt" + "contract/combinator.rkt" + "contract/parametric.rkt" + "contract/region.rkt" + "contract/private/legacy.rkt" + "contract/private/ds.rkt")) diff --git a/collects/racket/contract/base.rkt b/collects/racket/contract/base.rkt index b31b22e2d4..586bb04427 100644 --- a/collects/racket/contract/base.rkt +++ b/collects/racket/contract/base.rkt @@ -1,8 +1,5 @@ #lang racket/base -;; A version of racket/contract without contract regions -;; for use in the macro stepper - (require "private/arrow.rkt" "private/arr-i.rkt" "private/base.rkt" @@ -13,7 +10,6 @@ "private/misc.rkt" "private/provide.rkt" "private/guts.rkt" - "private/blame.rkt" "private/prop.rkt" "private/opters.rkt" ;; required for effect to install the opters "private/opt.rkt") @@ -30,30 +26,22 @@ contracted-function-proc contracted-function-ctc make-contracted-function) - (all-from-out "private/arr-i.rkt") - (all-from-out "private/box.rkt") - (all-from-out "private/hash.rkt") - (all-from-out "private/vector.rkt") - (all-from-out "private/struct.rkt") + (all-from-out "private/arr-i.rkt" + "private/box.rkt" + "private/hash.rkt" + "private/vector.rkt" + "private/struct.rkt") + (except-out (all-from-out "private/base.rkt") + current-contract-region) (except-out (all-from-out "private/misc.rkt") check-between/c check-unary-between/c) (all-from-out "private/provide.rkt") - (all-from-out "private/base.rkt") - (except-out (all-from-out "private/guts.rkt") - check-flat-contract - check-flat-named-contract) - - (except-out (all-from-out "private/blame.rkt") make-blame) - - (except-out (all-from-out "private/prop.rkt") - contract-struct-name - contract-struct-first-order - contract-struct-projection - contract-struct-stronger? - contract-struct? - chaperone-contract-struct? - flat-contract-struct?) ;; from private/opt.rkt: - opt/c define-opt/c) + opt/c define-opt/c + + ;; from private/guts.rkt + has-contract? + value-contract + ) diff --git a/collects/racket/contract/combinator.rkt b/collects/racket/contract/combinator.rkt new file mode 100644 index 0000000000..06011d226d --- /dev/null +++ b/collects/racket/contract/combinator.rkt @@ -0,0 +1,23 @@ +#lang racket/base +(require "private/prop.rkt" + "private/guts.rkt" + "private/blame.rkt") + +(provide + (except-out (all-from-out "private/prop.rkt") + contract-struct-name + contract-struct-first-order + contract-struct-projection + contract-struct-stronger? + contract-struct? + chaperone-contract-struct? + flat-contract-struct?) + + (except-out (all-from-out "private/guts.rkt") + check-flat-contract + check-flat-named-contract + make-predicate-contract + has-contract? + value-contract) + + (except-out (all-from-out "private/blame.rkt") make-blame)) diff --git a/collects/racket/contract/parametric.rkt b/collects/racket/contract/parametric.rkt new file mode 100644 index 0000000000..fc0fb30b74 --- /dev/null +++ b/collects/racket/contract/parametric.rkt @@ -0,0 +1,6 @@ +#lang racket/base +(require "private/exists.rkt" + "private/parametric.rkt") +(provide (all-from-out "private/parametric.rkt") + (except-out (all-from-out "private/exists.rkt") + ∀∃?)) diff --git a/collects/racket/contract/private/arr-i-old.rkt b/collects/racket/contract/private/arr-i-old.rkt deleted file mode 100644 index ffc640a377..0000000000 --- a/collects/racket/contract/private/arr-i-old.rkt +++ /dev/null @@ -1,600 +0,0 @@ -#lang racket/base - -(require "guts.rkt" - "arrow.rkt" - "opt.rkt" - "blame.rkt" - "prop.rkt" - racket/stxparam - - (for-syntax racket/base - syntax/stx - syntax/name - "arr-i-parse.rkt" - "opt-guts.rkt" - "helpers.rkt" - "arr-util.rkt")) - -(provide ->i) - -(define-for-syntax (make-this-parameters id) - (if (syntax-parameter-value #'making-a-method) - (list id) - null)) - -;; parses everything after the mandatory and optional doms in a ->d contract -(define-for-syntax (parse-leftover stx leftover) - (let*-values ([(raw-optional-doms leftover) - (syntax-case leftover () - [(kwd . leftover2) - (keyword? (syntax-e #'kwd)) - (values '() leftover)] - [(dep-range) - (values '() leftover)] - [(dep-range #:post . more) - (values '() leftover)] - [((opts ...) . rest) - (values #'(opts ...) #'rest)] - [_ (values '() leftover)])] - [(id/rest-id leftover) - (syntax-case leftover () - [(#:rest [id rest-expr] . leftover) - (and (identifier? #'id) - (not (keyword? (syntax-e #'rest-expr)))) - (values #'(id rest-expr) #'leftover)] - [(#:rest [id (id2 ...) rest-expr] . leftover) - (and (identifier? #'id) - (andmap identifier? (syntax->list #'(id2 ...))) - (not (keyword? (syntax-e #'rest-expr)))) - (values #'(id rest-expr) #'leftover)] - [(#:rest something . leftover) - (raise-syntax-error #f "expected id+ctc" stx #'something)] - [_ (values #f leftover)])] - [(pre-cond leftover) - (syntax-case leftover () - [(#:pre (id ...) pre-cond . leftover) - (values #'pre-cond #'leftover)] - [_ (values #f leftover)])] - [(range leftover) - (syntax-case leftover () - [(range . leftover) (values #'range #'leftover)] - [_ - (raise-syntax-error #f "expected a range expression, but found nothing" stx)])] - [(post-cond leftover) - (syntax-case leftover () - [(#:post (id ...) post-cond . leftover) - (begin - (syntax-case range (any) - [any (raise-syntax-error #f "cannot have a #:post with any as the range" stx #'post-cond)] - [_ (void)]) - (values #'post-cond #'leftover))] - [_ (values #f leftover)])]) - (syntax-case leftover () - [() - (values raw-optional-doms id/rest-id pre-cond range post-cond)] - [_ - (raise-syntax-error #f "bad syntax" stx)]))) - -;; verify-->i-structure : syntax syntax -> syntax -;; returns the second argument when it has the proper shape for the first two arguments to ->i -;; otherwise, raises a syntax error. -;; also: drops the extra identifiers in the ->i. -(define-for-syntax (verify-->i-structure stx doms) - (syntax-case doms () - [((regular ...) (kwd ...)) - (let ([check-pair-shape - (λ (reg) - (syntax-case reg () - [(id dom) - (identifier? #'id) - reg] - [(a b) - (raise-syntax-error #f "expected an identifier" stx #'a)] - - [(id (id2 ...) dom) - (and (identifier? #'id) - (andmap identifier? (syntax->list #'(id2 ...)))) - #'(id dom)] - [(id ids dom) - (unless (identifier? #'id) - (raise-syntax-error #f "expected an identifier" stx #'id)) - (raise-syntax-error #f "expected an sequence of identifiers" stx #'ids)] - [_ - (raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))]) - (list (map check-pair-shape (syntax->list #'(regular ...))) - (map - (λ (kwd) - (syntax-case kwd () - [(kwd ps) - #`(kwd #,(check-pair-shape #'ps))])) - (syntax->list #'(kwd ...)))))])) - -(define-for-syntax (make-this-transformer this-arg) - (with-syntax ([this-arg this-arg]) - (make-set!-transformer - (λ (sstx) - (syntax-case sstx (set!) - [(set! id arg) - (raise-syntax-error #f - "can't mutate this" - sstx)] - [id - (identifier? #'id) - (syntax/loc sstx this-arg)] - [(id . args) - (datum->syntax sstx (cons #'this-arg #'args) sstx)]))))) - -(define-for-syntax (find-pre/post-keywords stx) - (let ([pre #f] - [post #f]) - (let loop ([stx (syntax->list stx)]) - (cond - [(syntax? stx) - (loop (syntax-e stx))] - [(pair? stx) - (when (and (syntax? (car stx)) - (eq? (syntax-e (car stx)) - '#:pre)) - (set! pre (car stx))) - (when (and (syntax? (car stx)) - (eq? (syntax-e (car stx)) - '#:post)) - (set! post (car stx))) - (loop (cdr stx))] - [else (void)])) - (values pre post))) - -(define-syntax (->i stx) - (parse-->i stx) - (printf "finished ->i parsing\n") - (syntax-case stx () - [(_ (raw-mandatory-doms ...) - . - leftover) - (let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)] - [(this->i) (gensym '->i)]) - (define (add-indy-prop stx) - (syntax-property stx 'racket/contract:internal-contract (gensym '->i-boundary))) - (with-syntax ([(([mandatory-regular-id mandatory-dom/no-prop] ... ) - ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom/no-prop)] ...)) - (verify-->i-structure stx (split-doms stx '->i #'(raw-mandatory-doms ...)))] - [(([optional-regular-id optional-dom/no-prop] ...) - ([optional-kwd (optional-kwd-id optional-kwd-dom/no-prop)] ...)) - (verify-->i-structure stx (split-doms stx '->i raw-optional-doms))]) - (with-syntax ([(mandatory-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i))) - (syntax->list #'(mandatory-dom/no-prop ...)))] - [(mandatory-kwd-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i))) - (syntax->list #'(mandatory-kwd-dom/no-prop ...)))] - [(optional-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i))) - (syntax->list #'(optional-dom/no-prop ...)))] - [(optional-kwd-dom ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->i)) - (syntax->list #'(optional-kwd-dom/no-prop ...)))]) - (with-syntax ([((kwd kwd-id) ...) - (sort-keywords - stx - (syntax->list - #'((optional-kwd optional-kwd-id) ... - (mandatory-kwd mandatory-kwd-id) ...)))] - [(this-parameter ...) - (make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method)) - (car (generate-temporaries '(this))) - (datum->syntax stx 'this #f)))]) - (with-syntax ([(dom-params ...) - #`(this-parameter ... - mandatory-regular-id ... - optional-regular-id ... - #,@(if id/rest - (with-syntax ([(id rst-ctc) id/rest]) - #'(id)) - #'()) - kwd-id ...)]) - (with-syntax ([((rng-params ...) rng-ctcs) - (syntax-case range (any values) - [(values ctc-pr ...) - (with-syntax ([((id ctc/no-prop) ...) - (map (lambda (x) (syntax-case x () - [[id ctc/no-prop] #'[id ctc/no-prop]] - [[id (id2 ...) ctc/no-prop] #'[id ctc/no-prop]] - [x (raise-syntax-error #f "expected binding pair" stx #'x)])) - (syntax->list #'(ctc-pr ...)))]) - (with-syntax ([(ctc ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:positive-position this->i))) - (syntax->list #'(ctc/no-prop ...)))]) - #'((id ...) (ctc ...))))] - [any #'(() #f)] - [[id ctc] - #`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))] - [[id (id2 ...) ctc] - #`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))] - [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])] - [mtd? (and (syntax-parameter-value #'making-a-method) #t)]) - (let ([rng-underscores? - (let ([is-underscore? - (λ (x) - (syntax-case x (_) - [_ #t] - [else #f]))]) - (cond - [(andmap is-underscore? (syntax->list #'(rng-params ...))) - #t] - [(ormap (λ (x) (and (is-underscore? x) x)) - (syntax->list #'(rng-params ...))) - => - (λ (id) - (raise-syntax-error '->i - "expected all of the identifiers to be underscores, or none of them to be" - stx - id))] - [else #f]))]) - (let ([dup (check-duplicate-identifier - (append (if rng-underscores? - '() - (syntax->list #'(rng-params ...))) - (syntax->list #'(dom-params ...))))]) - (when dup - (raise-syntax-error #f "duplicate identifier" stx dup))) - #`(let-syntax ([parameterize-this - (let ([old-param (syntax-parameter-value #'making-a-method)]) - (λ (stx) - (syntax-case stx () - [(_ body) #'body] - [(_ id body) - (if (syntax? old-param) - (with-syntax ([param old-param]) - (syntax/loc stx - (syntax-parameterize - ([param (make-this-transformer #'id)]) - body))) - #'body)])))]) - (syntax-parameterize - ((making-a-method #f)) - #,(syntax-property - #`(build-->d mtd? - (list (λ (dom-params ...) - (parameterize-this this-parameter ... mandatory-dom)) ...) - (list (λ (dom-params ...) - (parameterize-this this-parameter ... optional-dom)) ...) - (list (λ (dom-params ...) - (parameterize-this this-parameter ... mandatory-kwd-dom)) ...) - (list (λ (dom-params ...) - (parameterize-this this-parameter ... optional-kwd-dom)) ...) - #,(if id/rest - (with-syntax ([(id rst-ctc) id/rest]) - #`(λ (dom-params ...) - (parameterize-this this-parameter ... rst-ctc))) - #f) - #,(if pre-cond - #`(λ (dom-params ...) - (parameterize-this this-parameter ... #,pre-cond)) - #f) - #,(syntax-case #'rng-ctcs () - [#f #f] - [(ctc ...) - (if rng-underscores? - #'(box (list (λ (dom-params ...) - (parameterize-this this-parameter ... ctc)) ...)) - #'(list (λ (rng-params ... dom-params ...) - (parameterize-this this-parameter ... ctc)) ...))]) - #,(if post-cond - #`(λ (rng-params ... dom-params ...) - (parameterize-this this-parameter ... #,post-cond)) - #f) - '(mandatory-kwd ...) - '(optional-kwd ...) - (λ (f) - #,(add-name-prop - (syntax-local-infer-name stx) - #`(λ args (apply f args))))) - 'racket/contract:contract - (let-values ([(pre-kwd post-kwd) (find-pre/post-keywords #'leftover)]) - (vector this->i - ;; the -> in the original input to this guy - (let ([kwd (list (car (syntax-e stx)))]) - (if post-kwd - (cons post-kwd kwd) - kwd)) - (if pre-kwd - (list pre-kwd) - '())))))))))))))])) - -(define ->d-tail-key (gensym '->d-tail-key)) - -(define (->d-proj ->d-stct) - (let* ([opt-count (length (->d-optional-dom-ctcs ->d-stct))] - [mandatory-count (+ (length (->d-mandatory-dom-ctcs ->d-stct)) - (if (->d-mtd? ->d-stct) 1 0))] - [non-kwd-ctc-count (+ mandatory-count opt-count)] - [arity - (cond - [(->d-rest-ctc ->d-stct) - (make-arity-at-least mandatory-count)] - [else - (let loop ([i 0]) - (cond - [(= i opt-count) - (list (+ mandatory-count i))] - [else - (cons (+ mandatory-count i) (loop (+ i 1)))]))])]) - (λ (blame) - (let ([this->d-id (gensym '->d-tail-key)]) - (λ (val) - (check-procedure val - (->d-mtd? ->d-stct) - (length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length - (length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length - (->d-mandatory-keywords ->d-stct) - (->d-optional-keywords ->d-stct) - blame) - (let ([kwd-proc - (λ (kwd-args kwd-arg-vals . raw-orig-args) - (let* ([orig-args (if (->d-mtd? ->d-stct) - (cdr raw-orig-args) - raw-orig-args)] - [this (and (->d-mtd? ->d-stct) (car raw-orig-args))] - [dep-pre-args - (build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct) - (->d-keywords ->d-stct) kwd-args kwd-arg-vals)] - [thunk - (λ () - (keyword-apply - val - kwd-args - - ;; contracted keyword arguments - (let loop ([all-kwds (->d-keywords ->d-stct)] - [kwd-ctcs (->d-keyword-ctcs ->d-stct)] - [building-kwd-args kwd-args] - [building-kwd-arg-vals kwd-arg-vals]) - (cond - [(or (null? building-kwd-args) (null? all-kwds)) '()] - [else (if (eq? (car all-kwds) - (car building-kwd-args)) - (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame)) - (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) - (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))])) - - (append - ;; this parameter (if necc.) - (if (->d-mtd? ->d-stct) - (list (car raw-orig-args)) - '()) - - ;; contracted ordinary arguments - (let loop ([args orig-args] - [non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct) - (->d-optional-dom-ctcs ->d-stct))]) - (cond - [(null? args) - (if (->d-rest-ctc ->d-stct) - (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame)) - '())] - [(null? non-kwd-ctcs) - (if (->d-rest-ctc ->d-stct) - (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame)) - - ;; ran out of arguments, but don't have a rest parameter. - ;; procedure-reduce-arity (or whatever the new thing is - ;; going to be called) should ensure this doesn't happen. - (error 'shouldnt\ happen))] - [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame)) - (loop (cdr args) - (cdr non-kwd-ctcs)))])))))] - [rng (let ([rng (->d-range ->d-stct)]) - (cond - [(not rng) #f] - [(box? rng) - (map (λ (val) (apply val dep-pre-args)) - (unbox rng))] - [else rng]))] - [rng-underscore? (box? (->d-range ->d-stct))]) - (when (->d-pre-cond ->d-stct) - (unless (apply (->d-pre-cond ->d-stct) dep-pre-args) - (raise-blame-error (blame-swap blame) - val - "#:pre violation~a" - (build-values-string ", argument" dep-pre-args)))) - (call-with-immediate-continuation-mark - ->d-tail-key - (λ (first-mark) - (cond - [(and rng - (not (and first-mark - (eq? this->d-id (car first-mark)) - (andmap eq? raw-orig-args (cdr first-mark))))) - (call-with-values - (λ () - (with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args) - (thunk))) - (λ orig-results - (let* ([range-count (length rng)] - [post-args (append orig-results raw-orig-args)] - [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] - [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count - post-args (->d-rest-ctc ->d-stct) - (->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) - (when (->d-post-cond ->d-stct) - (unless (apply (->d-post-cond ->d-stct) dep-post-args) - (raise-blame-error blame - val - "#:post violation~a~a" - (build-values-string ", argument" dep-pre-args) - (build-values-string (if (null? dep-pre-args) - ", result" - "\n result") - orig-results)))) - - (unless (= range-count (length orig-results)) - (raise-blame-error blame - val - "expected ~a results, got ~a" - range-count - (length orig-results))) - (apply - values - (let loop ([results orig-results] - [result-contracts rng]) - (cond - [(null? result-contracts) '()] - [else - (cons - (invoke-dep-ctc (car result-contracts) - (if rng-underscore? #f dep-post-args) - (car results) - blame) - (loop (cdr results) (cdr result-contracts)))]))))))] - [else - (thunk)])))))]) - (make-contracted-function - (procedure-reduce-keyword-arity - (make-keyword-procedure kwd-proc - ((->d-name-wrapper ->d-stct) - (λ args - (apply kwd-proc '() '() args)))) - - arity - (->d-mandatory-keywords ->d-stct) - (->d-keywords ->d-stct)) - ->d-stct))))))) - -(define (build-values-string desc dep-pre-args) - (cond - [(null? dep-pre-args) ""] - [(null? (cdr dep-pre-args)) (format "~a was: ~e" desc (car dep-pre-args))] - [else - (apply - string-append - (format "~as were:" desc) - (let loop ([lst dep-pre-args]) - (cond - [(null? lst) '()] - [else (cons (format "\n ~e" (car lst)) - (loop (cdr lst)))])))])) - -;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst -(define (invoke-dep-ctc dep-ctc dep-args val blame) - (let ([ctc (coerce-contract '->d (if dep-args - (apply dep-ctc dep-args) - dep-ctc))]) - (((contract-projection ctc) blame) val))) - -;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any) -(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args) - (append - - ;; ordinary args (possibly including `this' as the first element) - (let loop ([count non-kwd-ctc-count] - [args args]) - (cond - [(zero? count) - (if rest-arg? - (list args) - '())] - [(null? args) (cons the-unsupplied-arg (loop (- count 1) null))] - [else (cons (car args) (loop (- count 1) (cdr args)))])) - - ;; kwd args - (let loop ([all-kwds all-kwds] - [kwds supplied-kwds] - [args supplied-args]) - (cond - [(null? all-kwds) null] - [else (let* ([kwd (car all-kwds)] - [kwd-matches? (and (not (null? kwds)) (eq? (car kwds) kwd))]) - (if kwd-matches? - (cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args))) - (cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))])))) - -(define (build-->d mtd? - mandatory-dom-ctcs optional-dom-ctcs - mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs - rest-ctc pre-cond range post-cond - mandatory-kwds optional-kwds - name-wrapper) - (let ([kwd/ctc-pairs (sort - (map cons - (append mandatory-kwds optional-kwds) - (append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs)) - (λ (x y) (keywordd mtd? - mandatory-dom-ctcs optional-dom-ctcs - (map cdr kwd/ctc-pairs) - rest-ctc pre-cond range post-cond - (map car kwd/ctc-pairs) - mandatory-kwds - optional-kwds - name-wrapper))) - -;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that -;; is under the contract, and "dr???" refers to the arguments & the results of the function that -;; is under the contract. -;; the `box' in the range only serves to differentiate between range contracts that depend on -;; both the domain and the range from those that depend only on the domain (and thus, those -;; that can be applied early) -(define-struct ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes. - mandatory-dom-ctcs ;; (listof (-> d??? ctc)) - optional-dom-ctcs ;; (listof (-> d??? ctc)) - keyword-ctcs ;; (listof (-> d??? ctc)) - rest-ctc ;; (or/c false/c (-> d??? ctc)) - pre-cond ;; (-> d??? boolean) - range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc)))) - post-cond ;; (-> dr??? boolean) - keywords ;; (listof keywords) -- sorted by keyword< - mandatory-keywords ;; (listof keywords) -- sorted by keyword< - optional-keywords ;; (listof keywords) -- sorted by keyword< - name-wrapper) ;; (-> proc proc) - - #:omit-define-syntaxes - - #:property prop:contract - (build-contract-property - #:projection ->d-proj - #:name - (λ (ctc) - (let* ([counting-id 'x] - [ids '(x y z w)] - [next-id - (λ () - (cond - [(pair? ids) - (begin0 (car ids) - (set! ids (cdr ids)))] - [(null? ids) - (begin0 - (string->symbol (format "~a0" counting-id)) - (set! ids 1))] - [else - (begin0 - (string->symbol (format "~a~a" counting-id ids)) - (set! ids (+ ids 1)))]))]) - `(->i (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc)) - ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc)))) - (,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc)) - ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc)))) - ,@(if (->d-rest-ctc ctc) - (list '#:rest (next-id) '...) - '()) - ,@(if (->d-pre-cond ctc) - (list '#:pre '...) - (list)) - ,(let ([range (->d-range ctc)]) - (cond - [(not range) 'any] - [(box? range) - (let ([range (unbox range)]) - (cond - [(and (not (null? range)) - (null? (cdr range))) - `[_ ...]] - [else - `(values ,@(map (λ (x) `(_ ...)) range))]))] - [(and (not (null? range)) - (null? (cdr range))) - `[,(next-id) ...]] - [else - `(values ,@(map (λ (x) `(,(next-id) ...)) range))])) - ,@(if (->d-post-cond ctc) - (list '#:post '...) - (list))))) - - #:first-order (λ (ctc) (λ (x) #f)) - #:stronger (λ (this that) (eq? this that)))) - diff --git a/collects/racket/contract/private/arr-i-parse.rkt b/collects/racket/contract/private/arr-i-parse.rkt index 10efda5994..9f1b25b88c 100644 --- a/collects/racket/contract/private/arr-i-parse.rkt +++ b/collects/racket/contract/private/arr-i-parse.rkt @@ -7,6 +7,8 @@ [module-identifier-mapping-get free-identifier-mapping-get] [module-identifier-mapping-put! free-identifier-mapping-put!]) (for-template racket/base + "misc.rkt" + "prop.rkt" "guts.rkt")) #| diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 57fecbe8e5..7e40dda29b 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -4,6 +4,7 @@ "prop.rkt" "guts.rkt" "opt.rkt" + "misc.rkt" "blame.rkt" syntax/location (for-syntax racket/base diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index 78181d7511..63f6eb4ca8 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -21,6 +21,7 @@ v4 todo: (require "guts.rkt" "blame.rkt" "prop.rkt" + "misc.rkt" racket/stxparam) (require (for-syntax racket/base) (for-syntax "helpers.rkt") diff --git a/collects/racket/contract/private/base.rkt b/collects/racket/contract/private/base.rkt index 0b65a61e86..29266c5594 100644 --- a/collects/racket/contract/private/base.rkt +++ b/collects/racket/contract/private/base.rkt @@ -20,7 +20,8 @@ improve method arity mismatch contract violation error messages? "guts.rkt" "blame.rkt" "prop.rkt" - "arrow.rkt") + "arrow.rkt" + "misc.rkt") (define-syntax-parameter current-contract-region (λ (stx) #'(quote-module-path))) diff --git a/collects/racket/contract/private/basic-opters.rkt b/collects/racket/contract/private/basic-opters.rkt index 60ccba9c68..cfb6d10353 100644 --- a/collects/racket/contract/private/basic-opters.rkt +++ b/collects/racket/contract/private/basic-opters.rkt @@ -3,7 +3,8 @@ (require "guts.rkt" "blame.rkt" "opt.rkt" - "base.rkt") + "base.rkt" + "misc.rkt") (require (for-syntax racket/base "opt-guts.rkt")) diff --git a/collects/racket/contract/private/box.rkt b/collects/racket/contract/private/box.rkt index 57539902c1..a5d8ba76f9 100644 --- a/collects/racket/contract/private/box.rkt +++ b/collects/racket/contract/private/box.rkt @@ -3,7 +3,8 @@ (require (for-syntax racket/base) "prop.rkt" "blame.rkt" - "guts.rkt") + "guts.rkt" + "misc.rkt") (provide box-immutable/c (rename-out [wrap-box/c box/c])) diff --git a/collects/racket/contract/private/ds.rkt b/collects/racket/contract/private/ds.rkt index b88a621430..068e7f40db 100644 --- a/collects/racket/contract/private/ds.rkt +++ b/collects/racket/contract/private/ds.rkt @@ -20,7 +20,8 @@ it around flattened out. (require "guts.rkt" "prop.rkt" "blame.rkt" - "opt.rkt") + "opt.rkt" + "misc.rkt") (require (for-syntax scheme/base) (for-syntax "ds-helpers.rkt") (for-syntax "helpers.rkt") diff --git a/collects/racket/contract/exists.rkt b/collects/racket/contract/private/exists.rkt similarity index 93% rename from collects/racket/contract/exists.rkt rename to collects/racket/contract/private/exists.rkt index 86c53a86a3..91751124cb 100644 --- a/collects/racket/contract/exists.rkt +++ b/collects/racket/contract/private/exists.rkt @@ -1,8 +1,8 @@ #lang racket/base -(require "private/guts.rkt" - "private/prop.rkt" - "private/blame.rkt") +(require "guts.rkt" + "prop.rkt" + "blame.rkt") (provide new-∃/c new-∀/c diff --git a/collects/racket/contract/private/guts.rkt b/collects/racket/contract/private/guts.rkt index b4e6b1721d..6b9c354d29 100644 --- a/collects/racket/contract/private/guts.rkt +++ b/collects/racket/contract/private/guts.rkt @@ -16,24 +16,8 @@ coerce-chaperone-contracts coerce-contract/f - chaperone-contract? - - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract - build-compound-type-name - and/c - any/c - none/c - make-none/c - - contract? - contract-name - contract-projection - contract-stronger? contract-first-order @@ -47,11 +31,12 @@ ;; for opters check-flat-contract check-flat-named-contract - any ;; helpers for adding properties that check syntax uses define/final-prop - define/subexpression-pos-prop) + define/subexpression-pos-prop + + make-predicate-contract) (define (has-contract? v) (or (has-prop:contracted? v) @@ -79,9 +64,6 @@ (define-values (impersonator-prop:contracted has-impersonator-prop:contracted? get-impersonator-prop:contracted) (make-impersonator-property 'impersonator-prop:contracted)) -(define-syntax (any stx) - (raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx)) - (define (contract-first-order c) (contract-struct-first-order (coerce-contract 'contract-first-order c))) @@ -176,7 +158,7 @@ [(number? x) (make-=-contract x)] [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)] [else #f])) - + (define-syntax (define/final-prop stx) (syntax-case stx () [(_ header bodies ...) @@ -253,181 +235,12 @@ (list (car (syntax-e stx))) '()))))])))))])) -; -; -; -; -; -; ; ; -; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; -; ; ; ; ; ;; ; ; ;; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ;;;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; -; -; -; - -(define (flat-contract-predicate x) - (contract-struct-first-order - (coerce-flat-contract 'flat-contract-predicate x))) - -(define (flat-contract? x) - (let ([c (coerce-contract/f x)]) - (and c - (flat-contract-struct? c)))) - -(define (chaperone-contract? x) - (let ([c (coerce-contract/f x)]) - (and c - (chaperone-contract-struct? c)))) - -(define (contract-name ctc) - (contract-struct-name - (coerce-contract 'contract-name ctc))) - -(define (contract? x) (and (coerce-contract/f x) #t)) -(define (contract-projection ctc) - (contract-struct-projection - (coerce-contract 'contract-projection ctc))) - -(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) -(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) -(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) -(define (flat-named-contract name predicate) - (cond - [(and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (make-predicate-contract name predicate)] - [(flat-contract? predicate) - (make-predicate-contract name (flat-contract-predicate predicate))] - [else - (error 'flat-named-contract - "expected a flat contract or procedure of arity 1 as second argument, got ~e" - predicate)])) - ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) (define (build-compound-type-name . fs) (for/list ([sub (in-list fs)]) - (if (contract-struct? sub) (contract-name sub) sub))) - -(define (and-name ctc) - (apply build-compound-type-name 'and/c (base-and/c-ctcs ctc))) - -(define (and-first-order ctc) - (let ([tests (map contract-first-order (base-and/c-ctcs ctc))]) - (λ (x) (for/and ([test (in-list tests)]) (test x))))) - -(define (and-proj ctc) - (let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))]) - (lambda (blame) - (let ([projs (map (λ (c) (c blame)) mk-pos-projs)]) - (for/fold ([proj (car projs)]) - ([p (in-list (cdr projs))]) - (λ (v) (p (proj v)))))))) - -(define (first-order-and-proj ctc) - (λ (blame) - (λ (val) - (let loop ([predicates (first-order-and/c-predicates ctc)] - [ctcs (base-and/c-ctcs ctc)]) - (cond - [(null? predicates) val] - [else - (if ((car predicates) val) - (loop (cdr predicates) (cdr ctcs)) - (raise-blame-error - blame - val - "expected <~s>, given ~a, which isn't ~s" - (contract-name ctc) - val - (contract-name (car ctcs))))]))))) - -(define (and-stronger? this that) - (and (base-and/c? that) - (let ([this-ctcs (base-and/c-ctcs this)] - [that-ctcs (base-and/c-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs))))) - -(define-struct base-and/c (ctcs)) -(define-struct (first-order-and/c base-and/c) (predicates) - #:property prop:flat-contract - (build-flat-contract-property - #:projection first-order-and-proj - #:name and-name - #:first-order and-first-order - #:stronger and-stronger?)) -(define-struct (chaperone-and/c base-and/c) () - #:property prop:chaperone-contract - (build-chaperone-contract-property - #:projection and-proj - #:name and-name - #:first-order and-first-order - #:stronger and-stronger?)) -(define-struct (impersonator-and/c base-and/c) () - #:property prop:contract - (build-contract-property - #:projection and-proj - #:name and-name - #:first-order and-first-order - #:stronger and-stronger?)) + (if (contract-struct? sub) (contract-struct-name sub) sub))) -(define/subexpression-pos-prop (and/c . raw-fs) - (let ([contracts (coerce-contracts 'and/c raw-fs)]) - (cond - [(null? contracts) any/c] - [(andmap flat-contract? contracts) - (let ([preds (map flat-contract-predicate contracts)]) - (make-first-order-and/c contracts preds))] - [(andmap chaperone-contract? contracts) - (make-chaperone-and/c contracts)] - [else (make-impersonator-and/c contracts)]))) - -(define (get-any-projection c) any-projection) -(define (any-projection b) any-function) -(define (any-function x) x) - -(define (get-any? c) any?) -(define (any? x) #t) - -(define-struct any/c () - #:omit-define-syntaxes - #:property prop:flat-contract - (build-flat-contract-property - #:projection get-any-projection - #:stronger (λ (this that) (any/c? that)) - #:name (λ (ctc) 'any/c) - #:first-order get-any?)) - -(define/final-prop any/c (make-any/c)) - -(define (none-curried-proj ctc) - (λ (blame) - (λ (val) - (raise-blame-error - blame - val - "~s accepts no values, given: ~e" - (none/c-name ctc) - val)))) - -(define-struct none/c (name) - #:omit-define-syntaxes - #:property prop:flat-contract - (build-flat-contract-property - #:projection none-curried-proj - #:stronger (λ (this that) #t) - #:name (λ (ctc) (none/c-name ctc)) - #:first-order (λ (ctc) (λ (val) #f)))) - -(define/final-prop none/c (make-none/c 'none/c)) @@ -509,3 +322,6 @@ (predicate-contract-pred that)))) #:name (λ (ctc) (predicate-contract-name ctc)) #:first-order (λ (ctc) (predicate-contract-pred ctc)))) + +(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) +(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) diff --git a/collects/racket/contract/private/hash.rkt b/collects/racket/contract/private/hash.rkt index f47a3317b7..f085373c2a 100644 --- a/collects/racket/contract/private/hash.rkt +++ b/collects/racket/contract/private/hash.rkt @@ -3,7 +3,8 @@ (require (for-syntax racket/base) "guts.rkt" "blame.rkt" - "prop.rkt") + "prop.rkt" + "misc.rkt") (provide (rename-out [wrap-hash/c hash/c])) diff --git a/collects/racket/contract/private/legacy.rkt b/collects/racket/contract/private/legacy.rkt index 8f226d0132..211bbb7e3e 100644 --- a/collects/racket/contract/private/legacy.rkt +++ b/collects/racket/contract/private/legacy.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "guts.rkt" "blame.rkt" "prop.rkt" syntax/srcloc) +(require "guts.rkt" "blame.rkt" "prop.rkt" "misc.rkt" syntax/srcloc) (provide make-proj-contract raise-contract-error diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index a8c745bc05..edee158e6c 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -10,6 +10,7 @@ (provide flat-rec-contract flat-murec-contract or/c + and/c not/c =/c >=/c <=/c /c between/c integer-in @@ -25,7 +26,23 @@ check-between/c check-unary-between/c - parameter/c) + parameter/c + + any/c + any + none/c + make-none/c + + chaperone-contract? + flat-contract? + contract? + + flat-contract + flat-contract-predicate + flat-named-contract + + contract-projection + contract-name) (define-syntax (flat-rec-contract stx) (syntax-case stx () @@ -280,6 +297,85 @@ #:first-order (λ (ctc) (flat-or/c-pred ctc)))) + +(define (and-name ctc) + (apply build-compound-type-name 'and/c (base-and/c-ctcs ctc))) + +(define (and-first-order ctc) + (let ([tests (map contract-first-order (base-and/c-ctcs ctc))]) + (λ (x) (for/and ([test (in-list tests)]) (test x))))) + +(define (and-proj ctc) + (let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))]) + (lambda (blame) + (let ([projs (map (λ (c) (c blame)) mk-pos-projs)]) + (for/fold ([proj (car projs)]) + ([p (in-list (cdr projs))]) + (λ (v) (p (proj v)))))))) + +(define (first-order-and-proj ctc) + (λ (blame) + (λ (val) + (let loop ([predicates (first-order-and/c-predicates ctc)] + [ctcs (base-and/c-ctcs ctc)]) + (cond + [(null? predicates) val] + [else + (if ((car predicates) val) + (loop (cdr predicates) (cdr ctcs)) + (raise-blame-error + blame + val + "expected <~s>, given ~a, which isn't ~s" + (contract-name ctc) + val + (contract-name (car ctcs))))]))))) + +(define (and-stronger? this that) + (and (base-and/c? that) + (let ([this-ctcs (base-and/c-ctcs this)] + [that-ctcs (base-and/c-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs))))) + +(define-struct base-and/c (ctcs)) +(define-struct (first-order-and/c base-and/c) (predicates) + #:property prop:flat-contract + (build-flat-contract-property + #:projection first-order-and-proj + #:name and-name + #:first-order and-first-order + #:stronger and-stronger?)) +(define-struct (chaperone-and/c base-and/c) () + #:property prop:chaperone-contract + (build-chaperone-contract-property + #:projection and-proj + #:name and-name + #:first-order and-first-order + #:stronger and-stronger?)) +(define-struct (impersonator-and/c base-and/c) () + #:property prop:contract + (build-contract-property + #:projection and-proj + #:name and-name + #:first-order and-first-order + #:stronger and-stronger?)) + + +(define/subexpression-pos-prop (and/c . raw-fs) + (let ([contracts (coerce-contracts 'and/c raw-fs)]) + (cond + [(null? contracts) any/c] + [(andmap flat-contract? contracts) + (let ([preds (map flat-contract-predicate contracts)]) + (make-first-order-and/c contracts preds))] + [(andmap chaperone-contract? contracts) + (make-chaperone-and/c contracts)] + [else (make-impersonator-and/c contracts)]))) + + (define false/c #f) (define/final-prop (string-len/c n) @@ -358,28 +454,6 @@ (let ([elems (one-of/c-elems ctc)]) (λ (x) (memv x elems)))))) -(define printable/c - (flat-named-contract - 'printable/c - (λ (x) - (let printable? ([x x]) - (or (symbol? x) - (string? x) - (bytes? x) - (boolean? x) - (char? x) - (null? x) - (number? x) - (regexp? x) - (prefab-struct-key x) ;; this cannot be last, since it doesn't return just #t - (and (pair? x) - (printable? (car x)) - (printable? (cdr x))) - (and (vector? x) - (andmap printable? (vector->list x))) - (and (box? x) - (printable? (unbox x)))))))) - (define-struct between/c (low high) #:omit-define-syntaxes #:property prop:flat-contract @@ -446,15 +520,6 @@ `(>/c ,x) (λ (y) (and (real? y) (> y x))))) -(define natural-number/c - (flat-named-contract - 'natural-number/c - (λ (x) - (and (number? x) - (integer? x) - (exact? x) - (x . >= . 0))))) - (define/final-prop (integer-in start end) (unless (and (integer? start) (exact? start) @@ -703,3 +768,118 @@ (parameter/c-ctc that)) (contract-stronger? (parameter/c-ctc that) (parameter/c-ctc this)))))) + + + +(define (get-any-projection c) any-projection) +(define (any-projection b) any-function) +(define (any-function x) x) + +(define (get-any? c) any?) +(define (any? x) #t) + +(define-struct any/c () + #:omit-define-syntaxes + #:property prop:flat-contract + (build-flat-contract-property + #:projection get-any-projection + #:stronger (λ (this that) (any/c? that)) + #:name (λ (ctc) 'any/c) + #:first-order get-any?)) + +(define/final-prop any/c (make-any/c)) + +(define-syntax (any stx) + (raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx)) + +(define (none-curried-proj ctc) + (λ (blame) + (λ (val) + (raise-blame-error + blame + val + "~s accepts no values, given: ~e" + (none/c-name ctc) + val)))) + +(define-struct none/c (name) + #:omit-define-syntaxes + #:property prop:flat-contract + (build-flat-contract-property + #:projection none-curried-proj + #:stronger (λ (this that) #t) + #:name (λ (ctc) (none/c-name ctc)) + #:first-order (λ (ctc) (λ (val) #f)))) + +(define/final-prop none/c (make-none/c 'none/c)) + + +(define (flat-contract-predicate x) + (contract-struct-first-order + (coerce-flat-contract 'flat-contract-predicate x))) + +(define (flat-contract? x) + (let ([c (coerce-contract/f x)]) + (and c + (flat-contract-struct? c)))) + +(define (chaperone-contract? x) + (let ([c (coerce-contract/f x)]) + (and c + (chaperone-contract-struct? c)))) + +(define (contract-name ctc) + (contract-struct-name + (coerce-contract 'contract-name ctc))) + +(define (contract? x) (and (coerce-contract/f x) #t)) +(define (contract-projection ctc) + (contract-struct-projection + (coerce-contract 'contract-projection ctc))) + +(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) +(define (flat-named-contract name predicate) + (cond + [(and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (make-predicate-contract name predicate)] + [(flat-contract? predicate) + (make-predicate-contract name (flat-contract-predicate predicate))] + [else + (error 'flat-named-contract + "expected a flat contract or procedure of arity 1 as second argument, got ~e" + predicate)])) + + + +(define printable/c + (flat-named-contract + 'printable/c + (λ (x) + (let printable? ([x x]) + (or (symbol? x) + (string? x) + (bytes? x) + (boolean? x) + (char? x) + (null? x) + (number? x) + (regexp? x) + (prefab-struct-key x) ;; this cannot be last, since it doesn't return just #t + (and (pair? x) + (printable? (car x)) + (printable? (cdr x))) + (and (vector? x) + (andmap printable? (vector->list x))) + (and (box? x) + (printable? (unbox x)))))))) + + +(define natural-number/c + (flat-named-contract + 'natural-number/c + (λ (x) + (and (number? x) + (integer? x) + (exact? x) + (x . >= . 0))))) diff --git a/collects/racket/contract/private/object.rkt b/collects/racket/contract/private/object.rkt index c6d92b7f47..924676ef2d 100644 --- a/collects/racket/contract/private/object.rkt +++ b/collects/racket/contract/private/object.rkt @@ -1,7 +1,8 @@ -#lang scheme/base +#lang racket/base (require "arrow.rkt" "guts.rkt" "prop.rkt" + "misc.rkt" racket/private/class-internal scheme/stxparam) diff --git a/collects/racket/contract/private/opt-guts.rkt b/collects/racket/contract/private/opt-guts.rkt index cc80465ecb..d381c6e1f9 100644 --- a/collects/racket/contract/private/opt-guts.rkt +++ b/collects/racket/contract/private/opt-guts.rkt @@ -2,7 +2,8 @@ (require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts (for-template racket/base) (for-template "guts.rkt" - "blame.rkt") + "blame.rkt" + "misc.rkt") (for-syntax racket/base)) (provide get-opter reg-opter! opter diff --git a/collects/racket/contract/private/opt.rkt b/collects/racket/contract/private/opt.rkt index 71385d1a29..5487af7239 100644 --- a/collects/racket/contract/private/opt.rkt +++ b/collects/racket/contract/private/opt.rkt @@ -2,6 +2,7 @@ (require "guts.rkt" "prop.rkt" "blame.rkt" + "misc.rkt" racket/stxparam) (require (for-syntax racket/base) (for-syntax "opt-guts.rkt") diff --git a/collects/racket/contract/private/opters.rkt b/collects/racket/contract/private/opters.rkt index c2697c3c5e..2301b3fbdd 100644 --- a/collects/racket/contract/private/opters.rkt +++ b/collects/racket/contract/private/opters.rkt @@ -4,6 +4,7 @@ "guts.rkt" "arrow.rkt" "blame.rkt" + "misc.rkt" (for-syntax racket/base syntax/stx "opt-guts.rkt")) diff --git a/collects/racket/contract/private/parametric.rkt b/collects/racket/contract/private/parametric.rkt index 7193eda990..5a490a7b10 100644 --- a/collects/racket/contract/private/parametric.rkt +++ b/collects/racket/contract/private/parametric.rkt @@ -2,6 +2,7 @@ (require "guts.rkt" "prop.rkt" "blame.rkt" + "misc.rkt" (for-syntax racket/base)) (provide parametric->/c) diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt index 46b46ff410..d852539a0b 100644 --- a/collects/racket/contract/private/provide.rkt +++ b/collects/racket/contract/private/provide.rkt @@ -9,8 +9,9 @@ (prefix-in a: "helpers.rkt")) "arrow.rkt" "base.rkt" - racket/contract/exists "guts.rkt" + "misc.rkt" + "exists.rkt" (for-syntax unstable/dirs) syntax/location syntax/srcloc) diff --git a/collects/racket/contract/private/struct.rkt b/collects/racket/contract/private/struct.rkt index 747b2c1293..bdad07fd01 100644 --- a/collects/racket/contract/private/struct.rkt +++ b/collects/racket/contract/private/struct.rkt @@ -6,7 +6,8 @@ racket/list "guts.rkt" "blame.rkt" - "prop.rkt") + "prop.rkt" + "misc.rkt") (provide struct/c) diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt index e9fbe72b74..0f30b4d1bb 100644 --- a/collects/racket/contract/private/vector.rkt +++ b/collects/racket/contract/private/vector.rkt @@ -3,7 +3,8 @@ (require (for-syntax racket/base) "guts.ss" "prop.rkt" - "blame.rkt") + "blame.rkt" + "misc.rkt") (provide (rename-out [wrap-vectorof vectorof] [wrap-vector/c vector/c]) diff --git a/collects/racket/contract/regions.rkt b/collects/racket/contract/region.rkt similarity index 99% rename from collects/racket/contract/regions.rkt rename to collects/racket/contract/region.rkt index bbf6f84fce..4411660d33 100644 --- a/collects/racket/contract/regions.rkt +++ b/collects/racket/contract/region.rkt @@ -2,7 +2,8 @@ (provide define-struct/contract define/contract - with-contract) + with-contract + current-contract-region) (require (for-syntax racket/base racket/list @@ -17,7 +18,8 @@ syntax/location "private/arrow.rkt" "private/base.rkt" - "private/guts.rkt") + "private/guts.rkt" + "private/misc.rkt") ;; These are useful for all below. diff --git a/collects/racket/dict.rkt b/collects/racket/dict.rkt index 67331f5ced..4179805a45 100644 --- a/collects/racket/dict.rkt +++ b/collects/racket/dict.rkt @@ -121,9 +121,7 @@ (or/c #f (-> dict? contract?)) (or/c #f (-> dict? contract?)))) -(define even-length-list/c - (flat-named-contract 'even-length-list/c - (lambda (l) (even? (length l))))) +(define (even-length-list? l) (even? (length l))) ;; ---------------------------------------- @@ -163,7 +161,7 @@ (recursive-contract (or/c null (cons/c key/c (cons/c val/c args/c))))]) - (and/c even-length-list/c + (and/c even-length-list? args/c)))] [_r void?])] [dict-set* @@ -174,7 +172,7 @@ (recursive-contract (or/c null (cons/c key/c (cons/c val/c args/c))))]) - (and/c even-length-list/c + (and/c even-length-list? args/c)))] [_r dict?])] [dict-update! diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 33aa9af404..d00ef109fe 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -3,6 +3,7 @@ (require (for-syntax racket/base) mzlib/etc racket/contract/base + racket/contract/combinator (only-in racket/contract/private/arrow making-a-method) racket/list racket/stxparam diff --git a/collects/scheme/exists/lang.rkt b/collects/scheme/exists/lang.rkt index d6cf074f5e..ae8b29e518 100644 --- a/collects/scheme/exists/lang.rkt +++ b/collects/scheme/exists/lang.rkt @@ -1,6 +1,6 @@ #lang scheme -(require racket/contract/exists) +(require racket/contract/private/exists) ;; this code builds the list of predicates (in case it changes, this may need to be re-run) #; diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 55c6bd0088..6d8a6bb88e 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -17,15 +17,30 @@ another. Programmers specify the behavior of a module's exports via @racket[provide/contract], and the contract system enforces those constraints. -@note-lib[racket/contract #:use-sources (racket/contract/private/ds - racket/contract/private/base - racket/contract/private/guts - racket/contract/private/box - racket/contract/private/hash - racket/contract/private/vector - racket/contract/private/struct - racket/contract/private/misc - racket/contract/private/provide)] +@(define-syntax-rule + (add-use-sources (x y ...)) + (x y ... + #:use-sources + (racket/contract/private/base + racket/contract/private/misc + racket/contract/private/provide + racket/contract/private/guts + racket/contract/private/prop + racket/contract/private/blame + racket/contract/private/ds + racket/contract/private/opt + racket/contract/private/basic-opters + + racket/contract/private/box + racket/contract/private/hash + racket/contract/private/vector + racket/contract/private/struct))) + +@(define-syntax-rule + (declare-exporting-ctc mod) + (add-use-sources (declare-exporting mod racket/contract racket))) + +@(add-use-sources @note-lib[racket/contract]) @deftech{Contracts} come in two forms: those constructed by the various operations listed in this section of the manual, and various @@ -55,6 +70,7 @@ failed, and anything else to indicate it passed.} @; ---------------------------------------- @section{Data-structure Contracts} +@declare-exporting-ctc[racket/contract/base] A @deftech{flat contract} can be fully checked immediately for a given value. @@ -428,60 +444,12 @@ Constructs a contract on a promise. The contract does not force the promise, but when the promise is forced, the contract checks that the result value meets the contract produced by @racket[expr].} - -@defproc[(new-∀/c [name symbol?]) contract?]{ - Constructs a new universal contract. - - Universal contracts accept all values when in negative positions (e.g., function - inputs) and wrap them in an opaque struct, hiding the precise value. - In positive positions (e.g. function returns), - a universal contract accepts only values that were previously accepted in negative positions (by checking - for the wrappers). - - The name is used to identify the contract in error messages. - - For example, this contract: - @racketblock[(let ([a (new-∃/c 'a)]) - (-> a a))] - describes the identity function (or a non-terminating function) - That is, the first use of the @racket[a] appears in a - negative position and thus inputs to that function are wrapped with an opaque struct. - Then, when the function returns, it is checked to determine whether the result is wrapped, since - the second @racket[a] appears in a positive position. - - The @racket[new-∀/c] construct constructor is dual to @racket[new-∃/c]. - -} - -@defproc[(new-∃/c [name symbol?]) contract?]{ - Constructs a new existential contract. - - Existential contracts accept all values when in positive positions (e.g., function - returns) and wrap them in an opaque struct, hiding the precise value. - In negative positions (e.g. function inputs), - they accepts only values that were previously accepted in positive positions (by checking - for the wrappers). - - The name is used to identify the contract in error messages. - - For example, this contract: - @racketblock[(let ([a (new-∃/c 'a)]) - (-> (-> a a) - any/c))] - describes a function that accepts the identity function (or a non-terminating function) - and returns an arbitrary value. That is, the first use of the @racket[a] appears in a - positive position and thus inputs to that function are wrapped with an opaque struct. - Then, when the function returns, it is checked to see if the result is wrapped, since - the second @racket[a] appears in a negative position. - - The @racket[new-∃/c] construct constructor is dual to @racket[new-∀/c]. -} - - @; ------------------------------------------------------------------------ @section{Function Contracts} +@declare-exporting-ctc[racket/contract/base] + A @deftech{function contract} wraps a procedure to delay checks for its arguments and results. There are three primary function contract combinators that have increasing @@ -786,7 +754,15 @@ be blamed using the above contract: } -@subsection[#:tag "parametric-contracts"]{Parametric Contracts} +@section[#:tag "parametric-contracts"]{Parametric Contracts} +@defmodule*/no-declare[(racket/contract/parametric)] +@declare-exporting-ctc[racket/contract/parametric] + +The most convenient way to use parametric contract is to use +@racket[provide/contract]'s @racket[#:exists] keyword. +The @racketmodname[racket/contract/parametric] provides a few more, +general-purpose parametric contracts. + @defform[(parametric->/c (x ...) c)]{ @@ -815,6 +791,56 @@ if they do not, a contract violation is signaled. ] } +@defproc[(new-∀/c [name symbol?]) contract?]{ + Constructs a new universal contract. + + Universal contracts accept all values when in negative positions (e.g., function + inputs) and wrap them in an opaque struct, hiding the precise value. + In positive positions (e.g. function returns), + a universal contract accepts only values that were previously accepted in negative positions (by checking + for the wrappers). + + The name is used to identify the contract in error messages. + + For example, this contract: + @racketblock[(let ([a (new-∀/c 'a)]) + (-> a a))] + describes the identity function (or a non-terminating function) + That is, the first use of the @racket[a] appears in a + negative position and thus inputs to that function are wrapped with an opaque struct. + Then, when the function returns, it is checked to determine whether the result is wrapped, since + the second @racket[a] appears in a positive position. + + The @racket[new-∀/c] construct constructor is dual to @racket[new-∃/c]. + +} + +@defproc[(new-∃/c [name symbol?]) contract?]{ + Constructs a new existential contract. + + Existential contracts accept all values when in positive positions (e.g., function + returns) and wrap them in an opaque struct, hiding the precise value. + In negative positions (e.g. function inputs), + they accepts only values that were previously accepted in positive positions (by checking + for the wrappers). + + The name is used to identify the contract in error messages. + + For example, this contract: + @racketblock[(let ([a (new-∃/c 'a)]) + (-> (-> a a) + any/c))] + describes a function that accepts the identity function (or a non-terminating function) + and returns an arbitrary value. That is, the first use of the @racket[a] appears in a + positive position and thus inputs to that function are wrapped with an opaque struct. + Then, when the function returns, it is checked to see if the result is wrapped, since + the second @racket[a] appears in a negative position. + + The @racket[new-∃/c] construct constructor is dual to @racket[new-∀/c]. +} + + + @; ------------------------------------------------------------------------ @@ -909,6 +935,7 @@ lazy contract. @; ------------------------------------------------------------------------ @section{Attaching Contracts to Values} +@declare-exporting-ctc[racket/contract/base] @defform/subs[ #:literals (struct rename) @@ -969,6 +996,10 @@ is bound to vectors of two elements, the exported identifier and a syntax object for the expression that produces the contract controlling the export. } + +@subsection{Nested Contract Boundaries} +@defmodule*/no-declare[(racket/contract/region)] +@declare-exporting-ctc[racket/contract/region] @defform*/subs[ [(with-contract blame-id (wc-export ...) free-var-list ... body ...+) @@ -1050,6 +1081,9 @@ The @racket[define-struct/contract] form only allows a subset of the (make-salmon #f 'pacific) ]} +@subsection{Low-level Contract Boundaries} +@declare-exporting-ctc[racket/contract/base] + @defform*[[(contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr) (contract contract-expr to-protect-expr @@ -1088,8 +1122,8 @@ accepted by the third argument to @racket[datum->syntax]. @section{Building New Contract Combinators} -@emph{@bold{Note:} - The interface in this section is unstable and subject to change.} +@defmodule*/no-declare[(racket/contract/combinator)] +@declare-exporting-ctc[racket/contract/combinator] Contracts are represented internally as functions that accept information about the contract (who is to blame, @@ -1460,6 +1494,44 @@ specific to the precise violation. field extracts the @racket[blame?] object associated with a contract violation. } +@defparam[current-blame-format + proc + (-> blame? any/c string? string?)]{ + +A parameter that is used when constructing a +contract violation error. Its value is procedure that +accepts three arguments: +@itemize[ +@item{the blame object for the violation,} +@item{the value that the contract applies to, and} +@item{a message indicating the kind of violation.}] +The procedure then +returns a string that is put into the contract error +message. Note that the value is often already included in +the message that indicates the violation. + +@defexamples[#:eval (contract-eval) +(define (show-blame-error blame value message) + (string-append + "Contract Violation!\n" + (format "Guilty Party: ~a\n" (blame-positive blame)) + (format "Innocent Party: ~a\n" (blame-negative blame)) + (format "Contracted Value Name: ~a\n" (blame-value blame)) + (format "Contract Location: ~s\n" (blame-source blame)) + (format "Contract Name: ~a\n" (blame-contract blame)) + (format "Offending Value: ~s\n" value) + (format "Offense: ~a\n" message))) +(current-blame-format show-blame-error) +(define/contract (f x) + (-> integer? integer?) + (/ x 2)) +(f 2) +(f 1) +(f 1/2) +] + +} + @subsection{Contracts as structs} @para{ @@ -1727,46 +1799,8 @@ are below): @; ------------------------------------------------------------------------ -@section{Contract Utilities} - -@defproc[(contract? [v any/c]) boolean?]{ - -Returns @racket[#t] if its argument is a contract (i.e., constructed -with one of the combinators described in this section or a value that -can be used as a contract) and @racket[#f] otherwise.} - -@defproc[(chaperone-contract? [v any/c]) boolean?]{ - -Returns @racket[#t] if its argument is a contract that guarantees that -it returns a value which passes @racket[chaperone-of?] when compared to -the original, uncontracted value.} - -@defproc[(flat-contract? [v any/c]) boolean?]{ - -Returns @racket[#t] when its argument is a contract that can be -checked immediately (unlike, say, a function contract). - -For example, -@racket[flat-contract] constructs flat contracts from predicates, and -symbols, booleans, numbers, and other ordinary Racket values -(that are defined as @tech{contracts}) are also -flat contracts.} - -@defproc[(flat-contract-predicate [v flat-contract?]) - (any/c . -> . any/c)]{ - -Extracts the predicate from a flat contract.} - -@defproc[(value-contract [v has-contract?]) contract?]{ - Returns the contract attached to @racket[v], if recorded. - Otherwise it returns @racket[#f]. -} - -@defproc[(has-contract? [v any/c]) boolean?]{ - Returns @racket[#t] if @racket[v] is a value that - has a recorded contract attached to it. -} - +@subsection{Utilities for Building New Combinators} + @defproc[(contract-stronger? [x contract?] [y contract?]) boolean?]{ Returns @racket[#t] if the contract @racket[x] accepts either fewer or the same number of values as @racket[y] does. @@ -1799,14 +1833,57 @@ may or may not hold. If the contract is a first-order contract, a result of @racket[#t] guarantees that the contract holds.} -@defproc[(contract-name [c contract?]) any/c]{ -Produces the name used to describe the contract in error messages. -} - @defproc[(contract-first-order [c contract?]) (-> any/c boolean?)]{ Produces the first-order test used by @racket[or/c] to match values to higher-order contracts. } + +@section{Contract Utilities} + +@declare-exporting-ctc[racket/contract/base] + +@defproc[(contract? [v any/c]) boolean?]{ + +Returns @racket[#t] if its argument is a contract (i.e., constructed +with one of the combinators described in this section or a value that +can be used as a contract) and @racket[#f] otherwise.} + +@defproc[(chaperone-contract? [v any/c]) boolean?]{ + +Returns @racket[#t] if its argument is a contract that guarantees that +it returns a value which passes @racket[chaperone-of?] when compared to +the original, uncontracted value.} + +@defproc[(flat-contract? [v any/c]) boolean?]{ + +Returns @racket[#t] when its argument is a contract that can be +checked immediately (unlike, say, a function contract). + +For example, +@racket[flat-contract] constructs flat contracts from predicates, and +symbols, booleans, numbers, and other ordinary Racket values +(that are defined as @tech{contracts}) are also +flat contracts.} + +@defproc[(flat-contract-predicate [v flat-contract?]) + (any/c . -> . any/c)]{ + +Extracts the predicate from a flat contract.} + +@defproc[(contract-name [c contract?]) any/c]{ +Produces the name used to describe the contract in error messages. +} + +@defproc[(value-contract [v has-contract?]) contract?]{ + Returns the contract attached to @racket[v], if recorded. + Otherwise it returns @racket[#f]. +} + +@defproc[(has-contract? [v any/c]) boolean?]{ + Returns @racket[#t] if @racket[v] is a value that + has a recorded contract attached to it. +} + @defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{ Produces the projection defining a contract's behavior on protected values. @@ -1817,46 +1894,6 @@ Produces the projection defining a contract's behavior on protected values. Makes a contract that accepts no values, and reports the name @racket[sexp-name] when signaling a contract violation.} - -@defparam[current-blame-format - proc - (-> blame? any/c string? string?)]{ - -A parameter that is used when constructing a -contract violation error. Its value is procedure that -accepts three arguments: -@itemize[ -@item{the blame object for the violation,} -@item{the value that the contract applies to, and} -@item{a message indicating the kind of violation.}] -The procedure then -returns a string that is put into the contract error -message. Note that the value is often already included in -the message that indicates the violation. - -@defexamples[#:eval (contract-eval) -(define (show-blame-error blame value message) - (string-append - "Contract Violation!\n" - (format "Guilty Party: ~a\n" (blame-positive blame)) - (format "Innocent Party: ~a\n" (blame-negative blame)) - (format "Contracted Value Name: ~a\n" (blame-value blame)) - (format "Contract Location: ~s\n" (blame-source blame)) - (format "Contract Name: ~a\n" (blame-contract blame)) - (format "Offending Value: ~s\n" value) - (format "Offense: ~a\n" message))) -(current-blame-format show-blame-error) -(define/contract (f x) - (-> integer? integer?) - (/ x 2)) -(f 2) -(f 1) -(f 1/2) -] - -} - - @defform*[[(recursive-contract contract-expr) (recursive-contract contract-expr type)]]{ @@ -1963,4 +2000,4 @@ makes a binary search tree contract, but one that is struct and returns a projection function that checks the contract. } - \ No newline at end of file + diff --git a/collects/syntax/parse/experimental/provide.rkt b/collects/syntax/parse/experimental/provide.rkt index 98c261af96..43b435bdbf 100644 --- a/collects/syntax/parse/experimental/provide.rkt +++ b/collects/syntax/parse/experimental/provide.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/contract/base + racket/contract/combinator syntax/location (for-syntax racket/base racket/syntax diff --git a/collects/syntax/parse/experimental/reflect.rkt b/collects/syntax/parse/experimental/reflect.rkt index b2969c8e05..3445eea56b 100644 --- a/collects/syntax/parse/experimental/reflect.rkt +++ b/collects/syntax/parse/experimental/reflect.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/contract/base + racket/contract/combinator "../private/minimatch.rkt" "../private/keywords.rkt" "../private/runtime-reflect.rkt" diff --git a/collects/syntax/parse/private/rep-data.rkt b/collects/syntax/parse/private/rep-data.rkt index a44b2b53b2..2a306dd935 100644 --- a/collects/syntax/parse/private/rep-data.rkt +++ b/collects/syntax/parse/private/rep-data.rkt @@ -195,12 +195,10 @@ Arguments is defined in rep-patterns.rkt ;; Contracts -(define DeclEnv/c - (flat-named-contract 'DeclEnv declenv?)) +(define DeclEnv/c declenv?) -(define DeclEntry/c - (flat-named-contract 'DeclEntry - (or/c den:lit? den:class? den:parser? den:delayed?))) +(define DeclEntry/c + (or/c den:lit? den:class? den:parser? den:delayed?)) (define SideClause/c (or/c clause:fail? clause:with? clause:attr? clause:do?)) diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-scheme/private/with-types.rkt index d334893dd6..56420d212e 100644 --- a/collects/typed-scheme/private/with-types.rkt +++ b/collects/typed-scheme/private/with-types.rkt @@ -4,7 +4,7 @@ (for-template (except-in racket/base for for*) "prims.rkt" - (prefix-in c: (combine-in racket/contract/regions racket/contract/base))) + (prefix-in c: (combine-in racket/contract/region racket/contract/base))) "extra-procs.rkt" "prims.rkt" syntax/parse racket/block racket/match unstable/sequence "base-types-extra.rkt" diff --git a/collects/unstable/prop-contract.rkt b/collects/unstable/prop-contract.rkt index d7e5fbc851..9399d4186e 100644 --- a/collects/unstable/prop-contract.rkt +++ b/collects/unstable/prop-contract.rkt @@ -1,5 +1,6 @@ #lang racket/base -(require racket/contract/base) +(require racket/contract/base + racket/contract/combinator) (define (get-stpc-proj stpc) (let ([get-val-proj diff --git a/collects/web-server/stuffers/stuffer.rkt b/collects/web-server/stuffers/stuffer.rkt index 0a4e2d8cdc..18095253fe 100644 --- a/collects/web-server/stuffers/stuffer.rkt +++ b/collects/web-server/stuffers/stuffer.rkt @@ -1,5 +1,4 @@ #lang racket - (define-struct stuffer (in out)) (define (stuffer/c dom rng) (define in (dom . -> . rng)) diff --git a/collects/xml/private/structures.rkt b/collects/xml/private/structures.rkt index e58ad1120c..b12daeba45 100644 --- a/collects/xml/private/structures.rkt +++ b/collects/xml/private/structures.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base +(require racket/contract) ; Location = (make-location Nat Nat Nat) | Symbol (define-struct location (line char offset) #:transparent)