From cd004fd9cec127cf0e409e824c8b0194983b1cee Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 19 Sep 2013 23:48:22 -0400
Subject: [PATCH] Improve error message for misuse of type names

Closes PR 13289
---
 .../typed-racket/base-env/base-types-extra.rkt         |  7 +++++--
 .../typed-racket/base-env/extra-procs.rkt              |  2 +-
 .../typed-racket-lib/typed-racket/base-env/prims.rkt   |  8 +++++++-
 .../typed-racket/base-env/type-env-lang.rkt            |  6 ++++--
 .../tests/typed-racket/fail/pr13289.rkt                | 10 ++++++++++
 5 files changed, 27 insertions(+), 6 deletions(-)
 create mode 100644 pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/pr13289.rkt

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt
index c5149fb684..06f4b32f97 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt
@@ -1,13 +1,16 @@
 #lang racket/base
 
-(require (for-syntax racket/base))
+(require (for-syntax racket/base syntax/stx))
 
 (define-syntax (define-other-types stx)
   (syntax-case stx ()
     [(_ nm ...)
      #'(begin (define-syntax nm
                 (lambda (stx)
-                  (raise-syntax-error 'type-check "type name used out of context" stx))) ...
+                  (raise-syntax-error 'type-check "type name used out of context"
+                                      stx
+                                      (and (stx-pair? stx) (stx-car stx)))))
+              ...
               (provide nm) ...)]))
 
 ;; special type names that are not bound to particular types
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-procs.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-procs.rkt
index db86917f2b..d86fffc90a 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-procs.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/extra-procs.rkt
@@ -7,7 +7,7 @@
      (or v (error (format "Assertion failed on ~v" v))))
     ((assert v pred)
      (let ((val v))
-       (if (pred val)
+       (if ((#%expression pred) val)
            val
            (error (format "Assertion ~a failed on ~v" pred val)))))))
 
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
index dac67f54f1..e85c993ca3 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
@@ -499,7 +499,13 @@ This file defines two sorts of primitives. All of them are provided into any mod
                                  ([omit #f])))
      #`(begin
          #,(if (not (attribute omit))
-               (ignore #'(define-syntax tname (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))))
+               (ignore #'(define-syntax tname
+                           (lambda (stx)
+                             (raise-syntax-error
+                              'type-check
+                              "type name used out of context"
+                              stx
+                              (and (stx-pair? stx) (stx-car stx))))))
                #'(begin))
          #,(internal (syntax/loc stx (define-type-alias-internal tname rest))))]
     [(_ (tname:id args:id ...) rest)
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/type-env-lang.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/type-env-lang.rkt
index f2a79477aa..e1d1d604ac 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/type-env-lang.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/type-env-lang.rkt
@@ -1,6 +1,6 @@
 #lang racket/base
 
-(require (for-syntax racket/base syntax/parse))
+(require (for-syntax racket/base syntax/parse syntax/stx))
 
 (define-syntax (#%module-begin stx)
   (syntax-parse stx #:literals (require)
@@ -9,7 +9,9 @@
         (begin
           (define-syntax (nm stx)
             (raise-syntax-error
-             'type-check "type name used out of context" stx))
+             'type-check "type name used out of context"
+             stx
+             (and (stx-pair? stx) (stx-car stx))))
           ...
           (provide nm) ...
           (begin-for-syntax
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/pr13289.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/pr13289.rkt
new file mode 100644
index 0000000000..62c5d19c5a
--- /dev/null
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/fail/pr13289.rkt
@@ -0,0 +1,10 @@
+#;
+(exn-pred #rx"fail/pr13289.rkt:9:10:.*in: Natural")
+#lang typed/racket
+
+;; This test ensures that the error message for misuse of
+;; type names has a source location and reports with the correct
+;; syntax
+
+(assert 2 Natural)
+