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