From df6590b80f960ef43551a8a0a339f0313d410ed1 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 2 Jul 2011 23:58:39 +0800
Subject: [PATCH] adjust contract violation message by putting the name at the
 start of the message. For example, this:

contract violation, expected <(or/c (quote clean) (quote armed) (quote tained))>, given: #f
  contract on wrapped from 'zo-structs, blaming 'no-dep
  contract:
     (->
        any/c
	(listof wrap?)
	(or/c 'clean 'armed 'tained)
	wrapped?)
  at: C:\tmp3.rkt:6.21

becomes this:

wrapped: contract violation, expected <(or/c (quote clean) (quote armed) (quote tained))>, given: #f
  contract from 'zo-structs, blaming 'no-dep
  contract:
     (->
        any/c
        (listof wrap?)
        (or/c 'clean 'armed 'tained)
        wrapped?)
  at: C:\tmp3.rkt:6.21

(apologies if the indenting isn't quite right above; vi messed with it when I tried to paste it in ...)
---
 collects/racket/contract/private/blame.rkt | 24 ++++++++++++----------
 collects/tests/racket/contract-test.rktl   | 14 ++++++-------
 2 files changed, 20 insertions(+), 18 deletions(-)

diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt
index a3a3e8fc2f..cc45546817 100644
--- a/collects/racket/contract/private/blame.rkt
+++ b/collects/racket/contract/private/blame.rkt
@@ -76,19 +76,18 @@
                                                  "\n"
                                                  (if (string=? source-message "")
                                                      ""
-                                                     (format "        at: ~a" source-message))))]
-                                                 
-         [value-message (if (blame-value b)
-                          (format " on ~a" (show/display (blame-value b)))
-                          "")])
+                                                     (format "        at: ~a" source-message))))])
     ;; use (regexp-match #rx"\n" ...) to find out if show/display decided that this
     ;; is a multiple-line message and adjust surrounding formatting accordingly
     (cond
       [(blame-original? b)
+       (define start-of-message
+         (if (blame-value b)
+             (format "~a: self-contract violation," (blame-value b))
+             "self-contract violation:"))
        (string-append
-        (format "self-contract violation: ~a\n" custom-message)
-        (format "  contract~a from ~a~a blaming ~a~a" 
-                value-message 
+        (format "~a ~a\n" start-of-message custom-message)
+        (format "  contract from ~a~a blaming ~a~a" 
                 positive-message
                 (if (regexp-match #rx"\n" positive-message)
                     " "
@@ -100,10 +99,13 @@
         contract-message+at)]
       [else
        (define negative-message (show/display (blame-negative b)))
+       (define start-of-message
+         (if (blame-value b)
+             (format "~a: contract violation," (blame-value b))
+             "contract violation:"))
        (string-append
-        (format "contract violation: ~a\n" custom-message)
-        (format "  contract~a from ~a~a blaming ~a~a" 
-                value-message
+        (format "~a ~a\n" start-of-message custom-message)
+        (format "  contract from ~a~a blaming ~a~a" 
                 negative-message 
                 (if (regexp-match #rx"\n" negative-message)
                     " "
diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl
index ac7973b131..6a3689c306 100644
--- a/collects/tests/racket/contract-test.rktl
+++ b/collects/tests/racket/contract-test.rktl
@@ -92,7 +92,7 @@
       (define (has-proper-blame? msg)
         (define reg
           (case blame
-            [(pos) #rx"^self-contract violation"]
+            [(pos) #rx"self-contract violation"]
             [(neg) #rx"blaming neg"]
             [else (error 'test/spec-failed "unknown blame name ~s" blame)]))
         (regexp-match? reg msg))
@@ -11345,7 +11345,7 @@ so that propagation occurs.
        (eval '(require 'pce1-bug)))
    (λ (x)
      (and (exn? x)
-          (regexp-match #rx"on the-defined-variable1" (exn-message x)))))
+          (regexp-match #rx"the-defined-variable1: self-contract violation" (exn-message x)))))
   
   (contract-error-test
    #'(begin
@@ -11357,7 +11357,7 @@ so that propagation occurs.
        (eval '(the-defined-variable2 #f)))
    (λ (x)
      (and (exn? x)
-          (regexp-match #rx"on the-defined-variable2" (exn-message x)))))
+          (regexp-match #rx"the-defined-variable2: contract violation" (exn-message x)))))
   
   (contract-error-test
    #'(begin
@@ -11369,7 +11369,7 @@ so that propagation occurs.
        (eval '(the-defined-variable3 #f)))
    (λ (x)
      (and (exn? x)
-          (regexp-match #rx"on the-defined-variable3" (exn-message x)))))
+          (regexp-match #rx"the-defined-variable3" (exn-message x)))))
   
   (contract-error-test
    #'(begin
@@ -11381,7 +11381,7 @@ so that propagation occurs.
        (eval '((if #t the-defined-variable4 the-defined-variable4) #f)))
    (λ (x)
      (and (exn? x)
-          (regexp-match #rx"on the-defined-variable4" (exn-message x)))))
+          (regexp-match #rx"^the-defined-variable4" (exn-message x)))))
 
   (contract-error-test
    #'(begin
@@ -11447,7 +11447,7 @@ so that propagation occurs.
        (eval '(g 12)))
    (λ (x)
      (and (exn? x)
-          (regexp-match #rx"contract on g from 'pce9-bug" (exn-message x)))))
+          (regexp-match #rx"^g.*contract from 'pce9-bug" (exn-message x)))))
   
   (contract-error-test
    #'(begin
@@ -11460,7 +11460,7 @@ so that propagation occurs.
        (eval '(g 'a)))
    (λ (x)
      (and (exn? x)
-          (regexp-match #rx"contract on g from 'pce10-bug" (exn-message x)))))
+          (regexp-match #rx"^g.*contract from 'pce10-bug" (exn-message x)))))
    
   (contract-eval
    `(,test