diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl index 66a9a30d98..fa0b5b03cf 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -2708,6 +2708,12 @@ Produces the name used to describe the contract in error messages. @history[#:added "6.0.1.12"] } +@defproc[(value-contracts-and-blame [v any/c]) (listof (list/c blame? contract?))]{ + Returns the contracts and associated blame that are attached to @racket[v]. + + @history[#:added "6.1.0.8"] +} + @defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{ Produces the projection defining a contract's behavior on protected values. } diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt index 52f579cfe9..9c593cd9e9 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt @@ -2471,6 +2471,41 @@ (chaperone-of? c+c% c%)) #t) + (test/spec-passed/result + 'lots-of-wrapping + '(let () + (define state/c + (recursive-contract + (class/c + [m (-> any/c (instanceof/c state/c))] + [n (-> any/c (instanceof/c state/c))]))) + + (define state% + (class object% + (super-new) + (define/public (m) (send this n)) + (define/public (n) (new state%)))) + + (define tree-next + (contract + (-> (instanceof/c state/c) (instanceof/c state/c)) + (λ (o) (send o m)) + 'pos 'neg)) + (define make-tree + (contract + (-> (instanceof/c state/c)) + (λ () (new state%)) + 'pos + 'neg)) + + (define o1 (make-tree)) + (define o2 (tree-next o1)) + (define o3 (tree-next o2)) + (= (length (value-contracts-and-blames o2)) + (length (value-contracts-and-blames o3)))) + #t) + + (let ([expected-given? (λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn)) (regexp-match? #rx"expected: boolean[?]" (exn-message exn)) 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 e69625b28c..a9469f5c74 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 @@ -10,40 +10,73 @@ (ctest #f value-contract object%) (contract-eval + #:test-case-name 'value-contract1 `(let ([ctc (-> number? number?)]) - (,test ctc value-contract (contract ctc (λ (x) x) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract1 + ctc value-contract (contract ctc (λ (x) x) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract2 `(let ([ctc (->* (number?) (number?) number?)]) - (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract2 + ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract3 `(let ([ctc (->d ([x number?]) ([y number?]) [_ number?])]) - (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract3 + ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract4 `(let ([ctc (->i ([x number?]) ([y number?]) [_ number?])]) - (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract4 + ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract5 `(let ([ctc (unconstrained-domain-> number?)]) - (,test ctc value-contract (contract ctc (λ (x) 3) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract5 + ctc value-contract (contract ctc (λ (x) 3) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract6 `(let ([ctc (case-> (-> number? number? number?) (-> number? number?))]) - (,test ctc value-contract (contract ctc (case-lambda [(x) 3] [(x y) (+ x y)]) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract6 + ctc value-contract (contract ctc (case-lambda [(x) 3] [(x y) (+ x y)]) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract7 `(let ([ctc (box/c number?)]) - (,test ctc value-contract (contract ctc (box 3) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract7 + ctc value-contract (contract ctc (box 3) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract8 `(let ([ctc (hash/c number? number?)]) - (,test ctc value-contract (contract ctc (make-hash) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract8 + ctc value-contract (contract ctc (make-hash) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract9 `(let ([ctc (vectorof number?)]) - (,test ctc value-contract (contract ctc (vector 1 2 3) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract9 + ctc value-contract (contract ctc (vector 1 2 3) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract10 `(let ([ctc (vector/c number? number?)]) - (,test ctc value-contract (contract ctc (vector 4 5) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract10 + ctc value-contract (contract ctc (vector 4 5) 'pos 'neg)))) (contract-eval + #:test-case-name 'value-contract11 `(let ([ctc (object-contract)]) - (,test ctc value-contract (contract ctc (new object%) 'pos 'neg)))) + (,test + #:test-case-name 'value-contract11 + ctc value-contract (contract ctc (new object%) 'pos 'neg)))) (test/spec-passed/result 'value-contract