X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FFamInst.lhs;h=ccdbf579dcadf662509654061fb67b86a64e2aab;hp=8e8df882d32d3f44a5022cadde3e1ae3f32c9bf8;hb=HEAD;hpb=f5e36de375d03a0af3858c4222690bbaa5f8a1ee diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 8e8df88..ccdbf57 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -2,26 +2,26 @@ The @FamInst@ type: family instance heads \begin{code} module FamInst ( - checkFamInstConsistency, tcExtendLocalFamInstEnv + checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs ) where import HscTypes import FamInstEnv +import LoadIface import TcMType -import TcType import TcRnMonad import TyCon -import Type import Name import Module import SrcLoc import Outputable -import LazyUniqFM -import FiniteMap +import UniqFM import FastString -import Maybe -import Monad +import Maybes +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map \end{code} @@ -36,6 +36,16 @@ check whether the instances in the two modules are consistent, *unless* we can be certain that the instances of the two modules have already been checked for consistency during the compilation of modules that we import. +Why do we need to check? Consider + module X1 where module X2 where + data T1 data T2 + type instance F T1 b = Int type instance F a T2 = Char + f1 :: F T1 a -> Int f2 :: Char -> F a T2 + f1 x = x f2 x = x + +Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char. +Notice that neither instance is an orphan. + How do we know which pairs of modules have already been checked? Any pair of modules where both modules occur in the `HscTypes.dep_finsts' set (of the `HscTypes.Dependencies') of one of our directly imported modules must have @@ -62,10 +72,10 @@ instance Ord ModulePair where -- Sets of module pairs -- -type ModulePairSet = FiniteMap ModulePair () +type ModulePairSet = Map ModulePair () listToSet :: [ModulePair] -> ModulePairSet -listToSet l = listToFM (zip l (repeat ())) +listToSet l = Map.fromList (zip l (repeat ())) checkFamInstConsistency :: [Module] -> [Module] -> TcM () checkFamInstConsistency famInstMods directlyImpMods @@ -73,46 +83,48 @@ checkFamInstConsistency famInstMods directlyImpMods ; (eps, hpt) <- getEpsAndHpt ; let { -- Fetch the iface of a given module. Must succeed as - -- all imported modules must already have been loaded. + -- 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 = mkFamInstEnv . md_fam_insts . hm_details - ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv - ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi) - | hmi <- eltsUFM hpt] - ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules - `extendModuleEnvList` -- plus - hptModInsts -- home package modules + ; 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 = keysFM $ criticalPairs `minusFM` okPairs + ; toCheckPairs = Map.keys $ criticalPairs `Map.difference` okPairs -- the difference gives us the pairs we need to check now } - ; mapM_ (check modInstsEnv) toCheckPairs + ; mapM_ (check hpt_fam_insts) toCheckPairs } where allPairs [] = [] allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms - -- The modules are guaranteed to be in the environment, as they are either - -- already loaded in the EPS or they are in the HPT. - -- - check modInstsEnv (ModulePair m1 m2) - = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1 - ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2 - ; insts1 = famInstEnvElts instEnv1 - } - in - mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1 + 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} %************************************************************************ @@ -168,38 +180,13 @@ checkForConflicts inst_envs famInst -- (since we do unification). -- We use tcInstSkolType because we don't want to allocate -- fresh *meta* type variables. - ; let { tycon = famInstTyCon famInst - ; ty = case tyConFamInst_maybe tycon of - Nothing -> panic "FamInst.checkForConflicts" - Just (tc, tys) -> tc `mkTyConApp` tys - } - ; (_, _, tau') <- tcInstSkolType FamInstSkol ty - - ; let (fam, tys') = tcSplitTyConApp tau' - - ; let { matches = lookupFamInstEnvUnify inst_envs fam tys' - ; conflicts = [ conflictingFamInst - | match@((conflictingFamInst, _), _) <- matches - , conflicting tycon match - ] - } + + ; skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst)) + ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs ; unless (null conflicts) $ - conflictInstErr famInst (head conflicts) + conflictInstErr famInst (fst (head conflicts)) } where - -- * In the case of data family instances, any overlap is fundamentally a - -- conflict (as these instances imply injective type mappings). - -- * In the case of type family instances, overlap is admitted as long as - -- the right-hand sides of the overlapping rules coincide under the - -- overlap substitution. We require that they are syntactically equal; - -- anything else would be difficult to test for at this stage. - conflicting tycon1 ((famInst2, _), subst) - | isAlgTyCon tycon1 = True - | otherwise = not (rhs1 `tcEqType` rhs2) - where - tycon2 = famInstTyCon famInst2 - rhs1 = substTy subst $ synTyConType tycon1 - rhs2 = substTy subst $ synTyConType tycon2 conflictInstErr :: FamInst -> FamInst -> TcRn () conflictInstErr famInst conflictingFamInst @@ -212,4 +199,11 @@ addFamInstLoc famInst thing_inside = setSrcSpan (mkSrcSpan loc loc) thing_inside where loc = getSrcLoc famInst + +tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv) +-- Gets both the external-package inst-env +-- and the home-pkg inst env (includes module being compiled) +tcGetFamInstEnvs + = do { eps <- getEps; env <- getGblEnv + ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } \end{code}