\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}
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
-- 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
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
}
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
-- (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 tycon) 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}
projects / ghc-hetmet.git / blobdiff