Improve error messages in the simple case.

Change 'typecheck to Type Checker in error messages.

svn: r17542

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 ()

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: "

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 (string->symbol "Type Checker") msg (car stxs))
-      (raise-syntax-error 'typecheck msg #f #f stxs)))
+      (raise-syntax-error (string->symbol "Type Checker") msg #f #f stxs)))
 
 (define delayed-errors null)
 

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))