[project @ 1997-10-15 14:17:30 by simonm]

Simon's fix for type synonym arities.  The arity of a synonym must by
less than or eqaul to the number of arguments supplied (test
typecheck/should_compile/tc093.hs).

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index d2cd24f..ac34e2d 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -21,7 +21,7 @@ import TcKind         ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
                        )
 import Type            ( GenType, SYN_IE(Type), SYN_IE(ThetaType), 
                          mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
-                         mkSigmaTy, mkDictTy
+                         mkSigmaTy, mkDictTy, mkAppTys
                        )
 import TyVar           ( GenTyVar, SYN_IE(TyVar), mkTyVar )
 import Outputable
@@ -109,33 +109,43 @@ tcTyApp ty tys
   = tcFunType ty []
 
   | otherwise
-  = mapAndUnzipTc tcHsTypeKind tys     `thenTc`    \ (arg_kinds, arg_tys) ->
+  = mapAndUnzipTc tcHsTypeKind tys     `thenTc` \ (arg_kinds, arg_tys) ->
     tcFunType ty arg_tys               `thenTc` \ (fun_kind, result_ty) ->
 
-       -- Check argument compatibility; special ca
+       -- Check argument compatibility
     newKindVar                         `thenNF_Tc` \ result_kind ->
     unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds)
                                        `thenTc_`
     returnTc (result_kind, result_ty)
 
+-- (tcFunType ty arg_tys) returns (kind-of ty, mkAppTys ty arg_tys)
+-- But not quite; for synonyms it checks the correct arity, and builds a SynTy
+--     hence the rather strange functionality.
+
 tcFunType (MonoTyVar name) arg_tys
   | isTvOcc (getOccName name)  -- Must be a type variable
   = tcLookupTyVar name                 `thenNF_Tc` \ (kind,tyvar) ->
-    returnTc (kind, foldl mkAppTy (mkTyVarTy tyvar) arg_tys)
+    returnTc (kind, mkAppTys (mkTyVarTy tyvar) arg_tys)
 
   | otherwise                  -- Must be a type constructor
-  = tcLookupTyCon name                 `thenTc` \ (kind,maybe_arity,tycon) ->
+  = tcLookupTyCon name                 `thenTc` \ (tycon_kind,maybe_arity, tycon) ->
     case maybe_arity of
-       Nothing    -> returnTc (kind, foldl mkAppTy (mkTyConTy tycon) arg_tys)
-       Just arity -> checkTc (arity == n_args) (err arity)     `thenTc_`
-                     returnTc (kind, mkSynTy tycon arg_tys)
-  where
-    err arity = arityErr "Type synonym constructor" name arity n_args
-    n_args    = length arg_tys
+       Nothing    -> returnTc (tycon_kind, mkAppTys (mkTyConTy tycon) arg_tys)
+       Just arity -> checkTc (arity <= n_args) err_msg `thenTc_`
+                     returnTc (tycon_kind, result_ty)
+                  where
+                       -- It's OK to have an *over-applied* type synonym
+                       --      data Tree a b = ...
+                       --      type Foo a = Tree [a]
+                       --      f :: Foo a b -> ...
+                     result_ty = mkAppTys (mkSynTy tycon (take arity arg_tys))
+                                          (drop arity arg_tys)
+                     err_msg = arityErr "Type synonym constructor" name arity n_args
+                     n_args  = length arg_tys
 
 tcFunType ty arg_tys
   = tcHsTypeKind ty            `thenTc` \ (fun_kind, fun_ty) ->
-    returnTc (fun_kind, foldl mkAppTy fun_ty arg_tys)
+    returnTc (fun_kind, mkAppTys fun_ty arg_tys)
 \end{code}