From 722fae41a8e5e74a053336ab6e5bc32f3487870d Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Tue, 19 Jan 2010 03:42:45 +0000
Subject: [PATCH] Ported more code to new contract tools.

svn: r17733
---
 collects/drscheme/private/debug.ss        |  6 ++++--
 collects/drscheme/private/tools.ss        |  4 +++-
 collects/mzlib/private/contract-arrow.ss  |  2 +-
 collects/mzlib/private/contract-define.ss | 14 +++++++++-----
 collects/syntax/private/stxparse/lib.ss   | 10 ++++++----
 5 files changed, 23 insertions(+), 13 deletions(-)

diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss
index 7cd39c5ca3..18a44362d0 100644
--- a/collects/drscheme/private/debug.ss
+++ b/collects/drscheme/private/debug.ss
@@ -335,8 +335,10 @@ profile todo:
   
   ;; =User=
   (define (print-planet-icon-to-stderr exn)
-    (when (exn:fail:contract2? exn)
-      (let ([table (parse-gp exn (guilty-party exn))])
+    (when (exn:fail:contract:blame? exn)
+      (let ([table (parse-gp exn
+                             (blame-guilty
+                              (exn:fail:contract:blame-object exn)))])
         (when table
           (let ([gp-url (bug-info->ticket-url table)])
             (when planet-note%
diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss
index e446f0b925..433150ac3f 100644
--- a/collects/drscheme/private/tools.ss
+++ b/collects/drscheme/private/tools.ss
@@ -4,6 +4,7 @@
          scheme/list
          scheme/runtime-path
          scheme/contract
+         unstable/location
          setup/getinfo
          mred
          framework
@@ -326,7 +327,8 @@
                                                 name 
                                                 'drscheme 
                                                 tool-name
-                                                (quote-syntax name))]))
+                                                (quote name)
+                                                (quote-srcloc name))]))
                           name
                           ctc)
                 body)]
diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss
index 0a9a658273..4eb6f11dfd 100644
--- a/collects/mzlib/private/contract-arrow.ss
+++ b/collects/mzlib/private/contract-arrow.ss
@@ -33,7 +33,7 @@
            (let ([proj-x (contract-projection rngs-x)] ...)
              (simple-contract
               #:name
-              (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
+              (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
               #:projection
               (λ (blame)
                 (let ([p-app-x (proj-x blame)] ...)
diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss
index 9bc54bd3a7..df8215baa0 100644
--- a/collects/mzlib/private/contract-define.ss
+++ b/collects/mzlib/private/contract-define.ss
@@ -2,9 +2,11 @@
 
 (provide define/contract)
 
-(require (for-syntax scheme/base)
+(require (for-syntax scheme/base
+                     unstable/srcloc
+                     (prefix-in a: scheme/contract/private/helpers))
          (only-in scheme/contract contract)
-         (for-syntax (prefix-in a: scheme/contract/private/helpers)))
+         unstable/location)
 
 ;; First, we have the old define/contract implementation, which
 ;; is still used in mzlib/contract.
@@ -12,7 +14,7 @@
 (define-for-syntax (make-define/contract-transformer contract-id id)
   (make-set!-transformer
    (λ (stx)
-     (with-syntax ([neg-blame-str (a:build-src-loc-string stx)]
+     (with-syntax ([neg-blame-str (source-location->string stx)]
                    [contract-id contract-id]
                    [id id])
        (syntax-case stx (set!)
@@ -27,7 +29,8 @@
                        id
                        (syntax->datum (quote-syntax f))
                        neg-blame-str
-                       (quote-syntax f))
+                       (quote f)
+                       (quote-srcloc f))
              arg
              ...))]
          [ident
@@ -37,7 +40,8 @@
                       id
                       (syntax->datum (quote-syntax ident))
                       neg-blame-str
-                      (quote-syntax ident)))])))))
+                      (quote ident)
+                      (quote-srcloc ident)))])))))
 
 ;; (define/contract id contract expr)
 ;; defines `id' with `contract'; initially binding
diff --git a/collects/syntax/private/stxparse/lib.ss b/collects/syntax/private/stxparse/lib.ss
index ac911fd58d..83b580e158 100644
--- a/collects/syntax/private/stxparse/lib.ss
+++ b/collects/syntax/private/stxparse/lib.ss
@@ -5,7 +5,8 @@
          syntax/stx
          syntax/kerncase
          scheme/struct-info
-         scheme/contract/private/helpers
+         unstable/srcloc
+         unstable/location
          (for-syntax scheme/base
                      syntax/kerncase
                      "rep.ss"
@@ -110,9 +111,10 @@
   (pattern x:expr
            #:with c #`(contract #,ctc
                                 x
-                                (quote #,(string->symbol (or (build-src-loc-string #'x) "")))
-                                (quote #,(or '<this-macro>))
-                                (quote-syntax #,(syntax/loc #'x (<there>))))))
+                                (quote #,(source-location->string #'x))
+                                '<this-macro>
+                                #f
+                                (quote-srcloc x))))
 
 ;; Literal sets