From: simonpj <unknown>
Date: Mon, 28 Feb 2005 16:04:54 +0000 (+0000)
Subject: [project @ 2005-02-28 16:04:54 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~1009
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a84285247bfb162fdefc3fcb8be88c34c1f5cd35

[project @ 2005-02-28 16:04:54 by simonpj]
Add forall-hoisting to TcIface; see comments with mkIfTcAPp
	Fixes Sourceforge bug 1146068
	tc191 tests

This fix is temporary, until we get rid of forall-hoisting
altogether
---

diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs
index b713908..f893a58 100644
--- a/ghc/compiler/iface/IfaceType.lhs
+++ b/ghc/compiler/iface/IfaceType.lhs
@@ -338,7 +338,7 @@ toIfaceType ext (FunTy t1 t2)    	     = IfaceFunTy (toIfaceType ext t1) (toIfac
 toIfaceType ext (TyConApp tc tys) 	     = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys)
 toIfaceType ext (ForAllTy tv t)  	     = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t)
 toIfaceType ext (PredTy st)     	     = IfacePredTy (toIfacePred ext st)
-toIfaceType ext (NoteTy (SynNote tc_app) ty) = toIfaceType ext tc_app
+toIfaceType ext (NoteTy (SynNote tc_app) ty) = toIfaceType ext tc_app	-- Retain synonyms
 toIfaceType ext (NoteTy other_note ty)	     = toIfaceType ext ty
 
 ----------------
diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs
index 0167fdb..a75582a 100644
--- a/ghc/compiler/iface/TcIface.lhs
+++ b/ghc/compiler/iface/TcIface.lhs
@@ -14,23 +14,23 @@ module TcIface (
 
 import IfaceSyn
 import LoadIface	( loadHomeInterface, loadInterface, predInstGates,
-			  discardDeclPrags, loadDecls )
-import IfaceEnv		( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig,
+			  loadDecls )
+import IfaceEnv		( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, 
 			  extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
 			  tcIfaceTyVar, tcIfaceLclId,
 			  newIfaceName, newIfaceNames )
 import BuildTyCl	( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
 			  mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
 import TcRnMonad
-import Type		( liftedTypeKind, splitTyConApp, 
+import TcType		( hoistForAllTys )	-- TEMPORARY HACK
+import Type		( liftedTypeKind, splitTyConApp, mkSynTy, mkTyConApp,
 			  mkTyVarTys, mkGenTyConApp, ThetaType, pprClassPred )
 import TypeRep		( Type(..), PredType(..) )
-import TyCon		( TyCon, tyConName )
+import TyCon		( TyCon, tyConName, isSynTyCon )
 import HscTypes		( ExternalPackageState(..), EpsStats(..), PackageInstEnv, 
-			  HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon, 
+			  HscEnv, TyThing(..), tyThingClass, tyThingTyCon, 
 			  ModIface(..), ModDetails(..), ModGuts,
-			  mkTypeEnv, extendTypeEnv, 
-			  lookupTypeEnv, lookupType, typeEnvIds )
+			  extendTypeEnv, lookupTypeEnv, lookupType, typeEnvIds )
 import InstEnv		( extendInstEnvList )
 import CoreSyn
 import PprCore		( pprIdRules )
@@ -61,7 +61,7 @@ import Outputable
 import ErrUtils		( Message )
 import Maybes		( MaybeErr(..) )
 import SrcLoc		( noSrcLoc )
-import Util		( zipWithEqual, dropList, equalLength, zipLazy )
+import Util		( zipWithEqual, dropList, equalLength )
 import CmdLineOpts	( DynFlag(..) )
 \end{code}
 
@@ -583,12 +583,21 @@ tcIfaceType :: IfaceType -> IfL Type
 tcIfaceType (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
 tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
 tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
-tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkGenTyConApp tc' ts') }
+tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkIfTcApp tc' ts') }
 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
 tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePredType st; return (PredTy st') }
 
 tcIfaceTypes tys = mapM tcIfaceType tys
 
+mkIfTcApp :: TyCon -> [Type] -> Type
+-- In interface files we retain type synonyms (for brevity and better error
+-- messages), but type synonyms can expand into non-hoisted types (ones with
+-- foralls to the right of an arrow), so we must be careful to hoist them here.
+-- This hack should go away when we get rid of hoisting.
+mkIfTcApp tc tys
+  | isSynTyCon tc = hoistForAllTys (mkSynTy tc tys)
+  | otherwise	  = mkTyConApp tc tys
+
 -----------------------------------------
 tcIfacePredType :: IfacePredType -> IfL PredType
 tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }