diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 6339c80ddd..0b29fdddf8 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -1992,6 +1992,9 @@ first-order test fails, and produces the value unchanged otherwise. The @racket[val-first-proj] is like @racket[late-neg-proj], except with an extra layer of currying. +At least one of the @racket[late-neg-proj], @racket[proj], + @racket[val-first-proj], or @racket[first-order] must be non-@racket[#f]. + The projection arguments (@racket[late-neg-proj], @racket[proj], and @racket[val-first-proj]) must be in sync with the @racket[test] argument. In particular, if the test argument returns @racket[#f] for some value, @@ -2106,6 +2109,30 @@ contracts. The error messages assume that the function named by @history[#:added "6.1.1.5"] } +@defproc[(get/build-late-neg-projection [c contract?]) + (-> contract? blame? (-> any/c any/c any/c))]{ + Returns the @racket[_late-neg] projection for @racket[c]. + + If @racket[c] does not have a @racket[_late-neg] contract, + then this function uses the original projection for it + and logs a warning to the @racket['racket/contract] logger. + + See @racket[make-contract] for more details. + + @history[#:added "6.2.900.11"] +} + +@defparam[skip-projection-wrapper? wrap? boolean? #:value #f]{ + The functions @racket[make-chaperone-contract] and + @racket[build-chaperone-contract-property] wrap their + arguments to ensure that the result of the projections + are chaperones of the input. This layer of wrapping can, + in some cases, introduce unwanted overhead into contract + checking. If this parameter's value is @racket[#t] + during the dynamic extent of the call to either of those + functions, the wrapping (and thus the checks) are skipped. +} + @subsection{Blame Objects} @defproc[(blame? [x any/c]) boolean?]{ @@ -2526,6 +2553,9 @@ whose values will be generated by this process; and @racket[is-flat-contract?], which is used by @racket[flat-contract?] to determine if this contract accepts only @racket[list?]s. +At least one of the @racket[late-neg-proj], @racket[proj], +@racket[val-first-proj], or @racket[first-order] must be non-@racket[#f]. + These accessors are passed as (optional) keyword arguments to @racket[build-contract-property], and are applied to instances of the appropriate structure type by the contract system. Their results are used diff --git a/pkgs/racket-test/tests/racket/contract/make-contract.rkt b/pkgs/racket-test/tests/racket/contract/make-contract.rkt index 8f7ff01bf2..04bb43c3d1 100644 --- a/pkgs/racket-test/tests/racket/contract/make-contract.rkt +++ b/pkgs/racket-test/tests/racket/contract/make-contract.rkt @@ -134,6 +134,52 @@ '(contract proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) exn:fail?) + (contract-eval + '(define val-first-proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (make-chaperone-contract + #:name 'bad-prime-box-list/c + #:first-order (λ (v) (and (list? v) (andmap box? v))) + #:val-first-projection + (λ (blame) + (λ (v) + (λ (neg-party) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v + #:missing-party neg-party + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v)))))))) + + (contract-error-test + 'contract-error-test6 + '(contract val-first-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) + + (contract-eval + '(define late-neg-proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (make-chaperone-contract + #:name 'bad-prime-box-list/c + #:first-order (λ (v) (and (list? v) (andmap box? v))) + #:late-neg-projection + (λ (blame) + (λ (v neg-party) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v))))))) + + (contract-error-test + 'contract-error-test7 + '(contract late-neg-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) + (test/pos-blame 'build-chaperone-contract-property1 '(let () @@ -156,6 +202,88 @@ (((contract-projection (val-first-none)) (make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t)) 5))) + + (contract-eval + '(define prop:late-neg-proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (struct ctc () + #:property + prop:chaperone-contract + (build-chaperone-contract-property + #:name (λ (c) 'bad-prime-box-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap box? v)))) + #:late-neg-projection + (λ (c) + (λ (blame) + (λ (v neg-party) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v #:missing-party neg-party + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v)))))) + (ctc)))) + + (contract-error-test + 'contract-error-test8 + '(contract prop:late-neg-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) + + (contract-eval + '(define prop:val-first-proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (struct ctc () + #:property + prop:chaperone-contract + (build-chaperone-contract-property + #:name (λ (c) 'bad-prime-box-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap box? v)))) + #:val-first-projection + (λ (c) + (λ (blame) + (λ (v) + (λ (neg-party) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v #:missing-party neg-party + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v))))))) + (ctc)))) + + (contract-error-test + 'contract-error-test9 + '(contract prop:val-first-proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) + + (contract-eval + '(define prop:proj:bad-prime-box-list/c + (let* ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))] + [wrap-box (λ (blame b) (box (unbox b)))]) + (struct ctc () + #:property + prop:chaperone-contract + (build-chaperone-contract-property + #:name (λ (c) 'bad-prime-box-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap box? v)))) + #:projection + (λ (c) + (λ (blame) + (λ (v) + (unless (and (list? v) (andmap box? v)) + (raise-blame-error blame v + "expected list of boxes, got ~v" v)) + (map (λ (b) (wrap-box blame b)) v)))))) + (ctc)))) + + (contract-error-test + 'contract-error-test10 + '(contract prop:proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg) + exn:fail?) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -226,4 +354,228 @@ (test/spec-passed/result 'make-flat-contract-bad-6 '(chaperone-contract? proj:prime-list/c) - #t)) \ No newline at end of file + #t) + + (contract-eval + '(define val-first-proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (make-flat-contract + #:name 'prime-list/c + #:first-order (λ (v) (and (list? v) (andmap prime? v))) + #:val-first-projection + (λ (b) + (λ (v) + (λ (neg-party) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v #:missing-party neg-party + "expected prime list, got ~v" v)) + (map values v)))))))) + + + + +(test/spec-passed/result + 'make-flat-contract-bad-7 + '(contract val-first-proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-8 + '(contract val-first-proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-9 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract val-first-proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? val-first-proj:prime-list/c) +(ctest #t flat-contract? val-first-proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-10 + '(chaperone-contract? val-first-proj:prime-list/c) + #t) + + + (contract-eval + '(define late-neg-proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (make-flat-contract + #:name 'prime-list/c + #:first-order (λ (v) (and (list? v) (andmap prime? v))) + #:late-neg-projection + (λ (b) + (λ (v neg-party) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v #:missing-party neg-party "expected prime list, got ~v" v)) + (map values v))))))) + + + + +(test/spec-passed/result + 'make-flat-contract-bad-11 + '(contract late-neg-proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-12 + '(contract late-neg-proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-13 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract late-neg-proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? late-neg-proj:prime-list/c) +(ctest #t flat-contract? late-neg-proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-14 + '(chaperone-contract? late-neg-proj:prime-list/c) + #t) + + +(contract-eval + '(define prop:proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (struct ctc () + #:property + prop:flat-contract + (build-flat-contract-property + #:name (λ (c) 'prime-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap prime? v)))) + #:projection + (λ (c) + (λ (b) + (λ (v) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v "expected prime list, got ~v" v)) + (map values v)))))) + + (ctc)))) + +(test/spec-passed/result + 'make-flat-contract-bad-15 + '(contract prop:proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-16 + '(contract prop:proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-17 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract prop:proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? prop:proj:prime-list/c) +(ctest #t flat-contract? prop:proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-18 + '(chaperone-contract? prop:proj:prime-list/c) + #t) + + +(contract-eval + '(define prop:val-first-proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (struct ctc () + #:property + prop:flat-contract + (build-flat-contract-property + #:name (λ (c) 'prime-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap prime? v)))) + #:val-first-projection + (λ (c) + (λ (b) + (λ (v) + (λ (neg-party) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v + #:missing-party neg-party + "expected prime list, got ~v" v)) + (map values v))))))) + + (ctc)))) + +(test/spec-passed/result + 'make-flat-contract-bad-19 + '(contract prop:val-first-proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-20 + '(contract prop:val-first-proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-21 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract prop:val-first-proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? prop:val-first-proj:prime-list/c) +(ctest #t flat-contract? prop:val-first-proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-22 + '(chaperone-contract? prop:val-first-proj:prime-list/c) + #t) + + (contract-eval + '(define prop:late-neg-proj:prime-list/c + (let ([prime? (λ (n) + (for/and ([m (in-range 2 (add1 (floor (sqrt n))))]) + (not (= (remainder n m) 0))))]) + (struct ctc () + #:property + prop:flat-contract + (build-flat-contract-property + #:name (λ (c) 'prime-list/c) + #:first-order (λ (c) (λ (v) (and (list? v) (andmap prime? v)))) + #:late-neg-projection + (λ (c) + (λ (b) + (λ (v neg-party) + (unless (and (list? v) (andmap prime? v)) + (raise-blame-error b v + #:missing-party neg-party + "expected prime list, got ~v" v)) + (map values v)))))) + + (ctc)))) + +(test/spec-passed/result + 'make-flat-contract-bad-23 + '(contract prop:late-neg-proj:prime-list/c (list 2 3 5 7) 'pos 'neg) + (list 2 3 5 7)) + +(test/pos-blame + 'make-flat-contract-bad-24 + '(contract prop:late-neg-proj:prime-list/c (list 2 3 4 5) 'pos 'neg)) + +(test/spec-passed/result + 'make-flat-contract-bad-25 + '(let ([l (list 2 3 5 7)]) + (eq? l (contract prop:late-neg-proj:prime-list/c l 'pos 'neg))) + #t) + +(ctest #t contract? prop:late-neg-proj:prime-list/c) +(ctest #t flat-contract? prop:late-neg-proj:prime-list/c) + +(test/spec-passed/result + 'make-flat-contract-bad-26 + '(chaperone-contract? prop:late-neg-proj:prime-list/c) + #t)) diff --git a/racket/collects/racket/contract/combinator.rkt b/racket/collects/racket/contract/combinator.rkt index b2075fe620..5072060024 100644 --- a/racket/collects/racket/contract/combinator.rkt +++ b/racket/collects/racket/contract/combinator.rkt @@ -1,5 +1,6 @@ #lang racket/base (require "private/prop.rkt" + (prefix-in : "private/prop.rkt") "private/guts.rkt" "private/blame.rkt") @@ -12,7 +13,11 @@ contract-struct-stronger? contract-struct? chaperone-contract-struct? - flat-contract-struct?) + flat-contract-struct? + make-chaperone-contract + make-flat-contract + build-chaperone-contract-property + build-flat-contract-property) (except-out (all-from-out "private/guts.rkt") check-flat-contract @@ -21,4 +26,177 @@ has-contract? value-contract) - (except-out (all-from-out "private/blame.rkt") make-blame)) + (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] + [-build-flat-contract-property build-flat-contract-property]) + skip-projection-wrapper?) + +(define skip-projection-wrapper? (make-parameter #f)) + +(define (maybe-add-wrapper f x) + (cond + [(and x (not (skip-projection-wrapper?))) + (f x)] + [else x])) + +(define -make-chaperone-contract + (let ([make-chaperone-contract + (λ (#:name [name 'anonymous-chaperone-contract] + #:first-order [first-order (λ (x) #t)] + #:late-neg-projection [late-neg-projection #f] + #:val-first-projection [val-first-projection #f] + #:projection [projection #f] + #:stronger [stronger #f] + #:list-contract? [is-list-contract #f]) + (:make-chaperone-contract + #:name name + #:first-order first-order + #:late-neg-projection + (maybe-add-wrapper add-late-neg-chaperone-check late-neg-projection) + #:val-first-projection + (maybe-add-wrapper add-val-first-chaperone-check val-first-projection) + #:projection + (maybe-add-wrapper add-projection-chaperone-check projection) + #:stronger stronger + #:list-contract? is-list-contract))]) + make-chaperone-contract)) + +(define -build-chaperone-contract-property + (let () + (define (build-chaperone-contract-property + #:name [get-name (λ (c) 'anonymous-chaperone-contract)] + #:first-order [get-first-order (λ (c) (λ (x) #t))] + #:val-first-projection [val-first-proj #f] + #:late-neg-projection [late-neg-proj #f] + #:projection [get-projection #f] + #:stronger [stronger #f] + #:generate [generate #f] + #:exercise [exercise #f]) + (:build-chaperone-contract-property + #:name get-name + #:first-order get-first-order + #:val-first-projection + (maybe-add-wrapper add-prop-val-first-chaperone-check val-first-proj) + #:late-neg-projection + (maybe-add-wrapper add-prop-late-neg-chaperone-check late-neg-proj) + #:projection + (maybe-add-wrapper add-prop-chaperone-check get-projection) + #:stronger stronger + #:generate generate + #:exercise exercise)) + build-chaperone-contract-property)) + +(define (add-prop-late-neg-chaperone-check get-late-neg) + (λ (c) + (add-late-neg-chaperone-check (get-late-neg c)))) + +(define (add-late-neg-chaperone-check accepts-blame) + (λ (b) + (define accepts-val-and-np (accepts-blame b)) + (λ (x neg-party) + (check-and-signal x + (accepts-val-and-np x neg-party) + 'make-chaperone-contract::late-neg-projection)))) + +(define (add-prop-val-first-chaperone-check get) + (λ (c) + (add-val-first-chaperone-check (get c)))) + +(define (add-val-first-chaperone-check vfp) + (λ (b) + (define x-acceptor (vfp b)) + (λ (x) + (define neg-acceptor (x-acceptor x)) + (λ (neg-party) + (check-and-signal x + (neg-acceptor neg-party) + 'make-chaperone-contract::late-neg-projection))))) + +(define (add-prop-chaperone-check get) + (λ (c) + (add-projection-chaperone-check (get c)))) + +(define (add-projection-chaperone-check proj) + (λ (b) + (define x-acceptor (proj b)) + (λ (x) + (check-and-signal x (x-acceptor x) + 'make-chaperone-contract::projection)))) + + +(define (check-and-signal val chapd-val who) + (unless (chaperone-of? chapd-val val) + (raise-result-error who + (format "chaperone-of ~e" val) + chapd-val)) + chapd-val) + +(define -make-flat-contract + (let ([make-flat-contract + (λ (#:name [name 'anonymous-chaperone-contract] + #:first-order [first-order (λ (x) #t)] + #:late-neg-projection [late-neg-projection #f] + #:val-first-projection [val-first-projection #f] + #:projection [projection #f] + #:stronger [stronger #f] + #:list-contract? [is-list-contract #f]) + (:make-flat-contract + #:name name + #:first-order first-order + #:late-neg-projection (force-late-neg-eq late-neg-projection) + #:val-first-projection (force-val-first-eq val-first-projection) + #:projection (force-projection-eq projection) + #:stronger stronger + #:list-contract? is-list-contract))]) + make-flat-contract)) + +(define -build-flat-contract-property + (let ([build-flat-contract-property + (λ (#:name [name (λ (c) 'anonymous-chaperone-contract)] + #:first-order [first-order (λ (c) (λ (x) #t))] + #:late-neg-projection [late-neg-projection #f] + #:val-first-projection [val-first-projection #f] + #:projection [projection #f] + #:stronger [stronger #f] + #:list-contract? [is-list-contract #f]) + (:build-flat-contract-property + #:name name + #:first-order first-order + #:late-neg-projection + (and late-neg-projection (λ (c) (force-late-neg-eq (late-neg-projection c)))) + #:val-first-projection + (and val-first-projection (λ (c) (force-val-first-eq (val-first-projection c)))) + #:projection + (and projection (λ (c) (force-projection-eq (projection c)))) + #:stronger stronger + #:list-contract? is-list-contract))]) + build-flat-contract-property)) + +(define (force-late-neg-eq accepts-blame) + (and accepts-blame + (λ (b) + (define accepts-val-and-np (accepts-blame b)) + (λ (x neg-party) + (accepts-val-and-np x neg-party) + x)))) + +(define (force-val-first-eq vfp) + (and vfp + (λ (b) + (define x-acceptor (vfp b)) + (λ (x) + (define neg-acceptor (x-acceptor x)) + (λ (neg-party) + (neg-acceptor neg-party) + x))))) + +(define (force-projection-eq proj) + (and proj + (λ (b) + (define x-acceptor (proj b)) + (λ (x) + (x-acceptor x) + x)))) + diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt index e3f6ff3159..d2bf3b4715 100644 --- a/racket/collects/racket/contract/private/arr-i.rkt +++ b/racket/collects/racket/contract/private/arr-i.rkt @@ -87,11 +87,11 @@ (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) - blame) + blame #f) (check-procedure val mtd? (->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) - blame))) + blame #f))) ctc blame swapped-blame ;; used by the #:pre and #:post checking (append blames @@ -313,8 +313,8 @@ [opt-kwds (->i-opt-kwds ctc)]) (λ (val) (if has-rest - (check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f) - (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f))))) + (check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f #f) + (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f #f))))) #:exercise exercise->i #:stronger (λ (this that) (eq? this that)))) ;; WRONG diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index bcff1fc39d..8015f6c108 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -308,7 +308,7 @@ #`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) (let ([basic-lambda-name basic-lambda]) (arrow:arity-checking-wrapper val - (blame-add-missing-party blame neg-party) + blame neg-party basic-lambda-name void #,min-method-arity @@ -321,7 +321,7 @@ #`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) (let ([kwd-lambda-name kwd-lambda]) (arrow:arity-checking-wrapper val - (blame-add-missing-party blame neg-party) + blame neg-party void kwd-lambda-name #,min-method-arity @@ -335,7 +335,7 @@ (let ([basic-lambda-name basic-lambda] [kwd-lambda-name kwd-lambda]) (arrow:arity-checking-wrapper val - (blame-add-missing-party blame neg-party) + blame neg-party basic-lambda-name kwd-lambda-name #,min-method-arity diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 931eeee516..1345678b5d 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -911,7 +911,6 @@ (for/list ([kwd (in-list (append mandatory-keywords optional-keywords))] [kwd-proj (in-list (append mandatory-dom-kwd-projs optional-dom-kwd-projs))]) (cons kwd kwd-proj)))) - (define complete-blame (blame-add-missing-party blame neg-party)) (define interposition-proc (make-keyword-procedure @@ -936,7 +935,8 @@ (loop (cdr args) (cdr projs)))]))) (define (result-checker . results) (unless (= rng-len (length results)) - (arrow:bad-number-of-results complete-blame f rng-len results)) + (arrow:bad-number-of-results (blame-add-missing-party blame neg-party) + f rng-len results)) (apply values (for/list ([res (in-list results)] @@ -952,7 +952,7 @@ (cons result-checker args-dealt-with) args-dealt-with))))) - (arrow:arity-checking-wrapper f complete-blame + (arrow:arity-checking-wrapper f blame neg-party interposition-proc interposition-proc min-arity max-arity min-arity max-arity @@ -1176,44 +1176,43 @@ (base->-plus-one-arity-function ->stct) (base->-chaperone-constructor ->stct) #t))) - (parameterize ([skip-projection-wrapper? #t]) - (build-X-property - #:name base->-name - #:first-order ->-first-order - #:projection - (λ (this) - (define cthis (val-first-proj this)) - (λ (blame) - (define cblame (cthis blame)) - (λ (val) - ((cblame val) #f)))) - #:stronger - (λ (this that) - (and (base->? that) - (= (length (base->-doms that)) - (length (base->-doms this))) - (= (base->-min-arity this) (base->-min-arity that)) - (andmap contract-stronger? (base->-doms that) (base->-doms this)) - (= (length (base->-kwd-infos this)) - (length (base->-kwd-infos that))) - (for/and ([this-kwd-info (base->-kwd-infos this)] - [that-kwd-info (base->-kwd-infos that)]) - (and (equal? (kwd-info-kwd this-kwd-info) - (kwd-info-kwd that-kwd-info)) - (contract-stronger? (kwd-info-ctc that-kwd-info) - (kwd-info-ctc this-kwd-info)))) - (if (base->-rngs this) - (and (base->-rngs that) - (andmap contract-stronger? (base->-rngs this) (base->-rngs that))) - (not (base->-rngs that))) - (not (base->-pre? this)) - (not (base->-pre? that)) - (not (base->-post? this)) - (not (base->-post? that)))) - #:generate ->-generate - #:exercise ->-exercise - #:val-first-projection val-first-proj - #:late-neg-projection late-neg-proj))) + (build-X-property + #:name base->-name + #:first-order ->-first-order + #:projection + (λ (this) + (define cthis (val-first-proj this)) + (λ (blame) + (define cblame (cthis blame)) + (λ (val) + ((cblame val) #f)))) + #:stronger + (λ (this that) + (and (base->? that) + (= (length (base->-doms that)) + (length (base->-doms this))) + (= (base->-min-arity this) (base->-min-arity that)) + (andmap contract-stronger? (base->-doms that) (base->-doms this)) + (= (length (base->-kwd-infos this)) + (length (base->-kwd-infos that))) + (for/and ([this-kwd-info (base->-kwd-infos this)] + [that-kwd-info (base->-kwd-infos that)]) + (and (equal? (kwd-info-kwd this-kwd-info) + (kwd-info-kwd that-kwd-info)) + (contract-stronger? (kwd-info-ctc that-kwd-info) + (kwd-info-ctc this-kwd-info)))) + (if (base->-rngs this) + (and (base->-rngs that) + (andmap contract-stronger? (base->-rngs this) (base->-rngs that))) + (not (base->-rngs that))) + (not (base->-pre? this)) + (not (base->-pre? that)) + (not (base->-post? this)) + (not (base->-post? that)))) + #:generate ->-generate + #:exercise ->-exercise + #:val-first-projection val-first-proj + #:late-neg-projection late-neg-proj)) (define-struct (-> base->) () #:property diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index 42dd7ee2ee..ba27288f4e 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -87,46 +87,46 @@ [(p-app-x ...) (generate-temporaries #'(rngs ...))] [(res-x ...) (generate-temporaries #'(rngs ...))]) #`(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) - (let ([proj-x (contract-projection rngs-x)] ...) + (let ([proj-x (get/build-late-neg-projection rngs-x)] ...) (define (projection wrapper get-ctc) (λ (orig-blame) (define ctc (get-ctc)) (let ([rng-blame (blame-add-range-context orig-blame)]) - (let* ([p-app-x (proj-x rng-blame)] ... - [res-checker (λ (res-x ...) (values/drop (p-app-x res-x) ...))]) - (λ (val) - (check-is-a-procedure orig-blame val) + (let* ([p-app-x (proj-x rng-blame)] ...) + (λ (val neg-party) + (check-is-a-procedure orig-blame neg-party val) + (define (res-checker res-x ...) (values/drop (p-app-x res-x neg-party) ...)) (wrapper val (make-keyword-procedure (λ (kwds kwd-vals . args) (with-continuation-mark - contract-continuation-mark-key orig-blame - #,(check-tail-contract - #'(p-app-x ...) - (list #'res-checker) - (λ (s) #`(apply values #,@s kwd-vals args))))) + contract-continuation-mark-key (cons orig-blame neg-party) + #,(check-tail-contract + #'(p-app-x ...) + (list #'res-checker) + (λ (s) #`(apply values #,@s kwd-vals args))))) (λ args (with-continuation-mark - contract-continuation-mark-key orig-blame - #,(check-tail-contract - #'(p-app-x ...) - (list #'res-checker) - (λ (s) #`(apply values #,@s args)))))) + contract-continuation-mark-key (cons orig-blame neg-party) + #,(check-tail-contract + #'(p-app-x ...) + (list #'res-checker) + (λ (s) #`(apply values #,@s args)))))) impersonator-prop:contracted ctc impersonator-prop:application-mark (cons contract-key (list p-app-x ...)))))))) (make-unconstrained-domain-> (list rngs-x ...) projection))))])) -(define (check-is-a-procedure orig-blame val) +(define (check-is-a-procedure orig-blame neg-party val) (unless (procedure? val) - (raise-blame-error orig-blame + (raise-blame-error orig-blame #:missing-party neg-party val '(expected: "a procedure" given: "~v") val))) -(define (make-unconstrained-domain-> ctcs projection) +(define (make-unconstrained-domain-> ctcs late-neg-projection) (define name (apply build-compound-type-name 'unconstrained-domain-> (map contract-name ctcs))) @@ -134,11 +134,11 @@ (if (andmap chaperone-contract? ctcs) (make-chaperone-contract #:name name - #:projection (projection chaperone-procedure (λ () ctc)) + #:late-neg-projection (late-neg-projection chaperone-procedure (λ () ctc)) #:first-order procedure?) (make-contract #:name name - #:projection (projection impersonate-procedure (λ () ctc)) + #:late-neg-projection (late-neg-projection impersonate-procedure (λ () ctc)) #:first-order procedure?))) ctc) @@ -201,18 +201,25 @@ (loop (cdr accepted) req-kwds (cdr opt-kwds))] [else #f]))]))) -(define-for-syntax (create-chaperone blame val pre post this-args doms opt-doms dom-rest req-kwds opt-kwds rngs) +(define-for-syntax (create-chaperone blame neg-party val pre post this-args + doms opt-doms dom-rest req-kwds opt-kwds + rngs) (with-syntax ([blame blame] + [neg-party neg-party] [val val]) (with-syntax ([(pre ...) (if pre (list #`(unless #,pre - (raise-blame-error (blame-swap blame) val "#:pre condition"))) + (raise-blame-error + (blame-swap blame) #:missing-party neg-party + val "#:pre condition"))) null)] [(post ...) (if post (list #`(unless #,post - (raise-blame-error blame val "#:post condition"))) + (raise-blame-error + blame #:missing-party neg-party + val "#:post condition"))) null)]) (with-syntax ([(this-param ...) this-args] [(dom-ctc ...) doms] @@ -240,12 +247,12 @@ (if (and (pair? rngs) (null? (cdr rngs))) (with-syntax ([proj (car (syntax->list #'(rng-ctc ...)))] [name (car (syntax->list #'(rng-x ...)))]) - #'(proj name)) - #'(values/drop (rng-ctc rng-x) ...))]) + #'(proj name neg-party)) + #'(values/drop (rng-ctc rng-x neg-party) ...))]) #'(case-lambda [(rng-x ...) (with-continuation-mark - contract-continuation-mark-key blame + contract-continuation-mark-key (cons blame neg-party) (let () post ... rng-results))] @@ -267,13 +274,15 @@ [else #'(this-param ... dom-x ... [opt-dom-x unspecified-dom] ...)])] [opt+rest-uses - (for/fold ([i (if dom-rest #'(rest-ctc rest-x) #'null)]) - ([o (in-list (reverse (syntax->list #'([opt-dom-ctc opt-dom-x] ...))))]) + (for/fold ([i (if dom-rest #'(rest-ctc rest-x neg-party) #'null)]) + ([o (in-list (reverse + (syntax->list + #'((opt-dom-ctc opt-dom-x) ...))))]) (let* ([l (syntax->list o)] [c (car l)] [x (cadr l)]) #`(let ([r #,i]) - (if (eq? unspecified-dom #,x) r (cons (#,c #,x) r)))))] + (if (eq? unspecified-dom #,x) r (cons (#,c #,x neg-party) r)))))] [(kwd-param ...) (apply append (map list @@ -282,9 +291,12 @@ [kwd-stx (let* ([req-stxs (map (λ (s) (λ (r) #`(cons #,s #,r))) - (syntax->list #'((req-kwd-ctc req-kwd-x) ...)))] + (syntax->list #'((req-kwd-ctc req-kwd-x neg-party) ...)))] [opt-stxs - (map (λ (x c) (λ (r) #`(let ([r #,r]) (if (eq? unspecified-dom #,x) r (cons (#,c #,x) r))))) + (map (λ (x c) (λ (r) #`(let ([r #,r]) + (if (eq? unspecified-dom #,x) + r + (cons (#,c #,x neg-party) r))))) (syntax->list #'(opt-kwd-x ...)) (syntax->list #'(opt-kwd-ctc ...)))] [reqs (map cons req-keywords req-stxs)] @@ -301,16 +313,23 @@ [basic-return (let ([inner-stx-gen (if need-apply-values? - (λ (s) #`(apply values #,@s this-param ... (dom-ctc dom-x) ... opt+rest-uses)) - (λ (s) #`(values/drop #,@s this-param ... (dom-ctc dom-x) ...)))]) + (λ (s) #`(apply values #,@s this-param ... + (dom-ctc dom-x neg-party) ... opt+rest-uses)) + (λ (s) #`(values/drop #,@s this-param ... + (dom-ctc dom-x neg-party) ...)))]) (if no-rng-checking? (inner-stx-gen #'()) - (check-tail-contract #'(rng-ctc ...) #'(rng-checker-name ...) inner-stx-gen)))] + (check-tail-contract #'(rng-ctc ...) + #'(rng-checker-name ...) + inner-stx-gen)))] [kwd-return (let* ([inner-stx-gen (if need-apply-values? - (λ (s k) #`(apply values #,@s #,@k this-param ... (dom-ctc dom-x) ... opt+rest-uses)) - (λ (s k) #`(values/drop #,@s #,@k this-param ... (dom-ctc dom-x) ...)))] + (λ (s k) #`(apply values #,@s #,@k this-param ... + (dom-ctc dom-x neg-party) ... + opt+rest-uses)) + (λ (s k) #`(values/drop #,@s #,@k this-param ... + (dom-ctc dom-x neg-party) ...)))] [outer-stx-gen (if (null? req-keywords) (λ (s) @@ -335,13 +354,13 @@ ;; noticeable in my measurements so far. ;; - stamourv (with-continuation-mark - contract-continuation-mark-key blame + contract-continuation-mark-key (cons blame neg-party) (let () pre ... basic-return)))] [kwd-lambda-name (gen-id 'kwd-lambda)] [kwd-lambda #`(λ kwd-lam-params (with-continuation-mark - contract-continuation-mark-key blame + contract-continuation-mark-key (cons blame neg-party) (let () pre ... kwd-return)))]) (with-syntax ([(basic-checker-name) (generate-temporaries '(basic-checker))]) @@ -349,7 +368,7 @@ [(and (null? req-keywords) (null? opt-keywords)) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) (let ([basic-lambda-name basic-lambda]) - (arity-checking-wrapper val blame + (arity-checking-wrapper val blame neg-party basic-lambda-name void #,min-method-arity @@ -361,7 +380,7 @@ [(pair? req-keywords) #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) (let ([kwd-lambda-name kwd-lambda]) - (arity-checking-wrapper val blame + (arity-checking-wrapper val blame neg-party void kwd-lambda-name #,min-method-arity @@ -374,7 +393,7 @@ #`(let-values ([(rng-checker-name ...) (values/drop rng-checker ...)]) (let ([basic-lambda-name basic-lambda] [kwd-lambda-name kwd-lambda]) - (arity-checking-wrapper val blame + (arity-checking-wrapper val blame neg-party basic-lambda-name kwd-lambda-name #,min-method-arity @@ -385,7 +404,7 @@ '(opt-kwd ...))))]))))))))))) ;; should we pass both the basic-lambda and the kwd-lambda? -(define (arity-checking-wrapper val blame basic-lambda kwd-lambda +(define (arity-checking-wrapper val blame neg-party basic-lambda kwd-lambda min-method-arity max-method-arity min-arity max-arity req-kwd opt-kwd) ;; should not build this unless we are in the 'else' case (and maybe not at all) @@ -404,27 +423,28 @@ (define kwd-checker (if (and (null? req-kwd) (null? opt-kwd)) (λ (kwds kwd-args . args) - (raise-no-keywords-arg blame val kwds)) + (raise-no-keywords-arg blame #:missing-party neg-party val kwds)) (λ (kwds kwd-args . args) (with-continuation-mark - contract-continuation-mark-key blame + contract-continuation-mark-key (cons blame neg-party) (let () (define args-len (length args)) (unless (valid-number-of-args? args) (raise-wrong-number-of-args-error - blame val + blame #:missing-party neg-party val args-len max-arity min-method-arity max-method-arity)) ;; these two for loops are doing O(n^2) work that could be linear ;; (since the keyword lists are sorted) (for ([req-kwd (in-list req-kwd)]) (unless (memq req-kwd kwds) - (raise-blame-error (blame-swap blame) val + (raise-blame-error (blame-swap blame) #:missing-party neg-party + val '(expected "keyword argument ~a") req-kwd))) (for ([k (in-list kwds)]) (unless (memq k all-kwds) - (raise-blame-error (blame-swap blame) val + (raise-blame-error (blame-swap blame) #:missing-party neg-party val '(received: "unexpected keyword argument ~a") k))) (keyword-apply kwd-lambda kwds kwd-args args)))))) @@ -432,16 +452,16 @@ (if (null? req-kwd) (λ args (with-continuation-mark - contract-continuation-mark-key blame + contract-continuation-mark-key (cons blame neg-party) (let () (unless (valid-number-of-args? args) (define args-len (length args)) (raise-wrong-number-of-args-error - blame val + blame #:missing-party neg-party val args-len max-arity min-method-arity max-method-arity)) (apply basic-lambda args)))) (λ args - (raise-blame-error (blame-swap blame) val + (raise-blame-error (blame-swap blame) #:missing-party neg-party val "expected required keyword ~a" (car req-kwd))))) (if (or (not va) (pair? vr) (pair? va)) @@ -509,15 +529,15 @@ mtd? mctc? func)) -(define ((->-proj wrapper) ctc) - (let* ([doms-proj (map contract-projection +(define ((late-neg-->-proj wrapper) ctc) + (let* ([doms-proj (map get/build-late-neg-projection (if (base->-dom-rest/c ctc) (append (base->-doms/c ctc) (list (base->-dom-rest/c ctc))) (base->-doms/c ctc)))] - [doms-optional-proj (map contract-projection (base->-optional-doms/c ctc))] - [rngs-proj (map contract-projection (base->-rngs/c ctc))] - [mandatory-kwds-proj (map contract-projection (base->-mandatory-kwds/c ctc))] - [optional-kwds-proj (map contract-projection (base->-optional-kwds/c ctc))] + [doms-optional-proj (map get/build-late-neg-projection (base->-optional-doms/c ctc))] + [rngs-proj (map get/build-late-neg-projection (base->-rngs/c ctc))] + [mandatory-kwds-proj (map get/build-late-neg-projection (base->-mandatory-kwds/c ctc))] + [optional-kwds-proj (map get/build-late-neg-projection (base->-optional-kwds/c ctc))] [mandatory-keywords (base->-mandatory-kwds ctc)] [optional-keywords (base->-optional-kwds ctc)] [func (base->-func ctc)] @@ -529,11 +549,10 @@ [mtd? (base->-mtd? ctc)]) (λ (orig-blame) (define rng-blame (blame-add-range-context orig-blame)) - (define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t)) (define partial-doms (for/list ([dom (in-list doms-proj)] [n (in-naturals 1)]) - (dom (blame-add-context orig-blame + (dom (blame-add-context orig-blame (if (and has-rest? (n . > . dom-length)) "the rest argument of" @@ -563,11 +582,13 @@ (define the-args (append partial-doms partial-optional-doms partial-mandatory-kwds partial-optional-kwds partial-ranges)) - (λ (val) + (λ (val neg-party) (if has-rest? - (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords orig-blame) - (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords orig-blame)) - (define chap/imp-func (apply func orig-blame val the-args)) + (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords + orig-blame neg-party) + (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords + orig-blame neg-party)) + (define chap/imp-func (apply func orig-blame neg-party val the-args)) (if post (wrapper val @@ -632,18 +653,17 @@ (define-struct (chaperone-> base->) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:projection (->-proj chaperone-procedure) - #:name ->-name - #:first-order ->-first-order - #:stronger ->-stronger?))) + (build-chaperone-contract-property + #:late-neg-projection (late-neg-->-proj chaperone-procedure) + #:name ->-name + #:first-order ->-first-order + #:stronger ->-stronger?)) (define-struct (impersonator-> base->) () #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection (->-proj impersonate-procedure) + #:late-neg-projection (late-neg-->-proj impersonate-procedure) #:name ->-name #:first-order ->-first-order #:stronger ->-stronger?)) @@ -796,9 +816,9 @@ (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)] [->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)] [outer-lambda - #`(lambda (blame val dom-names ... kwd-names ... rng-names ...) + #`(lambda (blame neg-party val dom-names ... kwd-names ... rng-names ...) #,(create-chaperone - #'blame #'val #f #f + #'blame #'neg-party #'val #f #f (syntax->list #'(this-params ...)) (syntax->list #'(dom-names ...)) null #f (map list (syntax->list #'(kwds ...)) @@ -977,7 +997,7 @@ #''()) #,(if rng-ctc #f #t) mtd? ->m-ctc? - (λ (blame f + (λ (blame neg-party f mandatory-dom-proj ... #,@(if rest-ctc #'(rest-proj) @@ -987,7 +1007,7 @@ optional-dom-kwd-proj ... rng-proj ...) #,(create-chaperone - #'blame #'f pre post + #'blame #'neg-party #'f pre post (syntax->list #'(this-parameter ...)) (syntax->list #'(mandatory-dom-proj ...)) (syntax->list #'(optional-dom-proj ...)) @@ -1249,7 +1269,7 @@ (syntax-local-infer-name stx) #`(λ args (apply f args)))))))))))))])) -(define ((->d-proj wrap-procedure) ->d-stct) +(define ((late-neg-->d-proj wrap-procedure) ->d-stct) (let* ([opt-count (length (base-->d-optional-dom-ctcs ->d-stct))] [mandatory-count (+ (length (base-->d-mandatory-dom-ctcs ->d-stct)) (if (base-->d-mtd? ->d-stct) 1 0))] @@ -1266,28 +1286,32 @@ [else (cons (+ mandatory-count i) (loop (+ i 1)))]))])]) (λ (blame) - (λ (val) - (if (base-->d-rest-ctc ->d-stct) - (check-procedure/more val - (base-->d-mtd? ->d-stct) - (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length - (base-->d-mandatory-keywords ->d-stct) - (base-->d-optional-keywords ->d-stct) - blame) - (check-procedure val - (base-->d-mtd? ->d-stct) - (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length - (length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length - (base-->d-mandatory-keywords ->d-stct) - (base-->d-optional-keywords ->d-stct) - blame)) - (wrap-procedure - val - (make-keyword-procedure - (λ (kwd-args kwd-arg-vals . raw-orig-args) - (with-continuation-mark - contract-continuation-mark-key blame - (let* ([orig-args (if (base-->d-mtd? ->d-stct) + (define dom-blame (blame-add-context blame "the domain of" #:swap? #t)) + (define rng-blame (blame-add-range-context blame)) + (λ (val neg-party) + (if (base-->d-rest-ctc ->d-stct) + (check-procedure/more val + (base-->d-mtd? ->d-stct) + (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length + (base-->d-mandatory-keywords ->d-stct) + (base-->d-optional-keywords ->d-stct) + blame + neg-party) + (check-procedure val + (base-->d-mtd? ->d-stct) + (length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length + (length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length + (base-->d-mandatory-keywords ->d-stct) + (base-->d-optional-keywords ->d-stct) + blame + neg-party)) + (wrap-procedure + val + (make-keyword-procedure + (λ (kwd-args kwd-arg-vals . raw-orig-args) + (with-continuation-mark + contract-continuation-mark-key (cons blame neg-party) + (let* ([orig-args (if (base-->d-mtd? ->d-stct) (cdr raw-orig-args) raw-orig-args)] [this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))] @@ -1296,7 +1320,7 @@ (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) (when (base-->d-pre-cond ->d-stct) (unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args) - (raise-blame-error (blame-swap blame) + (raise-blame-error (blame-swap blame) #:missing-party neg-party val "#:pre violation~a" (build-values-string ", argument" dep-pre-args)))) @@ -1316,44 +1340,44 @@ (if rng (list (λ orig-results (with-continuation-mark - contract-continuation-mark-key blame - (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 (base-->d-rest-ctc ->d-stct) - (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) - (when (base-->d-post-cond ->d-stct) - (unless (apply (base-->d-post-cond ->d-stct) dep-post-args) - (raise-blame-error blame + contract-continuation-mark-key (cons blame neg-party) + (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 (base-->d-rest-ctc ->d-stct) + (base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) + (when (base-->d-post-cond ->d-stct) + (unless (apply (base-->d-post-cond ->d-stct) dep-post-args) + (raise-blame-error blame #:missing-party neg-party + 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 #:missing-party neg-party 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 - #f) - (loop (cdr results) (cdr result-contracts)))]))))))) + "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) + rng-blame + neg-party) + (loop (cdr results) (cdr result-contracts)))]))))))) null)) ;; contracted keyword arguments @@ -1365,9 +1389,16 @@ [(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 #t) - (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))]))]) + (cons (invoke-dep-ctc (car kwd-ctcs) + dep-pre-args + (car building-kwd-arg-vals) + dom-blame + neg-party) + (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))]))]) (if (null? kwd-res) null (list kwd-res))) @@ -1383,20 +1414,24 @@ (cond [(null? args) (if (base-->d-rest-ctc ->d-stct) - (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() blame #t) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() + dom-blame neg-party) '())] [(null? non-kwd-ctcs) (if (base-->d-rest-ctc ->d-stct) - (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args blame #t) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) + dep-pre-args args dom-blame neg-party) ;; 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 #t) + [else (cons (invoke-dep-ctc (car non-kwd-ctcs) + dep-pre-args (car args) + dom-blame neg-party) (loop (cdr args) (cdr non-kwd-ctcs)))])))))))) - impersonator-prop:contracted ->d-stct))))) + impersonator-prop:contracted ->d-stct))))) (define (build-values-string desc dep-pre-args) (cond @@ -1413,15 +1448,14 @@ (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 dom?) +(define (invoke-dep-ctc dep-ctc dep-args val blame neg-party) (let ([ctc (coerce-contract '->d (if dep-args (apply dep-ctc dep-args) dep-ctc))]) - (((contract-projection ctc) - (if dom? - (blame-add-context blame "the domain of" #:swap? #t) - (blame-add-range-context blame))) - val))) + (((get/build-late-neg-projection ctc) + blame) + val + neg-party))) ;; 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) @@ -1529,8 +1563,8 @@ [optional-kwds (base-->d-optional-keywords ctc)]) (λ (val) (if (base-->d-rest-ctc ctc) - (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f) - (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f))))) + (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f #f) + (check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f #f))))) (define (->d-stronger? this that) (eq? this that)) ;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that @@ -1564,7 +1598,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection (->d-proj impersonate-procedure) + #:late-neg-projection (late-neg-->d-proj impersonate-procedure) #:name ->d-name #:first-order ->d-first-order #:stronger ->d-stronger?)) @@ -1637,7 +1671,8 @@ ;; check-procedure : ... (or/c #f blame) -> (or/c boolean? void?) ;; if blame is #f, then just return a boolean indicating that this matched ;; (for use in arity checking) -(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame) +(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords + blame neg-party) (define passes? (and (procedure? val) (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals) @@ -1646,7 +1681,7 @@ [blame (unless passes? (raise-blame-error - blame + blame #:missing-party neg-party val '(expected " a ~a that accepts ~a~a~a argument~a~a~a" given: "~e") (if mtd? "method" "procedure") @@ -1712,7 +1747,7 @@ ;; check-procedure/more : ... (or/c #f blame) -> (or/c boolean? void?) ;; if blame is #f, then just return a boolean indicating that this matched ;; (for use in arity checking) -(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame) +(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame neg-party) (define passes? (and (procedure? val) (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length)) diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt index 1214f2d1ff..0097eb0305 100644 --- a/racket/collects/racket/contract/private/case-arrow.rkt +++ b/racket/collects/racket/contract/private/case-arrow.rkt @@ -74,9 +74,9 @@ [rng (let ([rng-checkers (list #`(case-lambda - [(rng-id ...) (values/drop (rng-proj-x rng-id) ...)] + [(rng-id ...) (values/drop (rng-proj-x rng-id neg-party) ...)] [args - (bad-number-of-results blame f + (bad-number-of-results blame #:missing-party neg-party f #,(length (syntax->list #'(rng-id ...))) args #,n)]))] @@ -85,19 +85,20 @@ (check-tail-contract #'(rng-proj-x ...) rng-checkers (λ (rng-checks) #`(apply values #,@rng-checks this-parameter ... - (dom-proj-x dom-formals) ... - (rst-proj-x rst-formal)))) - (check-tail-contract #'(rng-proj-x ...) rng-checkers - (λ (rng-checks) - #`(values/drop #,@rng-checks this-parameter ... - (dom-proj-x dom-formals) ...)))))] + (dom-proj-x dom-formals neg-party) ... + (rst-proj-x rst-formal neg-party)))) + (check-tail-contract + #'(rng-proj-x ...) rng-checkers + (λ (rng-checks) + #`(values/drop #,@rng-checks this-parameter ... + (dom-proj-x dom-formals neg-party) ...)))))] [rst #`(apply values this-parameter ... - (dom-proj-x dom-formals) ... - (rst-proj-x rst-formal))] + (dom-proj-x dom-formals neg-party) ... + (rst-proj-x rst-formal neg-party))] [else #`(values/drop this-parameter ... - (dom-proj-x dom-formals) ...)])))))) + (dom-proj-x dom-formals neg-party) ...)])))))) (define-syntax (case-> stx) (syntax-case stx () @@ -130,7 +131,7 @@ ctc #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) - (λ (f) + (λ (f neg-party) (put-it-together #,(let ([case-lam (syntax/loc stx (case-lambda [formals body] ...))]) @@ -138,14 +139,14 @@ #`(let ([#,name #,case-lam]) #,name) case-lam)) (list (list rng-proj-x ...) ...) - f blame wrapper ctc + f blame neg-party wrapper ctc chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))])) -(define (put-it-together the-case-lam range-projections f blame wrapper ctc chk mtd?) +(define (put-it-together the-case-lam range-projections f blame neg-party wrapper ctc chk mtd?) (chk f mtd?) (define checker (make-keyword-procedure - (raise-no-keywords-error f blame) + (raise-no-keywords-error f blame neg-party) (λ args (with-continuation-mark contract-continuation-mark-key blame (apply the-case-lam args))))) @@ -155,17 +156,18 @@ f checker impersonator-prop:contracted ctc - impersonator-prop:blame blame + impersonator-prop:blame (blame-add-missing-party blame neg-party) impersonator-prop:application-mark (cons contract-key same-rngs)) (wrapper f checker impersonator-prop:contracted ctc - impersonator-prop:blame blame))) + impersonator-prop:blame (blame-add-missing-party blame neg-party)))) -(define (raise-no-keywords-error f blame) +(define (raise-no-keywords-error f blame neg-party) (λ (kwds kwd-args . args) - (raise-blame-error blame f "expected no keywords, got keyword ~a" (car kwds)))) + (raise-blame-error blame f #:missing-party neg-party + "expected no keywords, got keyword ~a" (car kwds)))) ;; dom-ctcs : (listof (listof contract)) ;; rst-ctcs : (listof contract) @@ -180,8 +182,7 @@ (define (case->-proj wrapper) (λ (ctc) (define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc)) - (define rng-ctcs (map contract-projection - (get-case->-rng-ctcs ctc))) + (define rng-late-neg-ctcs (map contract-late-neg-projection (get-case->-rng-ctcs ctc))) (define rst-ctcs (base-case->-rst-ctcs ctc)) (define specs (base-case->-specs ctc)) (λ (blame) @@ -210,7 +211,7 @@ (apply p args)))]) (set! memo (cons (cons f new) memo)) new)))) - rng-ctcs))) + rng-late-neg-ctcs))) (define (chk val mtd?) (cond [(null? specs) @@ -220,8 +221,8 @@ (for-each (λ (dom-length has-rest?) (if has-rest? - (check-procedure/more val mtd? dom-length '() '() blame) - (check-procedure val mtd? dom-length 0 '() '() blame))) + (check-procedure/more val mtd? dom-length '() '() blame #f) + (check-procedure val mtd? dom-length 0 '() '() blame #f))) specs rst-ctcs)])) (apply (base-case->-wrapper ctc) chk @@ -260,7 +261,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property - #:projection (case->-proj chaperone-procedure) + #:late-neg-projection (case->-proj chaperone-procedure) #:name case->-name #:first-order case->-first-order #:stronger case->-stronger?)) @@ -269,7 +270,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property - #:projection (case->-proj impersonate-procedure) + #:late-neg-projection (case->-proj impersonate-procedure) #:name case->-name #:first-order case->-first-order #:stronger case->-stronger?)) @@ -290,11 +291,11 @@ [rst (in-list (base-case->-rst-ctcs ctc))] [i (in-naturals)]) (define dom+case-nums - (map (λ (dom) (cons i (contract-projection dom))) doms)) + (map (λ (dom) (cons i (contract-late-neg-projection dom))) doms)) (append acc (if rst (append dom+case-nums - (list (cons i (contract-projection rst)))) + (list (cons i (contract-late-neg-projection rst)))) dom+case-nums)))) (define (get-case->-rng-ctcs ctc) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index f01fd1c6b2..0e48a68791 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -57,6 +57,7 @@ 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 @@ -276,14 +277,13 @@ (define-struct (chaperone-and/c base-and/c) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:projection and-proj - #:late-neg-projection late-neg-and-proj - #:name and-name - #:first-order and-first-order - #:stronger and-stronger? - #:generate and/c-generate?))) + (build-chaperone-contract-property + #:projection and-proj + #:late-neg-projection late-neg-and-proj + #:name and-name + #:first-order and-first-order + #:stronger and-stronger? + #:generate and/c-generate?)) (define-struct (impersonator-and/c base-and/c) () #:property prop:custom-write custom-write-property-proc #:property prop:contract @@ -449,20 +449,21 @@ (build-flat-contract-property #:name (λ (c) `(,name ,(-ctc-x c))) #:first-order (λ (ctc) (define x (-ctc-x ctc)) (λ (y) (and (real? y) ( y x)))) - #:projection (λ (ctc) - (define x (-ctc-x ctc)) - (λ (blame) - (λ (val) - (if (and (real? val) ( val x)) - val - (raise-blame-error - blame val - '(expected: - "a number strictly ~a than ~v" - given: "~v") - less/greater - x - val))))) + #:late-neg-projection + (λ (ctc) + (define x (-ctc-x ctc)) + (λ (blame) + (λ (val neg-party) + (if (and (real? val) ( val x)) + val + (raise-blame-error + blame val #:missing-party neg-party + '(expected: + "a number strictly ~a than ~v" + given: "~v") + less/greater + x + val))))) #:generate (λ (ctc) (define x (-ctc-x ctc)) @@ -968,15 +969,14 @@ (define-struct (chaperone-cons/c the-cons/c) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d))) - #:projection (cons/c-ho-check (λ (v a d) (cons a d))) - #:name cons/c-name - #:first-order cons/c-first-order - #:stronger cons/c-stronger? - #:generate cons/c-generate - #:list-contract? cons/c-list-contract?))) + (build-chaperone-contract-property + #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d))) + #:projection (cons/c-ho-check (λ (v a d) (cons a d))) + #:name cons/c-name + #:first-order cons/c-first-order + #:stronger cons/c-stronger? + #:generate cons/c-generate + #:list-contract? cons/c-list-contract?)) (define-struct (impersonator-cons/c the-cons/c) () #:property prop:custom-write custom-write-property-proc #:property prop:contract @@ -1355,16 +1355,15 @@ (struct chaperone-list/c generic-list/c () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:name list/c-name-proc - #:first-order list/c-first-order - #:generate list/c-generate - #:exercise list/c-exercise - #:stronger list/c-stronger - #:projection list/c-chaperone/other-projection - #:late-neg-projection list/c-chaperone/other-late-neg-projection - #:list-contract? (λ (c) #t)))) + (build-chaperone-contract-property + #:name list/c-name-proc + #:first-order list/c-first-order + #:generate list/c-generate + #:exercise list/c-exercise + #:stronger list/c-stronger + #:projection list/c-chaperone/other-projection + #:late-neg-projection list/c-chaperone/other-late-neg-projection + #:list-contract? (λ (c) #t))) (struct higher-order-list/c generic-list/c () #:property prop:custom-write custom-write-property-proc @@ -1913,10 +1912,10 @@ ((proj blame) val)))) (define (generator evt) (values evt (checker evt))) - (λ (val) + (λ (val neg-party) (unless (contract-first-order-passes? evt-ctc val) (raise-blame-error - blame val + blame val #:missing-party neg-party '(expected: "~s" given: "~e") (contract-name evt-ctc) val)) @@ -1944,7 +1943,7 @@ (define-struct chaperone-evt/c (ctcs) #:property prop:chaperone-contract (build-chaperone-contract-property - #:projection evt/c-proj + #:late-neg-projection evt/c-proj #:first-order evt/c-first-order #:stronger evt/c-stronger? #:name evt/c-name)) @@ -2063,33 +2062,95 @@ (define (contract? x) (and (coerce-contract/f x) #t)) (define (contract-projection ctc) - (contract-struct-projection + (get/build-projection (coerce-contract 'contract-projection ctc))) (define (contract-val-first-projection ctc) - (contract-struct-val-first-projection + (get/build-val-first-projection (coerce-contract 'contract-projection ctc))) (define (contract-late-neg-projection ctc) - (contract-struct-late-neg-projection + (get/build-late-neg-projection (coerce-contract 'contract-projection ctc))) -(define (get/build-val-first-projection ctc) - (or (contract-struct-val-first-projection ctc) - (let ([p (contract-projection ctc)]) - (λ (blme) - (procedure-rename - (λ (val) - (λ (neg-party) - ((p (blame-add-missing-party blme neg-party)) val))) - (string->symbol (format "val-first: ~s" (contract-name ctc)))))))) - +(define-logger racket/contract) (define (get/build-late-neg-projection ctc) - (or (contract-struct-late-neg-projection ctc) - (let ([p (contract-projection ctc)]) - (λ (blme) - (procedure-rename - (λ (val neg-party) - ((p (blame-add-missing-party blme neg-party)) val)) - (string->symbol (format "late-neg: ~s" (contract-name 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 (get/build-val-first-projection ctc) + (cond + [(contract-struct-val-first-projection ctc) => values] + [else + (when (warn-about-val-first?) + (log-racket/contract-warning + "building val-first-projection of contract ~s for~a" + ctc + (build-context))) + (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 (build-context) + (apply + string-append + (for/list ([i (in-list (continuation-mark-set->context + (current-continuation-marks)))]) + (format "\n ~s" i)))) (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (flat-named-contract name pre-contract [generate #f]) diff --git a/racket/collects/racket/contract/private/opters.rkt b/racket/collects/racket/contract/private/opters.rkt index 0ea739207f..b1ef4d8dbe 100644 --- a/racket/collects/racket/contract/private/opters.rkt +++ b/racket/collects/racket/contract/private/opters.rkt @@ -662,7 +662,7 @@ ((next-dom ...) next-doms) (dom-len (length dom-vars))) (syntax (begin - (check-procedure val #f dom-len 0 '() '() #|keywords|# blame) + (check-procedure val #f dom-len 0 '() '() #|keywords|# blame #f) (chaperone-procedure val (case-lambda @@ -743,7 +743,7 @@ (define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info #t)) (define (handle-non-exact-procedure val dom-len blame exact-proc) - (check-procedure val #f dom-len 0 '() '() blame) + (check-procedure val #f dom-len 0 '() '() blame #f) (chaperone-procedure val (make-keyword-procedure diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt index d61f49dbb0..2b1e410333 100644 --- a/racket/collects/racket/contract/private/orc.rkt +++ b/racket/collects/racket/contract/private/orc.rkt @@ -217,18 +217,17 @@ (define-struct (chaperone-single-or/c single-or/c) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:projection single-or/c-projection - #:late-neg-projection single-or/c-late-neg-projection - #:name single-or/c-name - #:first-order single-or/c-first-order - #:stronger single-or/c-stronger? - #:generate (λ (ctc) (or/c-generate ctc - (cons (single-or/c-ho-ctc ctc) - (single-or/c-flat-ctcs ctc)))) - #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))) - #:list-contract? single-or/c-list-contract?))) + (build-chaperone-contract-property + #:projection single-or/c-projection + #:late-neg-projection single-or/c-late-neg-projection + #:name single-or/c-name + #:first-order single-or/c-first-order + #:stronger single-or/c-stronger? + #:generate (λ (ctc) (or/c-generate ctc + (cons (single-or/c-ho-ctc ctc) + (single-or/c-flat-ctcs ctc)))) + #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))) + #:list-contract? single-or/c-list-contract?)) (define-struct (impersonator-single-or/c single-or/c) () #:property prop:custom-write custom-write-property-proc @@ -376,18 +375,17 @@ (define-struct (chaperone-multi-or/c multi-or/c) () #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:projection multi-or/c-proj - #:late-neg-projection multi-or/c-late-neg-proj - #:name multi-or/c-name - #:first-order multi-or/c-first-order - #:stronger multi-or/c-stronger? - #:generate (λ (ctc) (or/c-generate ctc - (append (multi-or/c-ho-ctcs ctc) - (multi-or/c-flat-ctcs ctc)))) - #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))) - #:list-contract? mult-or/c-list-contract?))) + (build-chaperone-contract-property + #:projection multi-or/c-proj + #:late-neg-projection multi-or/c-late-neg-proj + #:name multi-or/c-name + #:first-order multi-or/c-first-order + #:stronger multi-or/c-stronger? + #:generate (λ (ctc) (or/c-generate ctc + (append (multi-or/c-ho-ctcs ctc) + (multi-or/c-flat-ctcs ctc)))) + #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))) + #:list-contract? mult-or/c-list-contract?)) (define-struct (impersonator-multi-or/c multi-or/c) () #:property prop:custom-write custom-write-property-proc @@ -539,16 +537,15 @@ (define-struct (chaperone-first-or/c base-first-or/c) () #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:projection first-or/c-proj - #:late-neg-projection first-or/c-late-neg-proj - #:name first-or/c-name - #:first-order first-or/c-first-order - #:stronger multi-or/c-stronger? - #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc))) - #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc))) - #:list-contract? first-or/c-list-contract?))) + (build-chaperone-contract-property + #:projection first-or/c-proj + #:late-neg-projection first-or/c-late-neg-proj + #:name first-or/c-name + #:first-order first-or/c-first-order + #:stronger multi-or/c-stronger? + #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc))) + #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc))) + #:list-contract? first-or/c-list-contract?)) (define-struct (impersonator-first-or/c base-first-or/c) () #:property prop:contract (build-contract-property @@ -596,7 +593,7 @@ (λ (ctc) (flat-rec-contract-name ctc)) #:stronger (let ([recur? (make-parameter #t)]) - (λ (this that) + (λ (this that) (cond [(equal? this that) #t] [(recur?) diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt index 3c11ea0c82..5e10eeada1 100644 --- a/racket/collects/racket/contract/private/prop.rkt +++ b/racket/collects/racket/contract/private/prop.rkt @@ -35,8 +35,6 @@ make-chaperone-contract make-flat-contract - skip-projection-wrapper? - prop:opt-chaperone-contract prop:opt-chaperone-contract? prop:opt-chaperone-contract-get-test @@ -97,10 +95,9 @@ first-order)) (define (contract-struct-projection c) - (let* ([prop (contract-struct-property c)] - [get-projection (contract-property-projection prop)] - [projection (get-projection c)]) - projection)) + (define prop (contract-struct-property c)) + (define get-projection (contract-property-projection prop)) + (and get-projection (get-projection c))) (define (contract-struct-val-first-projection c) (define prop (contract-struct-property c)) @@ -111,7 +108,7 @@ (define (contract-struct-late-neg-projection c) (define prop (contract-struct-property c)) (define get-projection (contract-property-late-neg-projection prop)) - (and get-projection + (and get-projection (get-projection c))) (define trail (make-parameter #f)) @@ -256,9 +253,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define skip-projection-wrapper? (make-parameter #f)) - -(define ((build-property mk default-name projection-wrapper) +(define ((build-property mk default-name proc-name first-order?) #:name [get-name #f] #:first-order [get-first-order #f] #:projection [get-projection #f] @@ -268,76 +263,41 @@ #:generate [generate (λ (ctc) (λ (fuel) #f))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:list-contract? [list-contract? (λ (c) #f)]) - - ;; this code is here to help me find the combinators that - ;; are still using only #:projection and not #:late-neg-projection - #; - (when (and get-projection - (not get-late-neg-projection)) - (printf "missing late-neg-projection ~s\n" - get-projection)) - - (let* ([get-name (or get-name (lambda (c) default-name))] - [get-first-order (or get-first-order get-any?)] - [get-val-first-projection - (or get-val-first-projection - (and (not get-projection) - (get-val-first-first-order-projection get-name get-first-order)))] - [get-late-neg-projection - (or get-late-neg-projection - (and (not get-projection) - (get-late-neg-first-order-projection get-name get-first-order)))] - [get-projection - (cond - [get-projection - (blame-context-projection-wrapper - (if (skip-projection-wrapper?) - get-projection - (projection-wrapper get-projection)))] - [else (val-first-projection->projection get-val-first-projection - get-name - get-first-order)])] - [stronger (or stronger weakest)]) - - (mk get-name get-first-order - get-projection stronger - generate exercise - get-val-first-projection - get-late-neg-projection - list-contract?))) + (unless (or get-first-order + get-projection + get-val-first-projection + get-late-neg-projection) + (error + proc-name + (string-append + "expected either the #:get-projection, #:val-first-project, or #:late-neg-projection" + " to not be #f, but all three were #f"))) + + (mk (or get-name (λ (c) default-name)) + (or get-first-order get-any?) + get-projection + (or stronger weakest) + generate exercise + get-val-first-projection + (cond + [first-order? + (or get-late-neg-projection + (λ (c) + (late-neg-first-order-projection (get-name c) (get-first-order c))))] + [else get-late-neg-projection]) + list-contract?)) (define build-contract-property (procedure-rename - (build-property make-contract-property 'anonymous-contract values) + (build-property make-contract-property 'anonymous-contract 'build-contract-property #f) 'build-contract-property)) -;; Here we'll force the projection to always return the original value, -;; instead of assuming that the provided projection does so appropriately. -(define (flat-projection-wrapper f) - (λ (c) - (let ([proj (f c)]) - (λ (b) - (let ([p (proj b)]) - (λ (v) (p v) v)))))) - (define build-flat-contract-property (procedure-rename (build-property (compose make-flat-contract-property make-contract-property) - 'anonymous-flat-contract - flat-projection-wrapper) + 'anonymous-flat-contract 'build-flat-contract-property #t) 'build-flat-contract-property)) -(define (chaperone-projection-wrapper f) - (λ (c) - (let ([proj (f c)]) - (λ (b) - (let ([p (proj b)]) - (λ (v) - (let ([v* (p v)]) - (unless (chaperone-of? v* v) - (error 'prop:chaperone-contract (format "expected a chaperone of ~v, got ~v" v v*))) - v*))))))) - (define (blame-context-projection-wrapper proj) (λ (ctc) (define c-proj (proj ctc)) @@ -347,8 +307,7 @@ (define build-chaperone-contract-property (procedure-rename (build-property (compose make-chaperone-contract-property make-contract-property) - 'anonymous-chaperone-contract - chaperone-projection-wrapper) + 'anonymous-chaperone-contract 'build-chaperone-contract-property #f) 'build-chaperone-contract-property)) (define (get-any? c) any?) @@ -460,41 +419,12 @@ #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:list-contract? [list-contract? (λ (ctc) #f)]) - (let* ([name (or name default-name)] - [first-order (or first-order any?)] - [projection (or projection (first-order-projection name first-order))] - [val-first-projection (or val-first-projection - (and (not projection) - (val-first-first-order-projection name first-order)))] - [late-neg-projection (or late-neg-projection - (and (not projection) - (late-neg-first-order-projection name first-order)))] - [stronger (or stronger as-strong?)]) - - (mk name first-order - projection val-first-projection late-neg-projection - stronger - generate exercise - list-contract?))) - -(define ((get-val-first-first-order-projection get-name get-first-order) c) - (val-first-first-order-projection (get-name c) (get-first-order c))) - -(define ((get-late-neg-first-order-projection get-name get-first-order) c) - (late-neg-first-order-projection (get-name c) (get-first-order c))) - -(define (val-first-first-order-projection name p?) - (λ (b) - (λ (v) - (λ (neg-party) - (if (p? v) - v - (raise-blame-error - b #:missing-party neg-party - v - '(expected: "~s" given: "~e") - name - v)))))) + (mk (or name default-name) + (or first-order any?) + projection val-first-projection late-neg-projection + (or stronger as-strong?) + generate exercise + list-contract?)) (define (late-neg-first-order-projection name p?) (λ (b) diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index 9fd3edbe08..5e7ea939d3 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -384,36 +384,25 @@ ;; ... -> (or/c #f (-> blame val)) (define (do-partial-app ctc val name pos-module-source source) - (define p (contract-struct-val-first-projection ctc)) + (define p (parameterize ([warn-about-val-first? #f]) + ;; when we're building the val-first projection + ;; here we might be needing the plus1 arity + ;; function (which will be on the val first's result) + ;; so this is a legtimate use. don't warn. + (get/build-val-first-projection ctc))) (define blme (make-blame (build-source-location source) name (λ () (contract-name ctc)) pos-module-source #f #t)) + (define neg-accepter ((p blme) val)) - (cond - [p - (define neg-accepter ((p blme) val)) - - ;; we don't have the negative blame here, but we - ;; expect only positive failures from this; do the - ;; check and then toss the results. - (neg-accepter 'incomplete-blame-from-provide.rkt) - - neg-accepter] - [else - (define proj (contract-struct-projection ctc)) - - ;; we don't have the negative blame here, but we - ;; expect only positive failures from this; do the - ;; check and then toss the results. - ((proj blme) val) - - (procedure-rename - (λ (neg-party) - (define complete-blame (blame-add-missing-party blme neg-party)) - ((proj complete-blame) val)) - (string->symbol (format "provide.rkt:neg-party-fn:~s" (contract-name ctc))))])) + ;; we don't have the negative blame here, but we + ;; expect only positive failures from this; do the + ;; check and then toss the results. + (neg-accepter 'incomplete-blame-from-provide.rkt) + + neg-accepter) (define-for-syntax (true-provide/contract provide-stx just-check-errors? who) (syntax-case provide-stx () diff --git a/racket/collects/racket/contract/private/struct-dc.rkt b/racket/collects/racket/contract/private/struct-dc.rkt index a9a0be9096..f35f9c8e03 100644 --- a/racket/collects/racket/contract/private/struct-dc.rkt +++ b/racket/collects/racket/contract/private/struct-dc.rkt @@ -678,36 +678,33 @@ (define-struct (struct/dc base-struct/dc) () #:property prop:chaperone-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-chaperone-contract-property - #:name struct/dc-name - #:first-order struct/dc-first-order - #:projection struct/dc-proj - #:stronger struct/dc-stronger? - #:generate struct/dc-generate - #:exercise struct/dc-exercise))) + (build-chaperone-contract-property + #:name struct/dc-name + #:first-order struct/dc-first-order + #:projection struct/dc-proj + #:stronger struct/dc-stronger? + #:generate struct/dc-generate + #:exercise struct/dc-exercise)) (define-struct (flat-struct/dc base-struct/dc) () #:property prop:flat-contract - (parameterize ([skip-projection-wrapper? #t]) - (build-flat-contract-property - #:name struct/dc-name - #:first-order struct/dc-flat-first-order - #:projection struct/dc-proj - #:stronger struct/dc-stronger? - #:generate struct/dc-generate - #:exercise struct/dc-exercise))) + (build-flat-contract-property + #:name struct/dc-name + #:first-order struct/dc-flat-first-order + #:projection struct/dc-proj + #:stronger struct/dc-stronger? + #:generate struct/dc-generate + #:exercise struct/dc-exercise)) (define-struct (impersonator-struct/dc base-struct/dc) () #:property prop:contract - (parameterize ([skip-projection-wrapper? #t]) - (build-contract-property - #:name struct/dc-name - #:first-order struct/dc-first-order - #:projection struct/dc-proj - #:stronger struct/dc-stronger? - #:generate struct/dc-generate - #:exercise struct/dc-exercise))) + (build-contract-property + #:name struct/dc-name + #:first-order struct/dc-first-order + #:projection struct/dc-proj + #:stronger struct/dc-stronger? + #:generate struct/dc-generate + #:exercise struct/dc-exercise)) (define (build-struct/dc subcontracts constructor pred struct-name here name-info struct/c?) (for ([subcontract (in-list subcontracts)])