From 019c2c8c34080bccb46889f6c59879ffbe7004ef Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 12 Sep 2008 18:49:08 +0000
Subject: [PATCH] Handle strings as blame, now add a description of the type of
 contract boundary that triggered the contract error.

svn: r11695
---
 collects/scheme/private/contract-guts.ss |  5 ++--
 collects/scheme/private/contract.ss      | 37 ++++++++++++++++--------
 2 files changed, 28 insertions(+), 14 deletions(-)

diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss
index 522a87e254..9a6f5d0f42 100644
--- a/collects/scheme/private/contract-guts.ss
+++ b/collects/scheme/private/contract-guts.ss
@@ -204,8 +204,9 @@
                                    (pair? (cdr to-blame))
                                    (null? (cddr to-blame))
                                    (equal? 'quote (car to-blame)))
-                              (format "'~s" (cadr to-blame))]
-                             [else (format "~s" to-blame)])
+                              (format "module '~s" (cadr to-blame))]
+                             [(string? to-blame) to-blame]
+                             [else (format "module ~s" to-blame)])
                            formatted-contract-sexp
                            specific-blame)
                    msg)))
diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index 51f769ae63..b932ac25a6 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -90,7 +90,7 @@ improve method arity mismatch contract violation error messages?
                          define-stx)]
     [(_ name contract-expr expr)
      (identifier? (syntax name))
-     #'(with-contract name
+     #'(with-contract #:type function name
          ([name (verify-contract 'define/contract contract-expr)])
          (define name expr))]
     [(_ name contract-expr expr0 expr ...)
@@ -132,7 +132,7 @@ improve method arity mismatch contract violation error messages?
   (make-set!-transformer
    (lambda (stx)
      (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
-                                     (a:module-source-as-symbol id))]
+                                     #`(quote #,(a:module-source-as-symbol id)))]
                    [pos-blame-id pos-blame-id]
                    [contract-id contract-id]
                    [id id])
@@ -147,7 +147,7 @@ improve method arity mismatch contract violation error messages?
             ((-contract contract-id
                         id
                         pos-blame-id
-                        'neg-blame-id
+                        neg-blame-id
                         #'f)
              arg ...))]
          [ident
@@ -156,7 +156,7 @@ improve method arity mismatch contract violation error messages?
             (-contract contract-id
                        id
                        pos-blame-id
-                       'neg-blame-id
+                       neg-blame-id
                        #'ident))])))))
 
 (define-for-syntax (check-and-split-with-contract-args args)
@@ -194,8 +194,9 @@ improve method arity mismatch contract violation error messages?
                         "used in expression context"
                         stx))
   (syntax-case stx ()
-    [(_ blame (arg ...) body0 body ...)
-     (identifier? (syntax blame))
+    [(_ #:type type blame (arg ...) body0 body ...)
+     (and (identifier? #'blame)
+          (identifier? #'type))
      (let-values ([(unprotected protected protections)
                    (check-and-split-with-contract-args (syntax->list #'(arg ...)))])
        (with-syntax ([((protected-id id contract-id) ...)
@@ -204,12 +205,13 @@ improve method arity mismatch contract violation error messages?
                                    (a:mangle-id stx "with-contract-id" n)
                                    (a:mangle-id stx "with-contract-contract-id" n)))
                            protected)]
+                     [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))]
                      [(contract-expr ...) protections]
                      [(unprotected-id ...) unprotected])
          (syntax/loc stx
            (begin 
              (define-values (unprotected-id ... id ...)
-               (syntax-parameterize ([current-contract-region (quote blame)])
+               (syntax-parameterize ([current-contract-region blame-str])
                  (begin-with-definitions
                    body0 body ...
                    (values unprotected-id ... protected-id ...))))
@@ -218,19 +220,30 @@ improve method arity mismatch contract violation error messages?
                (make-with-contract-transformer 
                 (quote-syntax contract-id)
                 (quote-syntax id)
-                (quote-syntax (quote blame)))) ...))))]
-    [(_ blame (arg ...) body0 body ...)
+                blame-str)) ...))))]
+    [(_ #:type type blame (arg ...) body0 body ...)
+     (identifier? #'blame)
      (raise-syntax-error 'with-contract
-                         "expected identifier"
+                         "expected identifier for type"
+                         #'type)]
+    [(_ #:type type blame (arg ...) body0 body ...)
+     (raise-syntax-error 'with-contract
+                         "expected identifier for blame"
                          #'blame)]
+    [(_ blame (arg ...) body0 body ...)
+     #'(with-contract #:type region blame (arg ...) body0 body ...)]
     [(_ blame (arg ...))
      (raise-syntax-error 'with-contract
                          "empty body"
                          stx)]
-    [(_ blame bad-args body0 body ...)
+    [(_ blame bad-args etc ...)
      (raise-syntax-error 'with-contract
                          "expected list of identifier and/or (identifier contract)"
-                         #'bad-args)]))
+                         #'bad-args)]
+    [(_ blame)
+     (raise-syntax-error 'with-contract
+                         "only blame"
+                         stx)]))
 
 ;                                                                                                            
 ;