1 The @FamInst@ type: family instance heads
5 checkFamInstConsistency, tcExtendLocalFamInstEnv
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 Why do we need to check? Consider
40 module X1 where module X2 where
42 type instance F T1 b = Int type instance F a T2 = Char
43 f1 :: F T1 a -> Int f2 :: Char -> F a T2
46 Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
47 Notice that neither instance is an orphan.
49 How do we know which pairs of modules have already been checked? Any pair of
50 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
51 `HscTypes.Dependencies') of one of our directly imported modules must have
52 already been checked. Everything else, we check now. (So that we can be
53 certain that the modules in our `HscTypes.dep_finsts' are consistent.)
56 -- The optimisation of overlap tests is based on determining pairs of modules
57 -- whose family instances need to be checked for consistency.
59 data ModulePair = ModulePair Module Module
61 -- canonical order of the components of a module pair
63 canon :: ModulePair -> (Module, Module)
64 canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
65 | otherwise = (m2, m1)
67 instance Eq ModulePair where
68 mp1 == mp2 = canon mp1 == canon mp2
70 instance Ord ModulePair where
71 mp1 `compare` mp2 = canon mp1 `compare` canon mp2
73 -- Sets of module pairs
75 type ModulePairSet = FiniteMap ModulePair ()
77 listToSet :: [ModulePair] -> ModulePairSet
78 listToSet l = listToFM (zip l (repeat ()))
80 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
81 checkFamInstConsistency famInstMods directlyImpMods
82 = do { dflags <- getDOpts
83 ; (eps, hpt) <- getEpsAndHpt
85 ; let { -- Fetch the iface of a given module. Must succeed as
86 -- all imported modules must already have been loaded.
88 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
89 Nothing -> panic "FamInst.checkFamInstConsistency"
92 ; hmiModule = mi_module . hm_iface
93 ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
94 ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
95 ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
97 ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
98 `extendModuleEnvList` -- plus
99 hptModInsts -- home package modules
100 ; groups = map (dep_finsts . mi_deps . modIface)
102 ; okPairs = listToSet $ concatMap allPairs groups
103 -- instances of okPairs are consistent
104 ; criticalPairs = listToSet $ allPairs famInstMods
105 -- all pairs that we need to consider
106 ; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs
107 -- the difference gives us the pairs we need to check now
110 ; mapM_ (check modInstsEnv) toCheckPairs
114 allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
116 -- The modules are guaranteed to be in the environment, as they are either
117 -- already loaded in the EPS or they are in the HPT.
119 check modInstsEnv (ModulePair m1 m2)
120 = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
121 ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2
122 ; insts1 = famInstEnvElts instEnv1
125 mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
128 %************************************************************************
130 Extending the family instance environment
132 %************************************************************************
135 -- Add new locally-defined family instances
136 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
137 tcExtendLocalFamInstEnv fam_insts thing_inside
138 = do { env <- getGblEnv
139 ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
140 ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
141 tcg_fam_inst_env = inst_env' }
142 ; setGblEnv env' thing_inside
145 -- Check that the proposed new instance is OK,
146 -- and then add it to the home inst env
147 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
148 addLocalFamInst home_fie famInst
149 = do { -- Load imported instances, so that we report
150 -- overlaps correctly
152 ; let inst_envs = (eps_fam_inst_env eps, home_fie)
154 -- Check for conflicting instance decls
155 ; checkForConflicts inst_envs famInst
157 -- OK, now extend the envt
158 ; return (extendFamInstEnv home_fie famInst)
162 %************************************************************************
164 Checking an instance against conflicts with an instance env
166 %************************************************************************
168 Check whether a single family instance conflicts with those in two instance
169 environments (one for the EPS and one for the HPT).
172 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
173 checkForConflicts inst_envs famInst
174 = do { -- To instantiate the family instance type, extend the instance
175 -- envt with completely fresh template variables
176 -- This is important because the template variables must
177 -- not overlap with anything in the things being looked up
178 -- (since we do unification).
179 -- We use tcInstSkolType because we don't want to allocate
180 -- fresh *meta* type variables.
181 ; let { tycon = famInstTyCon famInst
182 ; ty = case tyConFamInst_maybe tycon of
183 Nothing -> panic "FamInst.checkForConflicts"
184 Just (tc, tys) -> tc `mkTyConApp` tys
186 ; (_, _, tau') <- tcInstSkolType FamInstSkol ty
188 ; let (fam, tys') = tcSplitTyConApp tau'
190 ; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
191 ; conflicts = [ conflictingFamInst
192 | match@((conflictingFamInst, _), _) <- matches
193 , conflicting tycon match
196 ; unless (null conflicts) $
197 conflictInstErr famInst (head conflicts)
200 -- - In the case of data family instances, any overlap is fundamentally a
201 -- conflict (as these instances imply injective type mappings).
202 -- - In the case of type family instances, overlap is admitted as long as
203 -- the right-hand sides of the overlapping rules coincide under the
204 -- overlap substitution. We require that they are syntactically equal;
205 -- anything else would be difficult to test for at this stage.
206 conflicting tycon1 ((famInst2, _), subst)
207 | isAlgTyCon tycon1 = True
208 | otherwise = not (rhs1 `tcEqType` rhs2)
210 tycon2 = famInstTyCon famInst2
211 rhs1 = substTy subst $ synTyConType tycon1
212 rhs2 = substTy subst $ synTyConType tycon2
214 conflictInstErr :: FamInst -> FamInst -> TcRn ()
215 conflictInstErr famInst conflictingFamInst
216 = addFamInstLoc famInst $
217 addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
218 2 (pprFamInsts [famInst, conflictingFamInst]))
220 addFamInstLoc :: FamInst -> TcRn a -> TcRn a
221 addFamInstLoc famInst thing_inside
222 = setSrcSpan (mkSrcSpan loc loc) thing_inside
224 loc = getSrcLoc famInst