From 19ff5722d502af85399618fe1b31b01784a96fad Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 14 Aug 2012 21:14:22 -0500
Subject: [PATCH] improve the error message for cases where there is a
 substruct of a struct that got a contract via provide/contract, and the
 subconstructor gets a value that wouldn't have satisfied the original
 struct's contract

related to PR 12966
---
 collects/racket/contract/private/provide.rkt | 79 ++++++++------------
 1 file changed, 31 insertions(+), 48 deletions(-)

diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt
index ccd93dfb13..70659e2214 100644
--- a/collects/racket/contract/private/provide.rkt
+++ b/collects/racket/contract/private/provide.rkt
@@ -458,7 +458,6 @@
                           names
                           (cdr selector-strs)
                           (cdr field-names)))])))
-           
            (with-syntax ([((selector-codes selector-new-names) ...)
                           (filter
                            (λ (x) x)
@@ -570,7 +569,13 @@
                                [-struct:struct-name -struct:struct-name]
                                [struct-name struct-name]
                                [(selector-ids ...) selector-ids]
-                               [(constructor-args ...) (generate-temporaries selector-ids)])
+                               [(constructor-args ...) (generate-temporaries selector-ids)]
+                               [struct-name-srcloc `'(,(path->relative-string/library
+                                                        (syntax-source struct-name))
+                                                      ,(syntax-line struct-name)
+                                                      ,(syntax-column struct-name)
+                                                      ,(syntax-position struct-name)
+                                                      ,(syntax-span struct-name))])
                    (quasisyntax/loc stx
                      (begin
                        struct-code
@@ -589,7 +594,10 @@
                        ;; directly here in the expansion makes this very expensive at compile time
                        ;; when there are a lot of provide/contract clause using structs
                        (define -struct:struct-name 
-                         (make-pc-struct-type 'struct-name struct:struct-name field-contract-ids ...))
+                         (make-pc-struct-type 'struct-name
+                                              struct-name-srcloc
+                                              struct:struct-name
+                                              field-contract-ids ...))
                        (provide (rename-out [-struct:struct-name struct:struct-name]))))))))))
        
        (define (map/count f . ls)
@@ -830,53 +838,28 @@
                                     s-l-c))
                         stx)]))
 
-(define (make-pc-struct-type struct-name struct:struct-name . ctcs)
+(define (make-pc-struct-type struct-name srcloc struct:struct-name . ctcs)
   (chaperone-struct-type
    struct:struct-name
    (λ (a b c d e f g h) (values a b c d e f g h))
    (λ (x) x)
    (λ args
-     (let ([vals (let loop ([args args])
-                   (cond
-                     [(null? args) null]
-                     [(null? (cdr args)) null]
-                     [else (cons (car args) (loop (cdr args)))]))])
-       (apply values
-              (map (λ (ctc val)
-                     (contract ctc
-                               val
-                               'not-enough-info-for-blame
-                               'not-enough-info-for-blame
-                               '#f
-                               (build-source-location #f)))
-                   ctcs
-                   vals)))))
-  
-  #;
-  (let-values ([(struct:struct-name _make _pred _get _set)
-                (make-struct-type struct-name
-                                  struct:struct-name
-                                  0 ;; init
-                                  0 ;; auto
-                                  #f  ;; auto-v
-                                  '() ;; props
-                                  #f  ;; inspector
-                                  #f ;; proc-spec
-                                  '()  ;; immutable-k-list
-                                  (λ args
-                                    (let ([vals (let loop ([args args])
-                                                  (cond
-                                                    [(null? args) null]
-                                                    [(null? (cdr args)) null]
-                                                    [else (cons (car args) (loop (cdr args)))]))])
-                                      (apply values
-                                             (map (λ (ctc val)
-                                                    (contract ctc
-                                                              val
-                                                              'not-enough-info-for-blame
-                                                              'not-enough-info-for-blame
-                                                              '#f
-                                                              (build-source-location #f)))
-                                                  ctcs
-                                                  vals)))))])
-    (values struct:struct-name _make)))
+     (define name #f)
+     (define vals 
+       (let loop ([args args])
+         (cond
+           [(null? args) null]
+           [(null? (cdr args))
+            (set! name (car args))
+            null]
+           [else (cons (car args) (loop (cdr args)))])))
+     (apply values
+            (map (λ (ctc val)
+                   (contract ctc
+                             val
+                             'not-enough-info-for-blame
+                             'not-enough-info-for-blame
+                             name
+                             srcloc))
+                 ctcs
+                 vals)))))