X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=cf38146eb10d59b2c7b16691d72fdd35dba5fab0;hb=1ae354e107715a9e3fd4e2d67b61f868c090e4ae;hp=b0d647b67ae254b89ce0381cf7bce90f9236988d;hpb=25512ca39778bf6882a50db2ede21ffa74ea3ac9;p=ghc-hetmet.git

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index b0d647b..cf38146 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -36,16 +36,15 @@ module Type (
 	mkTyConApp, mkTyConTy, 
 	tyConAppTyCon, tyConAppArgs, 
 	splitTyConApp_maybe, splitTyConApp, 
-        splitNewTyConApp_maybe, splitNewTyConApp,
 
         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
-	applyTy, applyTys, isForAllTy, dropForAlls,
+	applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
 	
 	-- (Newtypes)
 	newTyConInstRhs,
 	
 	-- (Type families)
-        tyFamInsts,
+        tyFamInsts, predFamInsts,
 
         -- (Source types)
         mkPredTy, mkPredTys, mkFamilyTyConApp,
@@ -128,7 +127,7 @@ module Type (
         isEmptyTvSubst,
 
 	-- ** Performing substitution on types
-	substTy, substTys, substTyWith, substTheta, 
+	substTy, substTys, substTyWith, substTysWith, substTheta, 
 	substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
 
 	-- * Pretty-printing
@@ -534,20 +533,6 @@ splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 splitTyConApp_maybe _                 = Nothing
 
--- | Sometimes we do NOT want to look through a @newtype@.  When case matching
--- on a newtype we want a convenient way to access the arguments of a @newtype@
--- constructor so as to properly form a coercion, and so we use 'splitNewTyConApp'
--- instead of 'splitTyConApp_maybe'
-splitNewTyConApp :: Type -> (TyCon, [Type])
-splitNewTyConApp ty = case splitNewTyConApp_maybe ty of
-			Just stuff -> stuff
-			Nothing	   -> pprPanic "splitNewTyConApp" (ppr ty)
-splitNewTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
-splitNewTyConApp_maybe ty | Just ty' <- tcView ty = splitNewTyConApp_maybe ty'
-splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
-splitNewTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
-splitNewTyConApp_maybe _                 = Nothing
-
 newTyConInstRhs :: TyCon -> [Type] -> Type
 -- ^ Unwrap one 'layer' of newtype on a type constructor and it's arguments, using an 
 -- eta-reduced version of the @newtype@ if possible
@@ -742,15 +727,18 @@ applyTys :: Type -> [Type] -> Type
 -- > foo = case undefined :: R of
 -- >            R f -> f ()
 
-applyTys orig_fun_ty []      = orig_fun_ty
-applyTys orig_fun_ty arg_tys 
+applyTys ty args = applyTysD empty ty args
+
+applyTysD :: SDoc -> Type -> [Type] -> Type	-- Debug version
+applyTysD _   orig_fun_ty []      = orig_fun_ty
+applyTysD doc orig_fun_ty arg_tys 
   | n_tvs == n_args 	-- The vastly common case
   = substTyWith tvs arg_tys rho_ty
   | n_tvs > n_args 	-- Too many for-alls
   = substTyWith (take n_args tvs) arg_tys 
 		(mkForAllTys (drop n_args tvs) rho_ty)
   | otherwise		-- Too many type args
-  = ASSERT2( n_tvs > 0, ppr orig_fun_ty )	-- Zero case gives infnite loop!
+  = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty )	-- Zero case gives infnite loop!
     applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
 	     (drop n_tvs arg_tys)
   where
@@ -899,6 +887,14 @@ tyFamInsts (TyConApp tc tys)
 tyFamInsts (FunTy ty1 ty2)      = tyFamInsts ty1 ++ tyFamInsts ty2
 tyFamInsts (AppTy ty1 ty2)      = tyFamInsts ty1 ++ tyFamInsts ty2
 tyFamInsts (ForAllTy _ ty)      = tyFamInsts ty
+tyFamInsts (PredTy pty)         = predFamInsts pty
+
+-- | Finds type family instances occuring in a predicate type after expanding 
+-- synonyms.
+predFamInsts :: PredType -> [(TyCon, [Type])]
+predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys)
+predFamInsts (IParam _ ty)     = tyFamInsts ty
+predFamInsts (EqPred ty1 ty2)  = tyFamInsts ty1 ++ tyFamInsts ty2
 \end{code}
 
 
@@ -1159,14 +1155,16 @@ coreEqType t1 t2
 
 \begin{code}
 tcEqType :: Type -> Type -> Bool
--- ^ Type equality on source types. Does not look through @newtypes@ or 'PredType's
+-- ^ Type equality on source types. Does not look through @newtypes@ or 
+-- 'PredType's, but it does look through type synonyms.
 tcEqType t1 t2 = isEqual $ cmpType t1 t2
 
 tcEqTypes :: [Type] -> [Type] -> Bool
 tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
 
 tcCmpType :: Type -> Type -> Ordering
--- ^ Type ordering on source types. Does not look through @newtypes@ or 'PredType's
+-- ^ Type ordering on source types. Does not look through @newtypes@ or 
+-- 'PredType's, but it does look through type synonyms.
 tcCmpType t1 t2 = cmpType t1 t2
 
 tcCmpTypes :: [Type] -> [Type] -> Ordering
@@ -1511,6 +1509,12 @@ substTyWith :: [TyVar] -> [Type] -> Type -> Type
 substTyWith tvs tys = ASSERT( length tvs == length tys )
 		      substTy (zipOpenTvSubst tvs tys)
 
+-- | Type substitution making use of an 'TvSubst' that
+-- is assumed to be open, see 'zipOpenTvSubst'
+substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
+substTysWith tvs tys = ASSERT( length tvs == length tys )
+		       substTys (zipOpenTvSubst tvs tys)
+
 -- | Substitute within a 'Type'
 substTy :: TvSubst -> Type  -> Type
 substTy subst ty | isEmptyTvSubst subst = ty
@@ -1625,7 +1629,7 @@ Kinds
 --            ??   (\#)
 --           \/  &#92;
 --          \*    \#
---
+-- .
 -- Where:        \*    [LiftedTypeKind]   means boxed type
 --              \#    [UnliftedTypeKind] means unboxed type
 --              (\#)  [UbxTupleKind]     means unboxed tuple