From 31cf0bdbc38b6172a4c8cafffbe1069f14ed624f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 22 Dec 2015 14:27:47 -0600 Subject: [PATCH] remove the error-prone except-out's from racket/contract and take the opportunity to move some things around internally to more reasonable places --- racket/collects/racket/contract/base.rkt | 123 ++++++++++++---- .../collects/racket/contract/combinator.rkt | 123 +++++++++++++--- .../collects/racket/contract/parametric.rkt | 4 +- .../collects/racket/contract/private/guts.rkt | 131 ++++++++++++++++++ .../racket/contract/private/legacy.rkt | 2 +- .../collects/racket/contract/private/misc.rkt | 126 +---------------- .../collects/racket/contract/private/prop.rkt | 2 +- 7 files changed, 331 insertions(+), 180 deletions(-) diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index dec48b2016..6354928697 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -20,37 +20,88 @@ "private/orc.rkt") (provide - (except-out (all-from-out "private/arrow.rkt") - making-a-method - procedure-accepts-and-more? - check-procedure - check-procedure/more - - contract-key - - ;; these two are provided for-syntax - ;check-tail-contract - ;make-this-parameters - - -> ->*) + base->? + ->d + base->-rngs/c + base->-doms/c + unconstrained-domain-> + the-unsupplied-arg + unsupplied-arg? + method-contract? + matches-arity-exactly? + keywords-match + bad-number-of-results + (for-syntax check-tail-contract + make-this-parameters + parse-leftover->*) + tail-marks-match? + values/drop + arity-checking-wrapper + unspecified-dom + blame-add-range-context + blame-add-nth-arg-context + (rename-out [->2 ->] [->*2 ->*]) dynamic->* predicate/c + + ->i + box-immutable/c + box/c + hash/c + hash/dc + vectorof + vector/c + vector-immutable/c + vector-immutableof + struct/dc + struct/c + struct-type-property/c + + contract + recursive-contract + invariant-assertion + + flat-murec-contract + and/c + not/c + =/c >=/c <=/c /c between/c + integer-in + char-in + real-in + natural-number/c + string-len/c + false/c + printable/c + listof list*of non-empty-listof cons/c list/c cons/dc + promise/c + syntax/c + + parameter/c + procedure-arity-includes/c + + any/c + any + none/c + make-none/c + + prompt-tag/c + continuation-mark-key/c + + channel/c + evt/c + + flat-contract + flat-contract-predicate + flat-named-contract + + blame-add-car-context + blame-add-cdr-context + raise-not-cons-blame-error + + rename-contract + if/c - (all-from-out "private/arr-i.rkt" - "private/box.rkt" - "private/hash.rkt" - "private/vector.rkt" - "private/struct-dc.rkt" - "private/struct-prop.rkt") - (except-out (all-from-out "private/base.rkt") - current-contract-region - (for-syntax lifted-key add-lifted-property)) - (except-out (all-from-out "private/misc.rkt") - check-between/c - check-unary-between/c - random-any/c - maybe-warn-about-val-first) symbols or/c first-or/c one-of/c flat-rec-contract provide/contract @@ -74,7 +125,23 @@ case-> ;; from here (needs `->`, so can't be deeper) - failure-result/c) + failure-result/c + + contract? + chaperone-contract? + impersonator-contract? + flat-contract? + + contract-late-neg-projection + contract-name + contract-projection + contract-val-first-projection + get/build-late-neg-projection + get/build-val-first-projection + + ;; not documented.... (ie unintentional export) + n->th) + ;; failure-result/c : contract ;; Describes the optional failure argument passed to hash-ref, for example. diff --git a/racket/collects/racket/contract/combinator.rkt b/racket/collects/racket/contract/combinator.rkt index 5072060024..587adc2825 100644 --- a/racket/collects/racket/contract/combinator.rkt +++ b/racket/collects/racket/contract/combinator.rkt @@ -1,32 +1,112 @@ #lang racket/base (require "private/prop.rkt" - (prefix-in : "private/prop.rkt") + (prefix-in : (only-in "private/prop.rkt" + build-chaperone-contract-property + build-flat-contract-property + make-chaperone-contract + make-flat-contract)) "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-val-first-projection - contract-struct-stronger? - contract-struct? - chaperone-contract-struct? - flat-contract-struct? - make-chaperone-contract - make-flat-contract - build-chaperone-contract-property - build-flat-contract-property) + prop:contract + contract-struct-late-neg-projection + contract-struct-generate + contract-struct-exercise + contract-struct-list-contract? - (except-out (all-from-out "private/guts.rkt") - check-flat-contract - check-flat-named-contract - make-predicate-contract - has-contract? - value-contract) + prop:flat-contract + prop:chaperone-contract + + contract-property? + build-contract-property + + chaperone-contract-property? + + flat-contract-property? + + make-contract + + prop:opt-chaperone-contract + prop:opt-chaperone-contract? + prop:opt-chaperone-contract-get-test + + prop:orc-contract + prop:orc-contract? + prop:orc-contract-get-subcontracts + + prop:recursive-contract + prop:recursive-contract? + prop:recursive-contract-unroll + + prop:arrow-contract + prop:arrow-contract? + prop:arrow-contract-get-info + (struct-out arrow-contract-info) + + coerce-contract + coerce-contracts + coerce-flat-contract + coerce-flat-contracts + coerce-chaperone-contract + coerce-chaperone-contracts + coerce-contract/f + + build-compound-type-name + + contract-stronger? + list-contract? + + contract-first-order + contract-first-order-passes? + + prop:contracted prop:blame + impersonator-prop:contracted impersonator-prop:blame + has-blame? value-blame + + ;; helpers for adding properties that check syntax uses + define/final-prop + define/subexpression-pos-prop + define/subexpression-pos-prop/name + + eq-contract? + eq-contract-val + equal-contract? + equal-contract-val + char-in/c + + contract-continuation-mark-key + with-contract-continuation-mark + + (struct-out wrapped-extra-arg-arrow) + contract-custom-write-property-proc + (rename-out [contract-custom-write-property-proc custom-write-property-proc]) + + set-some-basic-contracts! + + blame? + blame-source + blame-positive + blame-negative + blame-contract + blame-value + blame-original? + blame-swapped? + blame-swap + blame-replace-negative ;; used for indy blame + blame-update ;; used for option contract transfers + blame-add-context + blame-add-unknown-context + blame-context + + blame-add-missing-party + blame-missing-party? + + raise-blame-error + current-blame-format + (struct-out exn:fail:contract:blame) + blame-fmt->-string - (except-out (all-from-out "private/blame.rkt") make-blame) (rename-out [-make-chaperone-contract make-chaperone-contract] [-make-flat-contract make-flat-contract] [-build-chaperone-contract-property build-chaperone-contract-property] @@ -199,4 +279,3 @@ (λ (x) (x-acceptor x) x)))) - diff --git a/racket/collects/racket/contract/parametric.rkt b/racket/collects/racket/contract/parametric.rkt index fc0fb30b74..1c6a321ab0 100644 --- a/racket/collects/racket/contract/parametric.rkt +++ b/racket/collects/racket/contract/parametric.rkt @@ -1,6 +1,4 @@ #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") - ∀∃?)) +(provide new-∃/c new-∀/c parametric->/c) diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index df3f78f627..fbd88499d9 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -48,12 +48,27 @@ equal-contract-val char-in/c + contract? + chaperone-contract? + impersonator-contract? + flat-contract? + contract-continuation-mark-key with-contract-continuation-mark (struct-out wrapped-extra-arg-arrow) contract-custom-write-property-proc (rename-out [contract-custom-write-property-proc custom-write-property-proc]) + + contract-projection + contract-val-first-projection ;; might return #f (if none) + contract-late-neg-projection ;; might return #f (if none) + get/build-val-first-projection ;; builds one if necc., using contract-projection + get/build-late-neg-projection + warn-about-val-first? + + contract-name + maybe-warn-about-val-first set-some-basic-contracts!) @@ -80,6 +95,27 @@ (print (contract-struct-name stct) port 1) (write-suffix)])])) +(define (contract? x) (and (coerce-contract/f x) #t)) + +(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 + (or (chaperone-contract-struct? c) + (and (prop:opt-chaperone-contract? c) + ((prop:opt-chaperone-contract-get-test c) c)))))) + +(define (impersonator-contract? x) + (let ([c (coerce-contract/f x)]) + (and c + (not (flat-contract-struct? c)) + (not (chaperone-contract-struct? c))))) + + (define (has-contract? v) (or (has-prop:contracted? v) (has-impersonator-prop:contracted? v))) @@ -600,6 +636,100 @@ (make-predicate-contract name pred generate #f)) + +(define (contract-name ctc) + (contract-struct-name + (coerce-contract 'contract-name ctc))) + +(define (contract-projection ctc) + (get/build-projection + (coerce-contract 'contract-projection ctc))) +(define (contract-val-first-projection ctc) + (get/build-val-first-projection + (coerce-contract 'contract-projection ctc))) +(define (contract-late-neg-projection ctc) + (get/build-late-neg-projection + (coerce-contract 'contract-projection ctc))) + +(define-logger racket/contract) + +(define (get/build-late-neg-projection ctc) + (cond + [(contract-struct-late-neg-projection ctc) => values] + [else + (log-racket/contract-warning "no late-neg-projection for ~s" ctc) + (cond + [(contract-struct-projection ctc) + => + (λ (projection) + (projection->late-neg-projection projection))] + [(contract-struct-val-first-projection ctc) + => + (λ (val-first-projection) + (val-first-projection->late-neg-projection val-first-projection))] + [else + (first-order->late-neg-projection (contract-struct-first-order ctc) + (contract-struct-name ctc))])])) + +(define (projection->late-neg-projection proj) + (λ (b) + (λ (x neg-party) + ((proj (blame-add-missing-party b neg-party)) x)))) +(define (val-first-projection->late-neg-projection vf-proj) + (λ (b) + (define vf-val-accepter (vf-proj b)) + (λ (x neg-party) + ((vf-val-accepter x) neg-party)))) +(define (first-order->late-neg-projection p? name) + (λ (b) + (λ (x neg-party) + (if (p? x) + x + (raise-blame-error + b x #:missing-party neg-party + '(expected: "~a" given: "~e") + name + x))))) + +(define warn-about-val-first? (make-parameter #t)) +(define (maybe-warn-about-val-first ctc) + (when (warn-about-val-first?) + (log-racket/contract-warning + "building val-first-projection of contract ~s for~a" + ctc + (build-context)))) + +(define (get/build-val-first-projection ctc) + (cond + [(contract-struct-val-first-projection ctc) => values] + [else + (maybe-warn-about-val-first ctc) + (late-neg-projection->val-first-projection + (get/build-late-neg-projection ctc))])) +(define (late-neg-projection->val-first-projection lnp) + (λ (b) + (define val+neg-party-accepter (lnp b)) + (λ (x) + (λ (neg-party) + (val+neg-party-accepter x neg-party))))) + +(define (get/build-projection ctc) + (cond + [(contract-struct-projection ctc) => values] + [else + (log-racket/contract-warning + "building projection of contract ~s for~a" + ctc + (build-context)) + (late-neg-projection->projection + (get/build-late-neg-projection ctc))])) +(define (late-neg-projection->projection lnp) + (λ (b) + (define val+np-acceptor (lnp b)) + (λ (x) + (val+np-acceptor x #f)))) + + ;; Key used by the continuation mark that holds blame information for the current contract. ;; That information is consumed by the contract profiler. (define contract-continuation-mark-key @@ -612,3 +742,4 @@ ;; (unless (or (pair? payload) (not (blame-missing-party? payload))) ;; (error "internal error: missing blame party" payload)) (with-continuation-mark contract-continuation-mark-key payload code))) + diff --git a/racket/collects/racket/contract/private/legacy.rkt b/racket/collects/racket/contract/private/legacy.rkt index 4ebdb5b4d3..2b7817f6ca 100644 --- a/racket/collects/racket/contract/private/legacy.rkt +++ b/racket/collects/racket/contract/private/legacy.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require "blame.rkt" "prop.rkt" "misc.rkt" syntax/srcloc) +(require "blame.rkt" "prop.rkt" "guts.rkt" syntax/srcloc) (provide make-proj-contract raise-contract-error diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 1b18727990..6025b72e96 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -43,22 +43,10 @@ channel/c evt/c - chaperone-contract? - impersonator-contract? - flat-contract? - contract? - flat-contract flat-contract-predicate flat-named-contract - contract-projection - contract-val-first-projection ;; might return #f (if none) - contract-late-neg-projection ;; might return #f (if none) - get/build-val-first-projection ;; builds one if necc., using contract-projection - get/build-late-neg-projection - warn-about-val-first? - contract-name n->th blame-add-car-context @@ -68,9 +56,7 @@ random-any/c rename-contract - if/c - - maybe-warn-about-val-first) + if/c) (define-syntax (flat-murec-contract stx) (syntax-case stx () @@ -1804,116 +1790,6 @@ (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 - (or (chaperone-contract-struct? c) - (and (prop:opt-chaperone-contract? c) - ((prop:opt-chaperone-contract-get-test c) c)))))) - -(define (impersonator-contract? x) - (let ([c (coerce-contract/f x)]) - (and c - (not (flat-contract-struct? c)) - (not (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) - (get/build-projection - (coerce-contract 'contract-projection ctc))) -(define (contract-val-first-projection ctc) - (get/build-val-first-projection - (coerce-contract 'contract-projection ctc))) -(define (contract-late-neg-projection ctc) - (get/build-late-neg-projection - (coerce-contract 'contract-projection ctc))) - -(define-logger racket/contract) -(define (get/build-late-neg-projection ctc) - (cond - [(contract-struct-late-neg-projection ctc) => values] - [else - (log-racket/contract-warning "no late-neg-projection for ~s" ctc) - (cond - [(contract-struct-projection ctc) - => - (λ (projection) - (projection->late-neg-projection projection))] - [(contract-struct-val-first-projection ctc) - => - (λ (val-first-projection) - (val-first-projection->late-neg-projection val-first-projection))] - [else - (first-order->late-neg-projection (contract-struct-first-order ctc) - (contract-struct-name ctc))])])) - -(define (projection->late-neg-projection proj) - (λ (b) - (λ (x neg-party) - ((proj (blame-add-missing-party b neg-party)) x)))) -(define (val-first-projection->late-neg-projection vf-proj) - (λ (b) - (define vf-val-accepter (vf-proj b)) - (λ (x neg-party) - ((vf-val-accepter x) neg-party)))) -(define (first-order->late-neg-projection p? name) - (λ (b) - (λ (x neg-party) - (if (p? x) - x - (raise-blame-error - b x #:missing-party neg-party - '(expected: "~a" given: "~e") - name - x))))) - -(define warn-about-val-first? (make-parameter #t)) -(define (maybe-warn-about-val-first ctc) - (when (warn-about-val-first?) - (log-racket/contract-warning - "building val-first-projection of contract ~s for~a" - ctc - (build-context)))) - -(define (get/build-val-first-projection ctc) - (cond - [(contract-struct-val-first-projection ctc) => values] - [else - (maybe-warn-about-val-first ctc) - (late-neg-projection->val-first-projection - (get/build-late-neg-projection ctc))])) -(define (late-neg-projection->val-first-projection lnp) - (λ (b) - (define val+neg-party-accepter (lnp b)) - (λ (x) - (λ (neg-party) - (val+neg-party-accepter x neg-party))))) - -(define (get/build-projection ctc) - (cond - [(contract-struct-projection ctc) => values] - [else - (log-racket/contract-warning - "building projection of contract ~s for~a" - ctc - (build-context)) - (late-neg-projection->projection - (get/build-late-neg-projection ctc))])) -(define (late-neg-projection->projection lnp) - (λ (b) - (define val+np-acceptor (lnp b)) - (λ (x) - (val+np-acceptor x #f)))) - (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (flat-named-contract name pre-contract [generate #f]) (cond diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt index ea451a3e3b..4964594e3e 100644 --- a/racket/collects/racket/contract/private/prop.rkt +++ b/racket/collects/racket/contract/private/prop.rkt @@ -510,4 +510,4 @@ ;; raises a blame error if val doesn't satisfy the first-order checks for the function ;; accepts-arglist : (-> (listof keyword?)[sorted by keyword