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 :: [ModulePair] -> ModulePairSet
69 listToSet l = listToFM (zip l (repeat ()))
71 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
72 checkFamInstConsistency famInstMods directlyImpMods
73 = do { dflags <- getDOpts
74 ; (eps, hpt) <- getEpsAndHpt
76 ; let { -- Fetch the iface of a given module. Must succeed as
77 -- all imported modules must already have been loaded.
79 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
80 Nothing -> panic "FamInst.checkFamInstConsistency"
83 ; hmiModule = mi_module . hm_iface
84 ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
85 ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
86 ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
88 ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
89 `extendModuleEnvList` -- plus
90 hptModInsts -- home package modules
91 ; groups = map (dep_finsts . mi_deps . modIface)
93 ; okPairs = listToSet $ concatMap allPairs groups
94 -- instances of okPairs are consistent
95 ; criticalPairs = listToSet $ allPairs famInstMods
96 -- all pairs that we need to consider
97 ; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs
98 -- the difference gives us the pairs we need to check now
101 ; mapM_ (check modInstsEnv) toCheckPairs
105 allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
107 -- The modules are guaranteed to be in the environment, as they are either
108 -- already loaded in the EPS or they are in the HPT.
110 check modInstsEnv (ModulePair m1 m2)
111 = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
112 ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
113 ; insts1 = famInstEnvElts instEnv1
116 mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
119 %************************************************************************
121 Extending the family instance environment
123 %************************************************************************
126 -- Add new locally-defined family instances
127 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
128 tcExtendLocalFamInstEnv fam_insts thing_inside
129 = do { env <- getGblEnv
130 ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
131 ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
132 tcg_fam_inst_env = inst_env' }
133 ; setGblEnv env' thing_inside
136 -- Check that the proposed new instance is OK,
137 -- and then add it to the home inst env
138 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
139 addLocalFamInst home_fie famInst
140 = do { -- Load imported instances, so that we report
141 -- overlaps correctly
143 ; let inst_envs = (eps_fam_inst_env eps, home_fie)
145 -- Check for conflicting instance decls
146 ; checkForConflicts inst_envs famInst
148 -- OK, now extend the envt
149 ; return (extendFamInstEnv home_fie famInst)
153 %************************************************************************
155 Checking an instance against conflicts with an instance env
157 %************************************************************************
159 Check whether a single family instance conflicts with those in two instance
160 environments (one for the EPS and one for the HPT).
163 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
164 checkForConflicts inst_envs famInst
165 = do { -- To instantiate the family instance type, extend the instance
166 -- envt with completely fresh template variables
167 -- This is important because the template variables must
168 -- not overlap with anything in the things being looked up
169 -- (since we do unification).
170 -- We use tcInstSkolType because we don't want to allocate
171 -- fresh *meta* type variables.
172 ; let { tycon = famInstTyCon famInst
173 ; ty = case tyConFamInst_maybe tycon of
174 Nothing -> panic "FamInst.checkForConflicts"
175 Just (tc, tys) -> tc `mkTyConApp` tys
177 ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
179 ; let (fam, tys') = tcSplitTyConApp tau'
181 ; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
182 ; conflicts = [ conflictingFamInst
183 | match@(conflictingFamInst, _) <- matches
184 , conflicting fam tys' tycon match
187 ; unless (null conflicts) $
188 conflictInstErr famInst (head conflicts)
191 -- In the case of data/newtype instances, any overlap is a conflict (as
192 -- these instances imply injective type mappings).
193 conflicting _ _ tycon _ | isAlgTyCon tycon = True
194 conflicting fam tys' tycon (subst, cFamInst) | otherwise =
195 panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing"
197 conflictInstErr famInst conflictingFamInst
198 = addFamInstLoc famInst $
199 addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
200 2 (pprFamInsts [famInst, conflictingFamInst]))
202 addFamInstLoc famInst thing_inside
203 = setSrcSpan (mkSrcSpan loc loc) thing_inside
205 loc = getSrcLoc famInst