X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FFamInst.lhs;h=ccdbf579dcadf662509654061fb67b86a64e2aab;hp=f85f6b926666e2b4ef343808895ee12aeb0196cc;hb=HEAD;hpb=4899cc823373bd016a49cdb0dffd0e22150ec07e diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index f85f6b9..ccdbf57 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -2,27 +2,26 @@ The @FamInst@ type: family instance heads \begin{code} module FamInst ( - checkFamInstConsistency, tcExtendLocalFamInstEnv + checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs ) where -#include "HsVersions.h" - 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 UniqFM -import FiniteMap +import FastString -import Maybe -import Monad +import Maybes +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map \end{code} @@ -37,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 @@ -63,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 @@ -74,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} %************************************************************************ @@ -169,38 +180,30 @@ 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 - } - ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty - - ; let (fam, tys') = tcSplitTyConApp tau' - - ; let { matches = lookupFamInstEnvUnify inst_envs fam tys' - ; conflicts = [ conflictingFamInst - | match@(conflictingFamInst, _) <- matches - , conflicting fam tys' 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/newtype instances, any overlap is a conflict (as - -- these instances imply injective type mappings). - conflicting _ _ tycon _ | isAlgTyCon tycon = True - conflicting fam tys' tycon (subst, cFamInst) | otherwise = - panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing" +conflictInstErr :: FamInst -> FamInst -> TcRn () conflictInstErr famInst conflictingFamInst = addFamInstLoc famInst $ - addErr (hang (ptext SLIT("Conflicting family instance declarations:")) + addErr (hang (ptext (sLit "Conflicting family instance declarations:")) 2 (pprFamInsts [famInst, conflictingFamInst])) +addFamInstLoc :: FamInst -> TcRn a -> TcRn a 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}