+-- The optimisation of overlap tests is based on determining pairs of modules
+-- whose family instances need to be checked for consistency.
+--
+data ModulePair = ModulePair Module Module
+
+-- canonical order of the components of a module pair
+--
+canon :: ModulePair -> (Module, Module)
+canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
+ | otherwise = (m2, m1)
+
+instance Eq ModulePair where
+ mp1 == mp2 = canon mp1 == canon mp2
+
+instance Ord ModulePair where
+ mp1 `compare` mp2 = canon mp1 `compare` canon mp2
+
+-- Sets of module pairs
+--
+type ModulePairSet = Map ModulePair ()
+
+listToSet :: [ModulePair] -> ModulePairSet
+listToSet l = Map.fromList (zip l (repeat ()))
+
+checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
+checkFamInstConsistency famInstMods directlyImpMods
+ = do { dflags <- getDOpts
+ ; (eps, hpt) <- getEpsAndHpt
+
+ ; let { -- Fetch the iface of a given module. Must succeed as
+ -- all directly imported modules must already have been loaded.
+ modIface mod =
+ case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
+ Nothing -> panic "FamInst.checkFamInstConsistency"
+ Just iface -> iface
+
+ ; hmiModule = mi_module . hm_iface
+ ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
+ . md_fam_insts . hm_details
+ ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
+ | hmi <- eltsUFM hpt]
+ ; groups = map (dep_finsts . mi_deps . modIface)
+ directlyImpMods
+ ; okPairs = listToSet $ concatMap allPairs groups
+ -- instances of okPairs are consistent
+ ; criticalPairs = listToSet $ allPairs famInstMods
+ -- all pairs that we need to consider
+ ; toCheckPairs = Map.keys $ criticalPairs `Map.difference` okPairs
+ -- the difference gives us the pairs we need to check now
+ }
+
+ ; mapM_ (check hpt_fam_insts) toCheckPairs
+ }
+ where
+ allPairs [] = []
+ allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
+
+ check hpt_fam_insts (ModulePair m1 m2)
+ = do { env1 <- getFamInsts hpt_fam_insts m1
+ ; env2 <- getFamInsts hpt_fam_insts m2
+ ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))
+ (famInstEnvElts env1) }
+
+getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
+getFamInsts hpt_fam_insts mod
+ | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
+ | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
+ ; eps <- getEps
+ ; return (expectJust "checkFamInstConsistency" $
+ lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+ where
+ doc = ppr mod <+> ptext (sLit "is a family-instance module")
+\end{code}
+
+%************************************************************************
+%* *
+ Extending the family instance environment
+%* *
+%************************************************************************