From ac1027af8b38669bddf388951cee98e08892cb44 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 20 May 2008 20:47:18 +0000
Subject: [PATCH] Handle errors in type application.

svn: r9915
---
 collects/typed-scheme/private/subtype.ss     | 28 +++++++++++++++++---
 collects/typed-scheme/private/tc-app-unit.ss |  5 ++--
 2 files changed, 27 insertions(+), 6 deletions(-)

diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss
index 999d8936bb..e2e5962397 100644
--- a/collects/typed-scheme/private/subtype.ss
+++ b/collects/typed-scheme/private/subtype.ss
@@ -228,12 +228,32 @@
                  (unless (Type? t)                     
                    (fail! s t))
                  #;(printf "subtype: app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other 
-                           (instantiate-poly t args))
+                         (instantiate-poly t args))
                  (unless (Poly? t)
-                   (tc-error/stx stx "cannot apply non-polymorphic type ~a" t))
-                 (let ([v (subtype* A0 (instantiate-poly t args) other)])                    
+                   (tc-error/stx stx "cannot apply non-polymorphic type ~a" t))                 
+                 (match t [(Poly-unsafe: n _)
+                           (unless (= n (length args))
+                             (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a"
+                                           n (length args)))])
+                 (let ([v (subtype* A0 (instantiate-poly t args) other)])
                    #;(printf "val: ~a~n"  v)
                    v))]
+              [(list other (App: (Name: n) args stx))
+               (let ([t (lookup-type-name n)])
+                 (unless (Type? t)                     
+                   (fail! s t))
+                 #;(printf "subtype: 2 app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other 
+                         (instantiate-poly t args))
+                 (unless (Poly? t)
+                   (tc-error/stx stx "cannot apply non-polymorphic type ~a" t))                 
+                 (match t [(Poly-unsafe: n _)
+                           (unless (= n (length args))
+                             (tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a"
+                                           n (length args)))])
+                 ;(printf "about to call subtype with: ~a ~a ~n" other (instantiate-poly t args))
+                 (let ([v (subtype* A0 other (instantiate-poly t args))])
+                   #;(printf "2 val: ~a~n"  v)
+                   v))]
               [(list (Name: n) other)
                (let ([t (lookup-type-name n)])
                  ;(printf "subtype: name: ~a ~a ~a~n" (syntax-e n) t other)
@@ -253,7 +273,7 @@
               [(list (Instance: t) (Instance: t*))
                (subtype* A0 t t*)]
               ;; otherwise, not a subtype
-              [_ (fail! s t) (printf "failed")]))))))
+              [_ (fail! s t) #;(printf "failed")]))))))
 
 (define (type-compare? a b)
   (and (subtype a b) (subtype b a)))
diff --git a/collects/typed-scheme/private/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss
index a3c8bf2313..4c033d949f 100644
--- a/collects/typed-scheme/private/tc-app-unit.ss
+++ b/collects/typed-scheme/private/tc-app-unit.ss
@@ -227,7 +227,7 @@
          (if (= 1 (length doms))
              (let-values ([(thn-eff els-eff)
                            (tc-args argtypes arg-thn-effs arg-els-effs (car doms) (car rests) 
-                                    (car latent-thn-effs) (car latent-els-effs) 
+                                    (car latent-thn-effs) (car latent-els-effs)
                                     (syntax->list args))])
                (ret (car rngs) thn-eff els-eff)
                #;(if (false-effect? eff)
@@ -271,7 +271,8 @@
                                  ;; FIXME
                                  ;; should be an error here, something went horribly wrong!!!
                                  (begin 
-                                   (printf "substituion was bad~n")
+				   #;
+                                   (printf "substitution was bad~n args: ~a ~n new-doms: ~a~n~a~n" argtypes new-doms* substitution)
                                    (loop (cdr doms*) (cdr rngs*)))))))]
                              #|
                            (printf "subst is:~a~nret is: ~a~nvars is: ~a~nresult is:~a~n" substitution (car rngs*) vars