X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FType.lhs;h=0912a2c15a0885424241c9bb2950cb7fd0bfe50a;hb=57217f68d74c803a189942eb99eed56610ad296b;hp=07e61daf0008c079462ff08b333022bc1946a73b;hpb=32a5c61dc1df5e12aaf1f21e5928fbb261d62043;p=ghc-hetmet.git

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 07e61da..0912a2c 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -44,7 +44,7 @@ module Type (
 	newTyConInstRhs,
 	
 	-- (Type families)
-        tyFamInsts,
+        tyFamInsts, predFamInsts,
 
         -- (Source types)
         mkPredTy, mkPredTys, mkFamilyTyConApp,
@@ -534,7 +534,7 @@ splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 splitTyConApp_maybe _                 = Nothing
 
 newTyConInstRhs :: TyCon -> [Type] -> Type
--- ^ Unwrap one 'layer' of newtype on a type constructor and it's arguments, using an 
+-- ^ Unwrap one 'layer' of newtype on a type constructor and its arguments, using an 
 -- eta-reduced version of the @newtype@ if possible
 newTyConInstRhs tycon tys 
     = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
@@ -739,8 +739,8 @@ applyTysD doc orig_fun_ty arg_tys
 		(mkForAllTys (drop n_args tvs) rho_ty)
   | otherwise		-- Too many type args
   = 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)
+    applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty)
+	          (drop n_tvs arg_tys)
   where
     (tvs, rho_ty) = splitForAllTys orig_fun_ty 
     n_tvs = length tvs
@@ -887,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}