1 The @FamInst@ type: family instance heads
5 checkFamInstConsistency, tcExtendLocalFamInstEnv
8 #include "HsVersions.h"
29 %************************************************************************
31 Optimised overlap checking for family instances
33 %************************************************************************
35 For any two family instance modules that we import directly or indirectly, we
36 check whether the instances in the two modules are consistent, *unless* we can
37 be certain that the instances of the two modules have already been checked for
38 consistency during the compilation of modules that we import.
40 How do we know which pairs of modules have already been checked? Any pair of
41 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
42 `HscTypes.Dependencies') of one of our directly imported modules must have
43 already been checked. Everything else, we check now. (So that we can be
44 certain that the modules in our `HscTypes.dep_finsts' are consistent.)
47 -- The optimisation of overlap tests is based on determining pairs of modules
48 -- whose family instances need to be checked for consistency.
50 data ModulePair = ModulePair Module Module
52 -- canonical order of the components of a module pair
54 canon :: ModulePair -> (Module, Module)
55 canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
56 | otherwise = (m2, m1)
58 instance Eq ModulePair where
59 mp1 == mp2 = canon mp1 == canon mp2
61 instance Ord ModulePair where
62 mp1 `compare` mp2 = canon mp1 `compare` canon mp2
64 -- Sets of module pairs
66 type ModulePairSet = FiniteMap ModulePair ()
68 listToSet l = listToFM (zip l (repeat ()))
70 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
71 checkFamInstConsistency famInstMods directlyImpMods
72 = do { dflags <- getDOpts
73 ; (eps, hpt) <- getEpsAndHpt
75 ; let { -- Fetch the iface of a given module. Must succeed as
76 -- all imported modules must already have been loaded.
78 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
79 Nothing -> panic "FamInst.checkFamInstConsistency"
82 ; hmiModule = mi_module . hm_iface
83 ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
84 ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
85 ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
87 ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
88 `extendModuleEnvList` -- plus
89 hptModInsts -- home package modules
90 ; groups = map (dep_finsts . mi_deps . modIface)
92 ; okPairs = listToSet $ concatMap allPairs groups
93 -- instances of okPairs are consistent
94 ; criticalPairs = listToSet $ allPairs famInstMods
95 -- all pairs that we need to consider
96 ; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs
97 -- the difference gives us the pairs we need to check now
100 ; mapM_ (check modInstsEnv) toCheckPairs
104 allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
106 -- The modules are guaranteed to be in the environment, as they are either
107 -- already loaded in the EPS or they are in the HPT.
109 check modInstsEnv (ModulePair m1 m2)
110 = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
111 ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
112 ; insts1 = famInstEnvElts instEnv1
115 mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
118 %************************************************************************
120 Extending the family instance environment
122 %************************************************************************
125 -- Add new locally-defined family instances
126 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
127 tcExtendLocalFamInstEnv fam_insts thing_inside
128 = do { env <- getGblEnv
129 ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
130 ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
131 tcg_fam_inst_env = inst_env' }
132 ; setGblEnv env' thing_inside
135 -- Check that the proposed new instance is OK,
136 -- and then add it to the home inst env
137 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
138 addLocalFamInst home_fie famInst
139 = do { -- Load imported instances, so that we report
140 -- overlaps correctly
142 ; let inst_envs = (eps_fam_inst_env eps, home_fie)
144 -- Check for conflicting instance decls
145 ; checkForConflicts inst_envs famInst
147 -- OK, now extend the envt
148 ; return (extendFamInstEnv home_fie famInst)
152 %************************************************************************
154 Checking an instance against conflicts with an instance env
156 %************************************************************************
158 Check whether a single family instance conflicts with those in two instance
159 environments (one for the EPS and one for the HPT).
162 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
163 checkForConflicts inst_envs famInst
164 = do { -- To instantiate the family instance type, extend the instance
165 -- envt with completely fresh template variables
166 -- This is important because the template variables must
167 -- not overlap with anything in the things being looked up
168 -- (since we do unification).
169 -- We use tcInstSkolType because we don't want to allocate
170 -- fresh *meta* type variables.
171 ; let { tycon = famInstTyCon famInst
172 ; ty = case tyConFamInst_maybe tycon of
173 Nothing -> panic "FamInst.checkForConflicts"
174 Just (tc, tys) -> tc `mkTyConApp` tys
176 ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
178 ; let (fam, tys') = tcSplitTyConApp tau'
180 ; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
181 ; conflicts = [ conflictingFamInst
182 | match@(_, conflictingFamInst) <- matches
183 , conflicting fam tys' tycon match
186 ; unless (null conflicts) $
187 conflictInstErr famInst (head conflicts)
190 -- In the case of data/newtype instances, any overlap is a conflict (as
191 -- these instances imply injective type mappings).
192 conflicting _ _ tycon _ | isAlgTyCon tycon = True
193 conflicting fam tys' tycon (subst, cFamInst) | otherwise =
194 panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing"
196 conflictInstErr famInst conflictingFamInst
197 = addFamInstLoc famInst $
198 addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
199 2 (pprFamInsts [famInst, conflictingFamInst]))
201 addFamInstLoc famInst thing_inside
202 = setSrcSpan (mkSrcSpan loc loc) thing_inside
204 loc = getSrcLoc famInst