X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FFamInst.lhs;h=45584d9b411aa11039aab9b0ef571c26dfa6c051;hp=9c5b597f216d773655b795e16564712cef26251a;hb=16b9e80dc14db24509f051f294b5b51943285090;hpb=f4510d27c5883fe7e8570f4dd49d45a8b0122f2c diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 9c5b597..45584d9 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -2,26 +2,25 @@ The @FamInst@ type: family instance heads \begin{code} module FamInst ( - checkFamInstConsistency, tcExtendLocalFamInstEnv + checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs ) where -#include "HsVersions.h" - import HscTypes import FamInstEnv import TcMType -import TcType import TcRnMonad import TyCon -import Type import Name import Module import SrcLoc import Outputable -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 +35,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,9 +71,10 @@ instance Ord ModulePair where -- Sets of module pairs -- -type ModulePairSet = FiniteMap ModulePair () +type ModulePairSet = Map ModulePair () -listToSet l = listToFM (zip l (repeat ())) +listToSet :: [ModulePair] -> ModulePairSet +listToSet l = Map.fromList (zip l (repeat ())) checkFamInstConsistency :: [Module] -> [Module] -> TcM () checkFamInstConsistency famInstMods directlyImpMods @@ -78,14 +88,21 @@ checkFamInstConsistency famInstMods directlyImpMods Nothing -> panic "FamInst.checkFamInstConsistency" Just iface -> iface - ; modInstsEnv = eps_mod_fam_inst_env eps + ; 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 ; 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 } @@ -95,10 +112,12 @@ checkFamInstConsistency famInstMods directlyImpMods allPairs [] = [] allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms - -- Check the consistency of the family instances of the two modules. + -- 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 + = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1 + ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2 ; insts1 = famInstEnvElts instEnv1 } in @@ -158,38 +177,36 @@ 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 +\end{code} + +\begin{code} + +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}