From bb798b4ba57b0d819a819a429c5dbe4900010336 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Tue, 18 May 2010 18:45:34 -0400
Subject: [PATCH] Fixing the negative blame associated with provide/contracted
 identifiers.

The contract system now keeps track of three points of blame: the positive
blame, assigned to the provider of a contracted value; the negative blame,
assigned to the receiver of a contracted value; and the user "blame",
assigned to the party that actually misuses the value.  While the latter
is not really blame, as blame is not assigned to that party when that party
is not either the negative or positive party, it's useful information for
programmers when debugging.

For provide/contract, the negative party should be the first module to
require an identifier provided via provide/contract.  What was previously
the negative party is really the user, and is now handled as such.
---
 collects/racket/contract/private/provide.rkt | 38 ++++++++++++++------
 1 file changed, 28 insertions(+), 10 deletions(-)

diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt
index 32f8a16e6e..5286000780 100644
--- a/collects/racket/contract/private/provide.rkt
+++ b/collects/racket/contract/private/provide.rkt
@@ -38,6 +38,32 @@
                                      (current-inspector) #f '(0))])
     make-))
 
+(define (first-requiring-module id self)
+  (define (resolved-module-path->module-path rmp)
+    (cond
+      [(not rmp) 'top-level]
+      [(path? (resolved-module-path-name rmp))
+       `(file ,(path->string (resolved-module-path-name rmp)))]
+      [(symbol? (resolved-module-path-name rmp))
+       `(module ,(resolved-module-path-name rmp))]))  
+  ;; Here we get the module-path-index corresponding to the identifier.
+  ;; We know we can split it at least once, because the contracted identifier
+  ;; we've provided must have been required.  If the second returned value is #f,
+  ;; we just fall back on the old behavior.  If we split again without getting
+  ;; either "self", that is, the first value returned is not #f, then we should
+  ;; use the second mpi result as the module that required the value.
+  (let ([mpi (syntax-source-module id)])
+    (let*-values ([(first-mp second-mpi)
+                   (module-path-index-split mpi)]
+                  [(second-mp third-mpi)
+                   (if second-mpi
+                       (module-path-index-split second-mpi)
+                       (values #f #f))])
+      (if second-mp
+          (resolved-module-path->module-path
+           (module-path-index-resolve second-mpi))
+          self))))
+
 (define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
   (make-set!-transformer
    (let ([saved-id-table (make-hasheq)])
@@ -52,21 +78,13 @@
                         (with-syntax ([contract-id contract-id]
                                       [id id]
                                       [external-id external-id]
-                                      [pos-module-source pos-module-source]
-                                      [id-ref (syntax-case stx (set!)
-                                                [(set! whatever e)
-                                                 id] ;; just avoid an error here, signal the error later
-                                                [(id . x)
-                                                 #'id]
-                                                [id
-                                                 (identifier? #'id)
-                                                 #'id])])
+                                      [pos-module-source pos-module-source])
                           (syntax-local-introduce
                            (syntax-local-lift-expression
                             #`(contract contract-id
                                         id
                                         pos-module-source
-                                        (quote-module-path)
+                                        (first-requiring-module (quote-syntax id) (quote-module-path))
                                         'external-id
                                         (quote-srcloc id))))))])
                (when key