Exports from scheme/contract/private/blame: removed constructor; fixed confusing selector names.

svn: r17909

collects/drscheme/private/debug.ss

@@ -337,7 +337,7 @@ profile todo:
   (define (print-planet-icon-to-stderr exn)
     (when (exn:fail:contract:blame? exn)
       (let ([table (parse-gp exn
-                             (blame-guilty
+                             (blame-positive
                               (exn:fail:contract:blame-object exn)))])
         (when table
           (let ([gp-url (bug-info->ticket-url table)])

collects/mzlib/private/unit-contract.ss

@@ -39,9 +39,9 @@
                                                                  var)])
                                    #`(let ([old-v/c (#,vref)])
                                        (contract sig-ctc-stx (car old-v/c)
-                                                 (cdr old-v/c) (blame-guilty #,blame-id)
+                                                 (cdr old-v/c) (blame-positive #,blame-id)
                                                  (quote #,var) (quote-syntax #,var)))))
-                              (blame-innocent #,blame-id))
+                              (blame-negative #,blame-id))
                       (wrap-with-proj ctc #`(#,vref))))
             vref)))
     (for ([tagged-info (in-list import-tagged-infos)]
@@ -53,7 +53,7 @@
                                                #`(vector-ref #,v #,index)))))
     (with-syntax ((((eloc ...) ...)
                    (for/list ([target-sig import-sigs])
-                     (let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-guilty #,blame-id))])
+                     (let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-positive #,blame-id))])
                        (for/list ([target-int/ext-name (in-list (car target-sig))]
                                   [sig-ctc (in-list (cadddr target-sig))])
                          (let* ([var (car target-int/ext-name)]

collects/scheme/contract/private/base.ss

@@ -55,7 +55,7 @@ improve method arity mismatch contract violation error messages?
   (let* ([c (coerce-contract 'contract c)])
     (check-source-location! 'contract loc)
     (((contract-projection c)
-      (make-blame loc name (contract-name c) pos neg #f))
+      (make-blame loc name (contract-name c) pos neg #t))
      v)))
 
 (define-syntax (recursive-contract stx)

collects/scheme/contract/private/blame.ss

@@ -5,10 +5,11 @@
 (provide blame?
          make-blame
          blame-source
-         blame-guilty
+         blame-positive
-         blame-innocent
+         blame-negative
          blame-contract
          blame-value
+         blame-original?
          blame-swapped?
          blame-swap
 
@@ -17,38 +18,35 @@
          (struct-out exn:fail:contract:blame))
 
 (define (blame=? a b equal?/recur)
-  (and (equal?/recur (blame-guilty a) (blame-guilty b))
+  (and (equal?/recur (blame-positive a) (blame-positive b))
-       (equal?/recur (blame-innocent a) (blame-innocent b))
+       (equal?/recur (blame-negative a) (blame-negative b))
        (equal?/recur (blame-contract a) (blame-contract b))
        (equal?/recur (blame-value a) (blame-value b))
        (equal?/recur (blame-source a) (blame-source b))
-       (equal?/recur (blame-swapped? a) (blame-swapped? b))))
+       (equal?/recur (blame-original? a) (blame-original? b))))
 
 (define (blame-hash b hash/recur)
-  (bitwise-xor (hash/recur (blame-guilty b))
+  (bitwise-xor (hash/recur (blame-positive b))
-               (hash/recur (blame-innocent b))
+               (hash/recur (blame-negative b))
                (hash/recur (blame-contract b))
                (hash/recur (blame-value b))
                (hash/recur (blame-source b))
-               (hash/recur (blame-swapped? b))))
+               (hash/recur (blame-original? b))))
 
 (define-struct blame
-  [source value contract positive negative swapped?]
+  [source value contract positive negative original?]
   #:property prop:equal+hash
   (list blame=? blame-hash blame-hash))
 
-(define (blame-guilty b)
-  (if (blame-swapped? b)
-    (blame-negative b)
-    (blame-positive b)))
-
-(define (blame-innocent b)
-  (if (blame-swapped? b)
-    (blame-positive b)
-    (blame-negative b)))
-
 (define (blame-swap b)
-  (struct-copy blame b [swapped? (not (blame-swapped? b))]))
+  (struct-copy
+   blame b
+   [original? (not (blame-original? b))]
+   [positive (blame-negative b)]
+   [negative (blame-positive b)]))
+
+(define (blame-swapped? b)
+  (not (blame-original? b)))
 
 (define-struct (exn:fail:contract:blame exn:fail:contract) [object]
   #:transparent)
@@ -62,14 +60,14 @@
 
 (define (default-blame-format b x custom-message)
   (let* ([source-message (source-location->prefix (blame-source b))]
-         [guilty-message (show/display (blame-guilty b))]
+         [positive-message (show/display (blame-positive b))]
          [contract-message (show/write (blame-contract b))]
          [value-message (if (blame-value b)
                           (format " on ~a" (show/display (blame-value b)))
                           "")])
     (format "~a~a broke the contract ~a~a; ~a"
             source-message
-            guilty-message
+            positive-message
             contract-message
             value-message
             custom-message)))

collects/scheme/contract/private/legacy.ss

@@ -23,7 +23,7 @@
                      name
                      (unpack-blame pos)
                      "<<unknown party>>"
-                     #f)
+                     #t)
          x
          fmt
          args))
@@ -36,15 +36,15 @@
    (cond
     [(procedure-arity-includes? proj 5)
      (lambda (blame)
-       (proj (blame-guilty blame)
+       (proj (blame-positive blame)
-             (blame-innocent blame)
+             (blame-negative blame)
              (list (blame-source blame) (blame-value blame))
              (blame-contract blame)
              (not (blame-swapped? blame))))]
     [(procedure-arity-includes? proj 4)
      (lambda (blame)
-       (proj (blame-guilty blame)
+       (proj (blame-positive blame)
-             (blame-innocent blame)
+             (blame-negative blame)
              (list (blame-source blame) (blame-value blame))
              (blame-contract blame)))]
     [else
@@ -60,7 +60,7 @@
                         name
                         (unpack-blame (if original? pos neg))
                         (unpack-blame (if original? neg pos))
-                        (not original?))))))
+                        original?)))))
 
 (define (legacy-property name)
   (define-values [ prop pred get ]

collects/scheme/contract/private/object.ss

@@ -18,9 +18,9 @@
 (let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))]
        [cf (-> integer? integer?)]
        [m-proj ((contract-projection cm)
-                (make-blame #'here #f "whatever" 'pos 'neg #f))]
+                (make-blame #'here #f "whatever" 'pos 'neg #t))]
        [f-proj ((contract-projection cf)
-                (make-blame #'here #f "whatever" 'pos 'neg #f))]
+                (make-blame #'here #f "whatever" 'pos 'neg #t))]
        [cls (make-wrapper-class 'wrapper-class
                                 '(m)
                                 (list 

collects/tests/mzscheme/contract-mzlib-test.ss

@@ -5126,7 +5126,7 @@ so that propagation occurs.
   (contract-eval
    `(,test
      'pos
-     (compose blame-guilty exn:fail:contract:blame-object)
+     (compose blame-positive exn:fail:contract:blame-object)
      (with-handlers ((void values)) (contract not #t 'pos 'neg))))
   
   (report-errs)

collects/tests/mzscheme/contract-test.ss

@@ -7158,7 +7158,7 @@ so that propagation occurs.
   (contract-eval
    `(,test
      'pos
-     (compose blame-guilty exn:fail:contract:blame-object)
+     (compose blame-positive exn:fail:contract:blame-object)
      (with-handlers ((void values)) (contract not #t 'pos 'neg))))
 
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;