[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

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 1a16e59..df429b7 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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