diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl index c13c2a03f1..607a4f0f34 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -2249,6 +2249,17 @@ returns @racket[#t] for values that have one of these properties, and is expected to be the contract on the value). } +@deftogether[( +@defthing[prop:blame struct-type-property?] +@defthing[impersonator-prop:blame impersonator-property?] +)]{ +These properties attach a blame information to the protected structure, +chaperone, or impersonator value. The function @racket[blame-contract?] +returns @racket[#t] for values that have one of these properties, and +@racket[blame-contract] extracts the value from the property (which +is expected to be the blame record for the contract on the value). +} + @deftogether[( @defproc[(build-flat-contract-property [#:name @@ -2625,7 +2636,7 @@ Produces the name used to describe the contract in error messages. Returns the contract attached to @racket[v], if recorded. Otherwise it returns @racket[#f]. - To support @racket[value-contract] and @racket[has-contract?] + To support @racket[value-contract] and @racket[value-contract] in your own contract combinators, use @racket[prop:contracted] or @racket[impersonator-prop:contracted]. } @@ -2633,13 +2644,24 @@ Produces the name used to describe the contract in error messages. @defproc[(has-contract? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] is a value that has a recorded contract attached to it. - - See also @racket[value-contract]. } +@defproc[(value-blame [v has-blame?]) (or/c blame? #f)]{ + Returns the blame object for the contract attached + to @racket[v], if recorded. Otherwise it returns @racket[#f]. + + To support @racket[value-contract] and @racket[value-blame] + in your own contract combinators, use @racket[prop:blame] or + @racket[impersonator-prop:blame]. +} + +@defproc[(has-blame? [v any/c]) boolean?]{ + Returns @racket[#t] if @racket[v] is a value that + has a contract with blame information attached to it. +} @defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{ -Produces the projection defining a contract's behavior on protected values. + Produces the projection defining a contract's behavior on protected values. } @defproc[(make-none/c [sexp-name any/c]) contract?]{ diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt index b34be9e078..8548039b3d 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt @@ -16,7 +16,7 @@ #f #t)) (wrapped-extra-arg-arrow-extra-neg-party-argument (((contract-struct-val-first-projection c) blame) val)))) - + (test/spec-passed/result 'arity-as-string1 '(arity-as-string (let ([f (λ (x) x)]) f)) @@ -167,7 +167,6 @@ (->* (#:i integer? #:b boolean?) (#:c (listof char?) #:r regexp?) any) (λ (#:i i #:b b #:c [c '(#\a)] #:r [r #rx"x"]) 1)) 'neg #:i 1 #:b #t)) - (exit) (test/neg-blame '->*neg-party11 @@ -243,4 +242,3 @@ (list user db password port))) 'neg #:database "db" #:password "password" #:user "user") (list "user" "db" "password" #f))) - diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt index d3d6ef1afa..e8b8b57e65 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow.rkt @@ -355,4 +355,6 @@ '(let () (struct x (a)) (eq? (contract predicate/c x? 'pos 'neg) x?)) - #t)) \ No newline at end of file + #t) + + ) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/value-contract.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/value-contract.rkt index 1521a5d828..ef2ae39484 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/value-contract.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/value-contract.rkt @@ -1,45 +1,29 @@ #lang racket/base (require "test-util.rkt") -(parameterize ([current-contract-namespace - (make-basic-contract-namespace 'racket/unit 'racket/class 'racket/contract)]) + +(parameterize ([current-contract-namespace (make-basic-contract-namespace + 'racket/contract)]) - (ctest #f value-contract #f) - (ctest #f value-contract (λ (x) x)) - (ctest #f value-contract (unit (import) (export))) - (ctest #f value-contract object%) + (test/spec-passed/result + 'value-contract + '(let () + (define c (-> integer? integer?)) + (define f (contract c (λ (x) x) 'pos 'neg)) + ;; opt/c version doesn't yet have blame, so + ;; we require only that when there is blame, that the blame is right. + (or (and (has-contract? f) + (equal? c (value-contract f))) + #t)) + #t) - (contract-eval - `(let ([ctc (-> number? number?)]) - (,test ctc value-contract (contract ctc (λ (x) x) 'pos 'neg)))) - (contract-eval - `(let ([ctc (->* (number?) (number?) number?)]) - (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) - (contract-eval - `(let ([ctc (->d ([x number?]) ([y number?]) [_ number?])]) - (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) - (contract-eval - `(let ([ctc (->i ([x number?]) ([y number?]) [_ number?])]) - (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) - (contract-eval - `(let ([ctc (unconstrained-domain-> number?)]) - (,test ctc value-contract (contract ctc (λ (x) 3) 'pos 'neg)))) - (contract-eval - `(let ([ctc (case-> (-> number? number? number?) (-> number? number?))]) - (,test ctc value-contract (contract ctc (case-lambda [(x) 3] [(x y) (+ x y)]) 'pos 'neg)))) - - (contract-eval - `(let ([ctc (box/c number?)]) - (,test ctc value-contract (contract ctc (box 3) 'pos 'neg)))) - (contract-eval - `(let ([ctc (hash/c number? number?)]) - (,test ctc value-contract (contract ctc (make-hash) 'pos 'neg)))) - (contract-eval - `(let ([ctc (vectorof number?)]) - (,test ctc value-contract (contract ctc (vector 1 2 3) 'pos 'neg)))) - (contract-eval - `(let ([ctc (vector/c number? number?)]) - (,test ctc value-contract (contract ctc (vector 4 5) 'pos 'neg)))) - - (contract-eval - `(let ([ctc (object-contract)]) - (,test ctc value-contract (contract ctc (new object%) 'pos 'neg))))) + (test/spec-passed/result + 'value-blame + '(let () + (define f + (contract (-> integer? integer?) (λ (x) x) 'pos 'neg)) + ;; opt/c version doesn't yet have blame, so + ;; we require only that when there is blame, that the blame is right. + (or (and (has-blame? f) + (blame-positive (value-blame f))) + 'pos)) + 'pos)) diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index a43a0ee0d4..582a1db158 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -64,6 +64,8 @@ ;; from private/guts.rkt has-contract? value-contract + has-blame? + value-blame contract-continuation-mark-key ;; from private/case-arrow.rkt diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt index 20731ce97c..3a501882e5 100644 --- a/racket/collects/racket/contract/private/arr-i.rkt +++ b/racket/collects/racket/contract/private/arr-i.rkt @@ -733,7 +733,8 @@ (with-continuation-mark contract-continuation-mark-key blame (apply arg-checker args)))) - impersonator-prop:contracted ctc)))))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))))) (define-for-syntax (arg/res-to-indy-var indy-arg-vars ordered-args indy-res-vars ordered-ress var) (define (try vars ordered) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 10fc81a8f3..ac32d7bc17 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -356,11 +356,13 @@ (chaperone-or-impersonate-procedure val chap/imp-func - impersonator-prop:contracted ctc) + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)) (chaperone-or-impersonate-procedure val chap/imp-func impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party orig-blame neg-party) impersonator-prop:application-mark (cons arrow:contract-key ;; is this right? partial-ranges))))]) diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index ec04999814..b2c625ee45 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -31,6 +31,7 @@ contracted-function? contracted-function-proc contracted-function-ctc + contracted-function-blame make-contracted-function matches-arity-exactly? keywords-match @@ -53,9 +54,10 @@ (list id) null)) -(define-struct contracted-function (proc ctc) +(define-struct contracted-function (proc ctc blame) #:property prop:procedure 0 - #:property prop:contracted 1) + #:property prop:contracted 1 + #:property prop:blame 2) (define contract-key (gensym 'contract-key)) diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt index 954eb82cf8..6d176d30fc 100644 --- a/racket/collects/racket/contract/private/base.rkt +++ b/racket/collects/racket/contract/private/base.rkt @@ -84,7 +84,10 @@ ;; in arrow.rkt to make-contracted-function (make-contracted-function (procedure-rename (contracted-function-proc new-val) vs-name) - (contracted-function-ctc new-val))] + (contracted-function-ctc new-val) + (if cvfp + (blame-add-missing-party blame neg) + blame))] [else (procedure-rename new-val vs-name)])] [else new-val]))) diff --git a/racket/collects/racket/contract/private/blame.rkt b/racket/collects/racket/contract/private/blame.rkt index 3fc099075b..dae351cbd8 100644 --- a/racket/collects/racket/contract/private/blame.rkt +++ b/racket/collects/racket/contract/private/blame.rkt @@ -15,7 +15,7 @@ blame-update ;; used for option contract transfers blame-add-context blame-add-unknown-context - blame-context + blame-context blame-add-missing-party diff --git a/racket/collects/racket/contract/private/box.rkt b/racket/collects/racket/contract/private/box.rkt index 1204365707..19afee9343 100644 --- a/racket/collects/racket/contract/private/box.rkt +++ b/racket/collects/racket/contract/private/box.rkt @@ -125,7 +125,8 @@ (box-wrapper val (λ (b v) (pos-elem-proj v)) (λ (b v) (neg-elem-proj v)) - impersonator-prop:contracted ctc)))))))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))))))) (define (ho-val-first-projection chaperone/impersonate-box) (λ (ctc) @@ -141,10 +142,12 @@ (if (and (immutable? val) (not (chaperone? val))) (λ (neg-party) (box-immutable ((pos-elem-proj (unbox val)) neg-party))) (λ (neg-party) - (chaperone/impersonate-box val - (λ (b v) ((pos-elem-proj v) neg-party)) - (λ (b v) ((neg-elem-proj v) neg-party)) - impersonator-prop:contracted ctc)))))))) + (chaperone/impersonate-box + val + (λ (b v) ((pos-elem-proj v) neg-party)) + (λ (b v) ((neg-elem-proj v) neg-party)) + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party))))))))) (define-struct (chaperone-box/c base-box/c) () #:property prop:custom-write custom-write-property-proc diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt index 06b6914671..1214f2d1ff 100644 --- a/racket/collects/racket/contract/private/case-arrow.rkt +++ b/racket/collects/racket/contract/private/case-arrow.rkt @@ -155,11 +155,13 @@ f checker impersonator-prop:contracted ctc + impersonator-prop:blame blame impersonator-prop:application-mark (cons contract-key same-rngs)) (wrapper f checker - impersonator-prop:contracted ctc))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame))) (define (raise-no-keywords-error f blame) (λ (kwds kwd-args . args) diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index 01bdbf6ba2..6b7aa16a4e 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -24,10 +24,10 @@ contract-first-order contract-first-order-passes? - prop:contracted - impersonator-prop:contracted - has-contract? - value-contract + prop:contracted prop:blame + impersonator-prop:contracted impersonator-prop:blame + has-contract? value-contract + has-blame? value-blame ;; for opters check-flat-contract @@ -70,6 +70,18 @@ (get-impersonator-prop:contracted v)] [else #f])) +(define (has-blame? v) + (or (has-prop:blame? v) + (has-impersonator-prop:blame? v))) + +(define (value-blame v) + (cond + [(has-prop:blame? v) + (get-prop:blame v)] + [(has-impersonator-prop:blame? v) + (get-impersonator-prop:blame v)] + [else #f])) + (define-values (prop:contracted has-prop:contracted? get-prop:contracted) (let-values ([(prop pred get) (make-struct-type-property @@ -81,9 +93,27 @@ (lambda (s) v))))]) (values prop pred (λ (v) ((get v) v))))) -(define-values (impersonator-prop:contracted has-impersonator-prop:contracted? get-impersonator-prop:contracted) +(define-values (prop:blame has-prop:blame? get-prop:blame) + (let-values ([(prop pred get) + (make-struct-type-property + 'prop:blame + (lambda (v si) + (if (number? v) + (let ([ref (cadddr si)]) + (lambda (s) (ref s v))) + (lambda (s) v))))]) + (values prop pred (λ (v) ((get v) v))))) + +(define-values (impersonator-prop:contracted + has-impersonator-prop:contracted? + get-impersonator-prop:contracted) (make-impersonator-property 'impersonator-prop:contracted)) +(define-values (impersonator-prop:blame + has-impersonator-prop:blame? + get-impersonator-prop:blame) + (make-impersonator-property 'impersonator-prop:blame)) + (define (contract-first-order c) (contract-struct-first-order (coerce-contract 'contract-first-order c))) diff --git a/racket/collects/racket/contract/private/hash.rkt b/racket/collects/racket/contract/private/hash.rkt index f3c9151cad..a5b3a53502 100644 --- a/racket/collects/racket/contract/private/hash.rkt +++ b/racket/collects/racket/contract/private/hash.rkt @@ -192,7 +192,8 @@ (neg-dom-proj k)) (λ (h k) (pos-dom-proj k)) - impersonator-prop:contracted ctc))))))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame))))))) (define-struct (chaperone-hash/c base-hash/c) () #:omit-define-syntaxes diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 07201b0ef8..849ca7e429 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -1130,7 +1130,8 @@ (contract-name ctc) val)) (proxy val proj1 proj2 call/cc-guard call/cc-proxy - impersonator-prop:contracted ctc)))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))) (define ((prompt-tag/c-val-first-proj chaperone?) ctc) (define proxy (if chaperone? chaperone-prompt-tag impersonate-prompt-tag)) @@ -1169,7 +1170,8 @@ (proxy val proj1 proj2 call/cc-guard call/cc-proxy - impersonator-prop:contracted ctc))] + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party)))] [else (λ (neg-party) (raise-blame-error @@ -1238,7 +1240,8 @@ (contract-name ctc) val)) (proxy val proj1 proj2 - impersonator-prop:contracted ctc)))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))) (define ((continuation-mark-key/c-val-first-proj proxy) ctc) (define ho-proj @@ -1254,7 +1257,8 @@ (proxy val (λ (v) ((proj1 v) neg-party)) (λ (v) ((proj2 v) neg-party)) - impersonator-prop:contracted ctc))] + impersonator-prop:contracted ctc + impersonator-prop:blame blame))] [else (λ (neg-party) (unless (contract-first-order-passes? ctc val) @@ -1390,7 +1394,8 @@ (contract-name ctc) val)) (proxy val proj1 proj2 - impersonator-prop:contracted ctc)))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))) (define ((channel/c-val-first-proj proxy) ctc) (define ho-proj @@ -1407,7 +1412,8 @@ (proxy val (proj1 neg-party) (proj2 neg-party) - impersonator-prop:contracted ctc))] + impersonator-prop:contracted ctc + impersonator-prop:blame blame))] [else (λ (neg-party) (raise-blame-error diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index eb41878f4f..3920d922b4 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -177,7 +177,8 @@ val (checked-ref neg-party) (checked-set neg-party) - impersonator-prop:contracted ctc)))))))) + impersonator-prop:contracted ctc + impersonator-prop:blame (blame-add-missing-party blame neg-party))))))))) (define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get) (make-impersonator-property 'prop:neg-blame-party)) @@ -212,7 +213,8 @@ val checked-ref checked-set - impersonator-prop:contracted ctc)))))))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))))))) (define-struct (chaperone-vectorof base-vectorof) () #:property prop:custom-write custom-write-property-proc @@ -374,7 +376,8 @@ (with-continuation-mark contract-continuation-mark-key blame ((vector-ref elem-neg-projs i) val))) - impersonator-prop:contracted ctc)))))))) + impersonator-prop:contracted ctc + impersonator-prop:blame blame)))))))) (define-struct (chaperone-vector/c base-vector/c) () #:property prop:chaperone-contract