From 79955e1204c0e03a0a1a9acb5b20abf77ea89b5c Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 13 Apr 2013 18:30:22 -0500
Subject: [PATCH] fix the sense of the blame aspects of the blame object has a
 #:important

closes PR 13692
---
 collects/racket/contract/private/blame.rkt | 38 ++++++++++++++--------
 collects/tests/racket/contract-test.rktl   | 24 +++++++++++---
 2 files changed, 44 insertions(+), 18 deletions(-)

diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt
index 281094f426..3f64ee42b5 100644
--- a/collects/racket/contract/private/blame.rkt
+++ b/collects/racket/contract/private/blame.rkt
@@ -68,16 +68,19 @@
     make-blame))
 
 ;; s : (or/c string? #f)
-(define (blame-add-context b s #:important [important #f] #:swap? [swap? #f])
+(define (blame-add-context b s #:important [name #f] #:swap? [swap? #f])
+  (define new-original? (if swap? (not (blame-original? b)) (blame-original? b)))
   (struct-copy
    blame b
-   [original? (if swap? (not (blame-original? b)) (blame-original? b))]
+   [original? new-original?]
    [positive (if swap? (blame-negative b) (blame-positive b))]
    [negative (if swap? (blame-positive b) (blame-negative b))]
-   [important (or important (blame-important b))]
+   [important (if name (important name new-original?) (blame-important b))]
    [context (if s (cons s (blame-context b)) (blame-context b))]
    [top-known? #t]))
 
+(struct important (name sense-swapped?))
+
 (define (blame-add-unknown-context b)
   (define old (blame-context b))
   (struct-copy
@@ -157,17 +160,17 @@
           (define nxt
             (cond
               [(eq? 'given: fst) (add-indent
-                                  (if (blame-original? blame)
+                                  (if (blame/important-original? blame)
                                       "produced:"
                                       "given:"))]
-              [(eq? 'given fst) (if (blame-original? blame)
+              [(eq? 'given fst) (if (blame/important-original? blame)
                                     "produced"
                                     "given")]
               [(eq? 'expected: fst) (add-indent
-                                     (if (blame-original? blame)
+                                     (if (blame/important-original? blame)
                                          "promised:"
                                          "expected:"))]
-              [(eq? 'expected fst) (if (blame-original? blame)
+              [(eq? 'expected fst) (if (blame/important-original? blame)
                                        "promised"
                                        "expected")]
               [else fst]))
@@ -180,6 +183,12 @@
                 new-so-far
                 (regexp-match #rx" $" nxt))]))]))
 
+(define (blame/important-original? blame)
+  (define i (blame-important blame))
+  (cond
+    [i (important-sense-swapped? i)]
+    [else (blame-original? blame)]))
+
 (define (default-blame-format blme x custom-message)
   (define source-message (source-location->string (blame-source blme)))
   
@@ -198,18 +207,21 @@
                       #f
                       (format "  at: ~a" source-message)))
   
-  (define self-or-not (if (blame-original? blme)
-                          "broke its contract"
-                          "contract violation"))
+  (define (self-or-not which-way?) 
+    (if which-way?
+        "broke its contract"
+        "contract violation"))
   
   (define start-of-message
     (cond
       [(blame-important blme)
-       (format "~a: ~a" (blame-important blme) self-or-not)]
+       (format "~a: ~a" 
+               (important-name (blame-important blme))
+               (self-or-not (important-sense-swapped? (blame-important blme))))]
       [(blame-value blme)
-       (format "~a: ~a" (blame-value blme) self-or-not)]
+       (format "~a: ~a" (blame-value blme) (self-or-not (blame-original? blme)))]
       [else
-       (format "~a:" self-or-not)]))
+       (format "~a:" (self-or-not (blame-original? blme)))]))
   
   (define blame-parties (blame-positive blme))
   (define blaming-line
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index 0b56827415..75fea45b50 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -57,10 +57,10 @@
 
   (define (contract-syntax-error-test name exp [reg #rx""])
     (test #t
-	  name
-	  (contract-eval `(with-handlers ((exn:fail:syntax?
-					   (lambda (x) (and (regexp-match ,reg (exn-message x)) #t))))
-					 (eval ',exp)))))
+          name
+          (contract-eval `(with-handlers ((exn:fail:syntax?
+                                           (lambda (x) (and (regexp-match ,reg (exn-message x)) #t))))
+                            (eval ',exp)))))
 
   ;; test/spec-passed : symbol sexp -> void
   ;; tests a passing specification
@@ -155,7 +155,7 @@
       (define (has-proper-blame? msg)
         (define reg
           (cond
-            [(eq? blame 'pos) #rx"broke its contract[\n:,].*blaming: pos"]
+            [(eq? blame 'pos) #rx"blaming: pos"]
             [(eq? blame 'neg) #rx"blaming: neg"]
             [(string? blame) (string-append "blaming: " (regexp-quote blame))]
             [else #f]))
@@ -8741,6 +8741,20 @@
                           'pos
                           'neg)])
       (send (new cls%) m 3 #t)))
+  
+  (contract-error-test
+   'class/c-tl-message
+   '((contract (-> (class/c (callback (->m boolean? any)))
+                   any)
+               (λ (c%) (send (new c%) callback 1))
+               'pos 'neg)
+     (class object%
+       (super-new)
+       (define/public (callback x) 3)))
+   (λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
+                 (regexp-match? #rx"expected: boolean[?]" (exn-message exn))
+                 (regexp-match? #rx"given: 1" (exn-message exn)))))
+                 
 
 ;
 ;