add has-blame? and value-blame

2014-06-13 08:27:56 -05:00 · 2014-06-13 08:27:56 -05:00 · 0a0c62a1e6
commit 0a0c62a1e6
parent 56801372f0
16 changed files with 137 additions and 76 deletions
--- 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?]{
--- 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
@ -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)))
-
--- 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))
+   #t)
+  
+  )
--- 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)])

-  (ctest #f value-contract #f)
-  (ctest #f value-contract (λ (x) x))
-  (ctest #f value-contract (unit (import) (export)))
-  (ctest #f value-contract object%)
+(parameterize ([current-contract-namespace (make-basic-contract-namespace
+                                            'racket/contract)])
  
-  (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))))
+  (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 (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))
--- 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
--- 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)
--- 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))))])
--- 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))

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