1 The @FamInst@ type: family instance heads
5 -- The above warning supression flag is a temporary kludge.
6 -- While working on this module you are encouraged to remove it and fix
7 -- any warnings in the module. See
8 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 checkFamInstConsistency, tcExtendLocalFamInstEnv
15 #include "HsVersions.h"
36 %************************************************************************
38 Optimised overlap checking for family instances
40 %************************************************************************
42 For any two family instance modules that we import directly or indirectly, we
43 check whether the instances in the two modules are consistent, *unless* we can
44 be certain that the instances of the two modules have already been checked for
45 consistency during the compilation of modules that we import.
47 How do we know which pairs of modules have already been checked? Any pair of
48 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
49 `HscTypes.Dependencies') of one of our directly imported modules must have
50 already been checked. Everything else, we check now. (So that we can be
51 certain that the modules in our `HscTypes.dep_finsts' are consistent.)
54 -- The optimisation of overlap tests is based on determining pairs of modules
55 -- whose family instances need to be checked for consistency.
57 data ModulePair = ModulePair Module Module
59 -- canonical order of the components of a module pair
61 canon :: ModulePair -> (Module, Module)
62 canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
63 | otherwise = (m2, m1)
65 instance Eq ModulePair where
66 mp1 == mp2 = canon mp1 == canon mp2
68 instance Ord ModulePair where
69 mp1 `compare` mp2 = canon mp1 `compare` canon mp2
71 -- Sets of module pairs
73 type ModulePairSet = FiniteMap ModulePair ()
75 listToSet :: [ModulePair] -> ModulePairSet
76 listToSet l = listToFM (zip l (repeat ()))
78 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
79 checkFamInstConsistency famInstMods directlyImpMods
80 = do { dflags <- getDOpts
81 ; (eps, hpt) <- getEpsAndHpt
83 ; let { -- Fetch the iface of a given module. Must succeed as
84 -- all imported modules must already have been loaded.
86 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
87 Nothing -> panic "FamInst.checkFamInstConsistency"
90 ; hmiModule = mi_module . hm_iface
91 ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
92 ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
93 ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
95 ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
96 `extendModuleEnvList` -- plus
97 hptModInsts -- home package modules
98 ; groups = map (dep_finsts . mi_deps . modIface)
100 ; okPairs = listToSet $ concatMap allPairs groups
101 -- instances of okPairs are consistent
102 ; criticalPairs = listToSet $ allPairs famInstMods
103 -- all pairs that we need to consider
104 ; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs
105 -- the difference gives us the pairs we need to check now
108 ; mapM_ (check modInstsEnv) toCheckPairs
112 allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
114 -- The modules are guaranteed to be in the environment, as they are either
115 -- already loaded in the EPS or they are in the HPT.
117 check modInstsEnv (ModulePair m1 m2)
118 = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
119 ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
120 ; insts1 = famInstEnvElts instEnv1
123 mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
126 %************************************************************************
128 Extending the family instance environment
130 %************************************************************************
133 -- Add new locally-defined family instances
134 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
135 tcExtendLocalFamInstEnv fam_insts thing_inside
136 = do { env <- getGblEnv
137 ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
138 ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
139 tcg_fam_inst_env = inst_env' }
140 ; setGblEnv env' thing_inside
143 -- Check that the proposed new instance is OK,
144 -- and then add it to the home inst env
145 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
146 addLocalFamInst home_fie famInst
147 = do { -- Load imported instances, so that we report
148 -- overlaps correctly
150 ; let inst_envs = (eps_fam_inst_env eps, home_fie)
152 -- Check for conflicting instance decls
153 ; checkForConflicts inst_envs famInst
155 -- OK, now extend the envt
156 ; return (extendFamInstEnv home_fie famInst)
160 %************************************************************************
162 Checking an instance against conflicts with an instance env
164 %************************************************************************
166 Check whether a single family instance conflicts with those in two instance
167 environments (one for the EPS and one for the HPT).
170 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
171 checkForConflicts inst_envs famInst
172 = do { -- To instantiate the family instance type, extend the instance
173 -- envt with completely fresh template variables
174 -- This is important because the template variables must
175 -- not overlap with anything in the things being looked up
176 -- (since we do unification).
177 -- We use tcInstSkolType because we don't want to allocate
178 -- fresh *meta* type variables.
179 ; let { tycon = famInstTyCon famInst
180 ; ty = case tyConFamInst_maybe tycon of
181 Nothing -> panic "FamInst.checkForConflicts"
182 Just (tc, tys) -> tc `mkTyConApp` tys
184 ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
186 ; let (fam, tys') = tcSplitTyConApp tau'
188 ; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
189 ; conflicts = [ conflictingFamInst
190 | match@((conflictingFamInst, _), _) <- matches
191 , conflicting tycon match
194 ; unless (null conflicts) $
195 conflictInstErr famInst (head conflicts)
198 -- * In the case of data family instances, any overlap is fundamentally a
199 -- conflict (as these instances imply injective type mappings).
200 -- * In the case of type family instances, overlap is admitted as long as
201 -- the right-hand sides of the overlapping rules coincide under the
202 -- overlap substitution. We require that they are syntactically equal;
203 -- anything else would be difficult to test for at this stage.
204 conflicting tycon1 ((famInst2, _), subst)
205 | isAlgTyCon tycon1 = True
206 | otherwise = not (rhs1 `tcEqType` rhs2)
208 tycon2 = famInstTyCon famInst2
209 rhs1 = substTy subst $ synTyConType tycon1
210 rhs2 = substTy subst $ synTyConType tycon2
212 conflictInstErr famInst conflictingFamInst
213 = addFamInstLoc famInst $
214 addErr (hang (ptext SLIT("Conflicting family instance declarations:"))
215 2 (pprFamInsts [famInst, conflictingFamInst]))
217 addFamInstLoc famInst thing_inside
218 = setSrcSpan (mkSrcSpan loc loc) thing_inside
220 loc = getSrcLoc famInst