add has-blame? and value-blame

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,10 +2644,21 @@ 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.

pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt

@@ -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)))
-

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))
+   #t)
+  
+  )

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)])
 
-  (ctest #f value-contract #f)
+(parameterize ([current-contract-namespace (make-basic-contract-namespace
-  (ctest #f value-contract (λ (x) x))
+                                            'racket/contract)])
-  (ctest #f value-contract (unit (import) (export)))
-  (ctest #f value-contract object%)
   
-  (contract-eval
+  (test/spec-passed/result
-   `(let ([ctc (-> number? number?)])
+   'value-contract
-      (,test ctc value-contract (contract ctc (λ (x) x) 'pos 'neg))))
+   '(let ()
-  (contract-eval
+      (define c (-> integer? integer?))
-   `(let ([ctc (->* (number?) (number?) number?)])
+      (define f (contract c (λ (x) x) 'pos 'neg))
-      (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))))
+      ;; opt/c version doesn't yet have blame, so 
-  (contract-eval
+      ;; we require only that when there is blame, that the blame is right.
-   `(let ([ctc (->d ([x number?]) ([y number?]) [_ number?])])
+      (or (and (has-contract? f)
-      (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))))
+               (equal? c (value-contract f)))
-  (contract-eval
+          #t))
-   `(let ([ctc (->i ([x number?]) ([y number?]) [_ number?])])
+   #t)
-      (,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
+  (test/spec-passed/result
-   `(let ([ctc (box/c number?)])
+   'value-blame
-      (,test ctc value-contract (contract ctc (box 3) 'pos 'neg))))
+   '(let ()
-  (contract-eval
+      (define f
-   `(let ([ctc (hash/c number? number?)])
+        (contract (-> integer? integer?) (λ (x) x) 'pos 'neg))
-      (,test ctc value-contract (contract ctc (make-hash) 'pos 'neg))))
+      ;; opt/c version doesn't yet have blame, so 
-  (contract-eval
+      ;; we require only that when there is blame, that the blame is right.
-   `(let ([ctc (vectorof number?)])
+      (or (and (has-blame? f)
-      (,test ctc value-contract (contract ctc (vector 1 2 3) 'pos 'neg))))
+               (blame-positive (value-blame f)))
-  (contract-eval
+          'pos))
-   `(let ([ctc (vector/c number? number?)])
+   'pos))
-      (,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)))))

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

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)

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))))])

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))
 

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])))

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
+                  (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: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

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)

racket/collects/racket/contract/private/guts.rkt

@@ -24,10 +24,10 @@
          contract-first-order
          contract-first-order-passes?
          
-         prop:contracted
+         prop:contracted prop:blame
-         impersonator-prop:contracted
+         impersonator-prop:contracted impersonator-prop:blame
-         has-contract?
+         has-contract? value-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)))

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

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

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