From 08457d35e3faa1a8dccbcbfc6b193c63fda45fb6 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Thu, 7 Jan 2010 19:41:42 +0000
Subject: [PATCH] Improve error messages in the simple case. Change 'typecheck
 to Type Checker in error messages.

svn: r17542
---
 collects/tests/typed-scheme/main.ss           |  2 +-
 .../typed-scheme/typecheck/tc-app-helper.ss   | 19 ++++++++++++++++-
 collects/typed-scheme/utils/tc-utils.ss       |  4 ++--
 collects/typed-scheme/utils/utils.ss          | 21 +------------------
 4 files changed, 22 insertions(+), 24 deletions(-)

diff --git a/collects/tests/typed-scheme/main.ss b/collects/tests/typed-scheme/main.ss
index 74d68762a2..ee7d29f635 100644
--- a/collects/tests/typed-scheme/main.ss
+++ b/collects/tests/typed-scheme/main.ss
@@ -39,7 +39,7 @@
       [(list-rest 'exn-pred e)
        (eval `(exn-matches . ,e) (namespace-anchor->namespace a))]
       [_ 
-       (exn-matches ".*typecheck.*" exn:fail:syntax?)])))
+       (exn-matches ".*Type Checker.*" exn:fail:syntax?)])))
 
 (define (mk-tests dir loader test)
   (lambda ()
diff --git a/collects/typed-scheme/typecheck/tc-app-helper.ss b/collects/typed-scheme/typecheck/tc-app-helper.ss
index db34787757..32efdc7da6 100644
--- a/collects/typed-scheme/typecheck/tc-app-helper.ss
+++ b/collects/typed-scheme/typecheck/tc-app-helper.ss
@@ -1,6 +1,6 @@
 #lang scheme/base
 
-(require "../utils/utils.ss" scheme/match
+(require "../utils/utils.ss" scheme/match unstable/list
          (utils tc-utils) (rep type-rep) (types utils union))
 
 (provide (all-defined-out))
@@ -28,6 +28,23 @@
   (cond
     [(null? doms)
      (int-err "How could doms be null: ~a ~a" ty)]
+    [(and (= 1 (length doms)) (not (car rests)) (not (car drests)) (not tail-ty) (not tail-bound))
+     (apply string-append
+            (if (not (= (length (car doms)) (length arg-tys)))
+                (format "Wrong number of arguments - Expected ~a, but got ~a\n\n" (length (car doms)) (length arg-tys))
+                "")
+            (append
+             (for/list ([dom-t (in-list (extend arg-tys (car doms) #f))]
+                        [arg-t (in-list (extend (car doms) arg-tys #f))]
+                        [i (in-naturals 1)])
+               (let ([dom-t (or dom-t "-none-")]
+                     [arg-t (or arg-t "-none-")])
+                 (format "Argument ~a:\n  Expected: ~a\n  Given:    ~a\n" i (make-printable dom-t) (make-printable arg-t))))
+             (list
+              (if expected
+                  (format "\nResult type:     ~a\nExpected result: ~a\n"
+                          (car rngs) (make-printable expected))
+                  ""))))]
     [(= 1 (length doms))
      (string-append
       "Domain: "
diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss
index 48fd81240f..ce76d55e58 100644
--- a/collects/typed-scheme/utils/tc-utils.ss
+++ b/collects/typed-scheme/utils/tc-utils.ss
@@ -59,8 +59,8 @@ don't depend on any other portion of the system
 
 (define (raise-typecheck-error msg stxs)
   (if (null? (cdr stxs))
-      (raise-syntax-error 'typecheck msg (car stxs))
-      (raise-syntax-error 'typecheck msg #f #f stxs)))
+      (raise-syntax-error (string->symbol "Type Checker") msg (car stxs))
+      (raise-syntax-error (string->symbol "Type Checker") msg #f #f stxs)))
 
 (define delayed-errors null)
 
diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss
index 9f2797f2b6..8e3d6f7362 100644
--- a/collects/typed-scheme/utils/utils.ss
+++ b/collects/typed-scheme/utils/utils.ss
@@ -11,7 +11,7 @@ at least theoretically.
 	 scheme/pretty mzlib/pconvert syntax/parse)
 
 ;; to move to unstable
-(provide debug reverse-begin)
+(provide reverse-begin)
 
 (provide
  ;; timing
@@ -79,25 +79,6 @@ at least theoretically.
 (define-requirer private private-out)
 (define-requirer types types-out)
 
-;; printf debugging convenience
-(define-syntax debug
-  (syntax-rules ()
-    [(_ (f . args))
-     (begin (printf "starting ~a~n" 'f)
-            (let ([l (list . args)])
-              (printf "arguments are:~n")
-              (for/list ([arg 'args]
-                         [val l])
-                (printf "\t~a: ~a~n" arg val))
-              (let ([e (apply f l)])
-                (printf "result was ~a~n" e)
-                e)))]
-    [(_ . args)
-     (begin (printf "starting ~a~n" 'args)
-            (let ([e (begin . args)])
-              (printf "result was ~a~n" e)
-              e))]))
-
 ;; run `h' last, but drop its return value
 (define-syntax-rule (reverse-begin h . forms) (begin0 (begin . forms) h))