From 5afd840ff381e3743602330d6384df08fc7c47a8 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 17 Oct 2001 10:35:34 +0000
Subject: [PATCH] [project @ 2001-10-17 10:35:34 by simonpj]
 ------------------------------- 	Fix type-synonym
 arity checking 	-------------------------------

	*** MERGE TO STABLE BRANCH ***

The newish stuff on checking types (checkValidType etc)
didn't detect an un-saturated, but *kind-correct* type
synonym occurrence.  Example:

	type A i = i
	type B = A

Result: crash.  Fix is rather easy.

Thanks to Thomas Hallgren.
---
 ghc/compiler/typecheck/TcMType.lhs    |    9 ++++++++-
 ghc/compiler/typecheck/TcMonoType.lhs |    8 ++------
 ghc/compiler/types/Type.lhs           |   25 +++++++++++++++++++------
 3 files changed, 29 insertions(+), 13 deletions(-)

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 13b656b..d5d394e 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -522,7 +522,8 @@ to a Type, performing kind checking, and then check various things that should
 be true about it.  We don't want to perform these checks at the same time
 as the initial translation because (a) they are unnecessary for interface-file
 types and (b) when checking a mutually recursive group of type and class decls,
-we can't "look" at the tycons/classes yet.
+we can't "look" at the tycons/classes yet.  Also, the checks are are rather
+diverse, and used to really mess up the other code.
 
 One thing we check for is 'rank'.  
 
@@ -537,7 +538,13 @@ One thing we check for is 'rank'.
 	r1  ::= forall tvs. cxt => r0
 	r0  ::= r0 -> r0 | basic
 	
+Another thing is to check that type synonyms are saturated. 
+This might not necessarily show up in kind checking.
+	type A i = i
+	data T k = MkT (k Int)
+	f :: T A	-- BAD!
 
+	
 \begin{code}
 data UserTypeCtxt 
   = FunSigCtxt Name	-- Function type signature
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 7277db7..867fa9d 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -77,7 +77,7 @@ Generally speaking we now type-check types in three phases
 
 	1.  Kind check the HsType [kcHsType]
 	2.  Convert from HsType to Type, and hoist the foralls [tcHsType]
-	3.  Check the validity of the resultint type [checkValidType]
+	3.  Check the validity of the resulting type [checkValidType]
 
 Often these steps are done one after the othe (tcHsSigType).
 But in mutually recursive groups of type and class decls we do
@@ -445,12 +445,8 @@ tc_fun_type name arg_tys
 	ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
 
 	AGlobal (ATyCon tc)
-		| isSynTyCon tc ->  returnTc (mkAppTys (mkSynTy tc (take arity arg_tys))
-						       (drop arity arg_tys))
+		| isSynTyCon tc ->  returnTc (mkSynTy tc arg_tys)
 		| otherwise	->  returnTc (mkTyConApp tc arg_tys)
-		where
-	  	    arity = tyConArity tc
-
 
 	other -> failWithTc (wrongThingErr "type constructor" thing name)
 \end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 5fcba6d..101363d 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -368,13 +368,26 @@ splitTyConApp_maybe other	      = Nothing
 				~~~~~
 
 \begin{code}
-mkSynTy syn_tycon tys
-  = ASSERT( isSynTyCon syn_tycon )
-    ASSERT( length tyvars == length tys )
-    NoteTy (SynNote (TyConApp syn_tycon tys))
-	   (substTyWith tyvars tys body)
+mkSynTy tycon tys
+  | n_args == arity	-- Exactly saturated
+  = mk_syn tys
+  | n_args >  arity	-- Over-saturated
+  = foldl AppTy (mk_syn (take arity tys)) (drop arity tys)
+  | otherwise		-- Un-saturated
+  = TyConApp tycon tys
+	-- For the un-saturated case we build TyConApp directly
+	-- (mkTyConApp ASSERTs that the tc isn't a SynTyCon).
+	-- Here we are relying on checkValidType to find
+	-- the error.  What we can't do is use mkSynTy with
+	-- too few arg tys, because that is utterly bogus.
+
   where
-    (tyvars, body) = getSynTyConDefn syn_tycon
+    mk_syn tys = NoteTy (SynNote (TyConApp tycon tys))
+			(substTyWith tyvars tys body)
+
+    (tyvars, body) = ASSERT( isSynTyCon tycon ) getSynTyConDefn tycon
+    arity 	   = tyConArity tycon
+    n_args	   = length tys
 \end{code}
 
 Notes on type synonyms
-- 
1.7.10.4