1 The @FamInst@ type: family instance heads
5 checkFamInstConsistency, tcExtendLocalFamInstEnv
8 #include "HsVersions.h"
28 %************************************************************************
30 Optimised overlap checking for family instances
32 %************************************************************************
34 For any two family instance modules that we import directly or indirectly, we
35 check whether the instances in the two modules are consistent, *unless* we can
36 be certain that the instances of the two modules have already been checked for
37 consistency during the compilation of modules that we import.
39 How do we know which pairs of modules have already been checked? Any pair of
40 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
41 `HscTypes.Dependencies') of one of our directly imported modules must have
42 already been checked. Everything else, we check now. (So that we can be
43 certain that the modules in our `HscTypes.dep_finsts' are consistent.)
46 -- The optimisation of overlap tests is based on determining pairs of modules
47 -- whose family instances need to be checked for consistency.
49 data ModulePair = ModulePair Module Module
51 -- canonical order of the components of a module pair
53 canon :: ModulePair -> (Module, Module)
54 canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
55 | otherwise = (m2, m1)
57 instance Eq ModulePair where
58 mp1 == mp2 = canon mp1 == canon mp2
60 instance Ord ModulePair where
61 mp1 `compare` mp2 = canon mp1 `compare` canon mp2
63 -- Sets of module pairs
65 type ModulePairSet = FiniteMap ModulePair ()
67 listToSet l = listToFM (zip l (repeat ()))
69 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
70 checkFamInstConsistency famInstMods directlyImpMods
71 = do { dflags <- getDOpts
72 ; (eps, hpt) <- getEpsAndHpt
74 ; let { -- Fetch the iface of a given module. Must succeed as
75 -- all imported modules must already have been loaded.
77 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
78 Nothing -> panic "FamInst.checkFamInstConsistency"
81 ; modInstsEnv = eps_mod_fam_inst_env eps
82 ; groups = map (dep_finsts . mi_deps . modIface)
84 ; okPairs = listToSet $ concatMap allPairs groups
85 -- instances of okPairs are consistent
86 ; criticalPairs = listToSet $ allPairs famInstMods
87 -- all pairs that we need to consider
88 ; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs
89 -- the difference gives us the pairs we need to check now
92 ; mapM_ (check modInstsEnv) toCheckPairs
96 allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
98 -- Check the consistency of the family instances of the two modules.
99 check modInstsEnv (ModulePair m1 m2)
100 = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
101 ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
102 ; insts1 = famInstEnvElts instEnv1
105 mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
108 %************************************************************************
110 Extending the family instance environment
112 %************************************************************************
115 -- Add new locally-defined family instances
116 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
117 tcExtendLocalFamInstEnv fam_insts thing_inside
118 = do { env <- getGblEnv
119 ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
120 ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
121 tcg_fam_inst_env = inst_env' }
122 ; setGblEnv env' thing_inside
125 -- Check that the proposed new instance is OK,
126 -- and then add it to the home inst env
127 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
128 addLocalFamInst home_fie famInst
129 = do { -- Load imported instances, so that we report
130 -- overlaps correctly
132 ; let inst_envs = (eps_fam_inst_env eps, home_fie)
134 -- Check for conflicting instance decls
135 ; checkForConflicts inst_envs famInst
137 -- OK, now extend the envt
138 ; return (extendFamInstEnv home_fie famInst)
142 %************************************************************************
144 Checking an instance against conflicts with an instance env
146 %************************************************************************
148 Check whether a single family instance conflicts with those in two instance
149 environments (one for the EPS and one for the HPT).
152 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
153 checkForConflicts inst_envs famInst
154 = do { -- To instantiate the family instance type, extend the instance
155 -- envt with completely fresh template variables
156 -- This is important because the template variables must
157 -- not overlap with anything in the things being looked up
158 -- (since we do unification).
159 -- We use tcInstSkolType because we don't want to allocate
160 -- fresh *meta* type variables.
161 ; let { tycon = famInstTyCon famInst
162 ; ty = case tyConFamInst_maybe tycon of
163 Nothing -> panic "FamInst.checkForConflicts"
164 Just (tc, tys) -> tc `mkTyConApp` tys
166 ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
168 ; let (fam, tys') = tcSplitTyConApp tau'
170 ; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
171 ; conflicts = [ conflictingFamInst
172 | match@(_, conflictingFamInst) <- matches
173 , conflicting fam tys' tycon match
176 ; unless (null conflicts) $
177 conflictInstErr famInst (head conflicts)
180 -- In the case of data/newtype instances, any overlap is a conflict (as
181 -- these instances imply injective type mappings).
182 conflicting _ _ tycon _ | isAlgTyCon tycon = True
183 conflicting fam tys' tycon (subst, cFamInst) | otherwise =
184 panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing"
186 conflictInstErr famInst conflictingFamInst
187 = addFamInstLoc famInst $
188 addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
189 2 (pprFamInsts [famInst, conflictingFamInst]))
191 addFamInstLoc famInst thing_inside
192 = setSrcSpan (mkSrcSpan loc loc) thing_inside
194 loc = getSrcLoc famInst