From 72c2f581702ca162f56012dd0c8cafcbac284b5c Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 12 Mar 2002 15:55:27 +0000
Subject: [PATCH] [project @ 2002-03-12 15:55:26 by simonpj]
 ------------------------ 	Fix a type-invariant bug 
 ------------------------

We need to call Type.mkGenTyConApp from Type.mkAppTy, in
case there's a partially applied type synonym.  Explanation
with Type.mkAppTy.  All part of GHC's rather liberal treatment
of type synonyms.

Shown up by a program from Ralf Laemmel:

	type Generic i o = forall x. i x -> o x
	type Id x = x
	comb :: Generic Id Id

Test is typecheck/should_compile/tc149.hs
---
 ghc/compiler/typecheck/TcMType.lhs    |    3 ++-
 ghc/compiler/typecheck/TcMonoType.lhs |   10 ++++------
 ghc/compiler/typecheck/TcType.lhs     |    4 ++--
 ghc/compiler/types/Type.lhs           |   17 +++++++++++++++--
 4 files changed, 23 insertions(+), 11 deletions(-)

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 1a16e59..df429b7 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -697,7 +697,8 @@ check_tau_type rank ubx_tup (NoteTy note ty)
 	-- Synonym notes are built only when the synonym is 
 	-- saturated (see Type.mkSynTy)
 	-- Not checking the 'note' part allows us to instantiate a synonym
-	-- defn with a for-all type, but that seems OK too
+	-- defn with a for-all type, or with a partially-applied type synonym,
+	-- but that seems OK too
 
 check_tau_type rank ubx_tup ty@(TyConApp tc tys)
   | isSynTyCon tc	
diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index e200bcf..90d5f8b 100644
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -34,9 +34,9 @@ import TcMType		( newKindVar, zonkKindEnv, tcInstType,
 import TcUnify		( unifyKind, unifyOpenTypeKind )
 import TcType		( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
 			  TcTyVar, TcKind, TcThetaType, TcTauType,
-			  mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
+			  mkTyVarTy, mkTyVarTys, mkFunTy, 
 		 	  hoistForAllTys, zipFunTys, 
-			  mkSigmaTy, mkPredTy, mkTyConApp, mkAppTys, 
+			  mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
 			  liftedTypeKind, unliftedTypeKind, mkArrowKind,
 			  mkArrowKinds, tcSplitFunTy_maybe
 			)
@@ -45,7 +45,7 @@ import Inst		( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
 import Id		( mkLocalId, idName, idType )
 import Var		( TyVar, mkTyVar, tyVarKind )
 import ErrUtils		( Message )
-import TyCon		( TyCon, isSynTyCon, tyConKind )
+import TyCon		( TyCon, tyConKind )
 import Class		( classTyCon )
 import Name		( Name )
 import NameSet
@@ -480,9 +480,7 @@ tc_fun_type name arg_tys
     case thing of
 	ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
 
-	AGlobal (ATyCon tc)
-		| isSynTyCon tc ->  returnTc (mkSynTy tc arg_tys)
-		| otherwise	->  returnTc (mkTyConApp tc arg_tys)
+	AGlobal (ATyCon tc) -> returnTc (mkGenTyConApp tc arg_tys)
 
 	other -> failWithTc (wrongThingErr "type constructor" thing name)
 \end{code}
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 5a815e4..8286f64 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -87,7 +87,7 @@ module TcType (
   Type, SourceType(..), PredType, ThetaType, 
   mkForAllTy, mkForAllTys, 
   mkFunTy, mkFunTys, zipFunTys, 
-  mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
+  mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
   mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, 
 
   isUnLiftedType,	-- Source types are always lifted
@@ -115,7 +115,7 @@ import Type		(	-- Re-exports
 			  unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
 			  mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind,
 			  mkFunTy, mkFunTys, zipFunTys, 
-			  mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
+			  mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
 			  mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
 			  isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
 			  splitNewType_maybe, splitTyConApp_maybe,
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 526cf3d..2f93e9f 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -33,7 +33,7 @@ module Type (
 	mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, 
 	funResultTy, funArgTy, zipFunTys, isFunTy,
 
-	mkTyConApp, mkTyConTy, 
+	mkGenTyConApp, mkTyConApp, mkTyConTy, 
 	tyConAppTyCon, tyConAppArgs, 
 	splitTyConApp_maybe, splitTyConApp,
 
@@ -194,8 +194,16 @@ mkAppTy orig_ty1 orig_ty2
     mk_app orig_ty1
   where
     mk_app (NoteTy _ ty1)    = mk_app ty1
-    mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
+    mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2])
     mk_app ty1		     = AppTy orig_ty1 orig_ty2
+	-- We call mkGenTyConApp because the TyConApp could be an 
+	-- under-saturated type synonym.  GHC allows that; e.g.
+	--	type Foo k = k a -> k a
+	--	type Id x = x
+	--	foo :: Foo Id -> Foo Id
+	--
+	-- Here Id is partially applied in the type sig for Foo,
+	-- but once the type synonyms are expanded all is well
 
 mkAppTys :: Type -> [Type] -> Type
 mkAppTys orig_ty1 []	    = orig_ty1
@@ -306,6 +314,11 @@ funArgTy ty		 = pprPanic "funArgTy" (pprType ty)
 as apppropriate.
 
 \begin{code}
+mkGenTyConApp :: TyCon -> [Type] -> Type
+mkGenTyConApp tc tys
+  | isSynTyCon tc = mkSynTy tc tys
+  | otherwise     = mkTyConApp tc tys
+
 mkTyConApp :: TyCon -> [Type] -> Type
 -- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those
 mkTyConApp tycon tys
-- 
1.7.10.4