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
35 %************************************************************************
37 Optimised overlap checking for family instances
39 %************************************************************************
41 For any two family instance modules that we import directly or indirectly, we
42 check whether the instances in the two modules are consistent, *unless* we can
43 be certain that the instances of the two modules have already been checked for
44 consistency during the compilation of modules that we import.
46 How do we know which pairs of modules have already been checked? Any pair of
47 modules where both modules occur in the `HscTypes.dep_finsts' set (of the
48 `HscTypes.Dependencies') of one of our directly imported modules must have
49 already been checked. Everything else, we check now. (So that we can be
50 certain that the modules in our `HscTypes.dep_finsts' are consistent.)
53 -- The optimisation of overlap tests is based on determining pairs of modules
54 -- whose family instances need to be checked for consistency.
56 data ModulePair = ModulePair Module Module
58 -- canonical order of the components of a module pair
60 canon :: ModulePair -> (Module, Module)
61 canon (ModulePair m1 m2) | m1 < m2 = (m1, m2)
62 | otherwise = (m2, m1)
64 instance Eq ModulePair where
65 mp1 == mp2 = canon mp1 == canon mp2
67 instance Ord ModulePair where
68 mp1 `compare` mp2 = canon mp1 `compare` canon mp2
70 -- Sets of module pairs
72 type ModulePairSet = FiniteMap ModulePair ()
74 listToSet :: [ModulePair] -> ModulePairSet
75 listToSet l = listToFM (zip l (repeat ()))
77 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
78 checkFamInstConsistency famInstMods directlyImpMods
79 = do { dflags <- getDOpts
80 ; (eps, hpt) <- getEpsAndHpt
82 ; let { -- Fetch the iface of a given module. Must succeed as
83 -- all imported modules must already have been loaded.
85 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
86 Nothing -> panic "FamInst.checkFamInstConsistency"
89 ; hmiModule = mi_module . hm_iface
90 ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
91 ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
92 ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
94 ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
95 `extendModuleEnvList` -- plus
96 hptModInsts -- home package modules
97 ; groups = map (dep_finsts . mi_deps . modIface)
99 ; okPairs = listToSet $ concatMap allPairs groups
100 -- instances of okPairs are consistent
101 ; criticalPairs = listToSet $ allPairs famInstMods
102 -- all pairs that we need to consider
103 ; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs
104 -- the difference gives us the pairs we need to check now
107 ; mapM_ (check modInstsEnv) toCheckPairs
111 allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
113 -- The modules are guaranteed to be in the environment, as they are either
114 -- already loaded in the EPS or they are in the HPT.
116 check modInstsEnv (ModulePair m1 m2)
117 = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1
118 ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2
119 ; insts1 = famInstEnvElts instEnv1
122 mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
125 %************************************************************************
127 Extending the family instance environment
129 %************************************************************************
132 -- Add new locally-defined family instances
133 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
134 tcExtendLocalFamInstEnv fam_insts thing_inside
135 = do { env <- getGblEnv
136 ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
137 ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
138 tcg_fam_inst_env = inst_env' }
139 ; setGblEnv env' thing_inside
142 -- Check that the proposed new instance is OK,
143 -- and then add it to the home inst env
144 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
145 addLocalFamInst home_fie famInst
146 = do { -- Load imported instances, so that we report
147 -- overlaps correctly
149 ; let inst_envs = (eps_fam_inst_env eps, home_fie)
151 -- Check for conflicting instance decls
152 ; checkForConflicts inst_envs famInst
154 -- OK, now extend the envt
155 ; return (extendFamInstEnv home_fie famInst)
159 %************************************************************************
161 Checking an instance against conflicts with an instance env
163 %************************************************************************
165 Check whether a single family instance conflicts with those in two instance
166 environments (one for the EPS and one for the HPT).
169 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
170 checkForConflicts inst_envs famInst
171 = do { -- To instantiate the family instance type, extend the instance
172 -- envt with completely fresh template variables
173 -- This is important because the template variables must
174 -- not overlap with anything in the things being looked up
175 -- (since we do unification).
176 -- We use tcInstSkolType because we don't want to allocate
177 -- fresh *meta* type variables.
178 ; let { tycon = famInstTyCon famInst
179 ; ty = case tyConFamInst_maybe tycon of
180 Nothing -> panic "FamInst.checkForConflicts"
181 Just (tc, tys) -> tc `mkTyConApp` tys
183 ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty
185 ; let (fam, tys') = tcSplitTyConApp tau'
187 ; let { matches = lookupFamInstEnvUnify inst_envs fam tys'
188 ; conflicts = [ conflictingFamInst
189 | match@((conflictingFamInst, _), _) <- matches
190 , conflicting tycon match
193 ; unless (null conflicts) $
194 conflictInstErr famInst (head conflicts)
197 -- * In the case of data family instances, any overlap is fundamentally a
198 -- conflict (as these instances imply injective type mappings).
199 -- * In the case of type family instances, overlap is admitted as long as
200 -- the right-hand sides of the overlapping rules coincide under the
201 -- overlap substitution. We require that they are syntactically equal;
202 -- anything else would be difficult to test for at this stage.
203 conflicting tycon1 ((famInst2, _), subst)
204 | isAlgTyCon tycon1 = True
205 | otherwise = not (rhs1 `tcEqType` rhs2)
207 tycon2 = famInstTyCon famInst2
208 rhs1 = substTy subst $ synTyConType tycon1
209 rhs2 = substTy subst $ synTyConType tycon2
211 conflictInstErr famInst conflictingFamInst
212 = addFamInstLoc famInst $
213 addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
214 2 (pprFamInsts [famInst, conflictingFamInst]))
216 addFamInstLoc famInst thing_inside
217 = setSrcSpan (mkSrcSpan loc loc) thing_inside
219 loc = getSrcLoc famInst