X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FInstEnv.lhs;h=b7a356b610fab6ac7b23885cb433f0deecf6cf09;hb=4e3255388e8b99ccdae290bfcb6cd666b8c93d4a;hp=7b6e93a8894bd947a259d59385404eec07e03c22;hpb=d32c5227315009f38355fe3233f0f4e5b1f61dc6;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs
index 7b6e93a..b7a356b 100644
--- a/ghc/compiler/types/InstEnv.lhs
+++ b/ghc/compiler/types/InstEnv.lhs
@@ -10,7 +10,7 @@ module InstEnv (
 	DFunId, InstEnv,
 
 	emptyInstEnv, extendInstEnv,
-	lookupInstEnv, 
+	lookupInstEnv, instEnvElts,
 	classInstances, simpleDFunClassTyCon, checkFunDeps
     ) where
 
@@ -27,7 +27,7 @@ import TcType		( Type, tcTyConAppTyCon, tcIsTyVarTy,
 import FunDeps		( checkClsFD )
 import TyCon		( TyCon )
 import Outputable
-import UniqFM		( UniqFM, lookupUFM, emptyUFM, addToUFM_C )
+import UniqFM		( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM )
 import Id		( idType )
 import CmdLineOpts
 import Util             ( notNull )
@@ -58,10 +58,16 @@ type InstEnvElt = (TyVarSet, [Type], DFunId)
 emptyInstEnv :: InstEnv
 emptyInstEnv = emptyUFM
 
-classInstances :: InstEnv -> Class -> [InstEnvElt]
-classInstances env cls = case lookupUFM env cls of
-			  Just (ClsIE insts _) -> insts
-			  Nothing	       -> []
+instEnvElts :: InstEnv -> [InstEnvElt]
+instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts]
+
+classInstances :: (InstEnv,InstEnv) -> Class -> [InstEnvElt]
+classInstances (pkg_ie, home_ie) cls 
+  = get home_ie ++ get pkg_ie
+  where
+    get env = case lookupUFM env cls of
+		Just (ClsIE insts _) -> insts
+		Nothing		     -> []
 
 extendInstEnv :: InstEnv -> DFunId -> InstEnv
 extendInstEnv inst_env dfun_id
@@ -398,13 +404,13 @@ checkFunDeps :: (InstEnv, InstEnv) -> DFunId
 	     -> Maybe [DFunId]	-- Nothing  <=> ok
 				-- Just dfs <=> conflict with dfs
 -- Check wheher adding DFunId would break functional-dependency constraints
-checkFunDeps (pkg_ie, home_ie) dfun
+checkFunDeps inst_envs dfun
   | null bad_fundeps = Nothing
   | otherwise	     = Just bad_fundeps
   where
     (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun)
     ins_tv_set   = mkVarSet ins_tvs
-    cls_inst_env = classInstances home_ie clas ++ classInstances pkg_ie clas
+    cls_inst_env = classInstances inst_envs clas
     bad_fundeps  = badFunDeps cls_inst_env clas ins_tv_set ins_tys
 
 badFunDeps :: [InstEnvElt] -> Class