1 The @FamInst@ type: family instance heads
5 checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs
26 %************************************************************************
28 Optimised overlap checking for family instances
30 %************************************************************************
32 For any two family instance modules that we import directly or indirectly, we
33 check whether the instances in the two modules are consistent, *unless* we can
34 be certain that the instances of the two modules have already been checked for
35 consistency during the compilation of modules that we import.
37 Why do we need to check? Consider
38 module X1 where module X2 where
40 type instance F T1 b = Int type instance F a T2 = Char
41 f1 :: F T1 a -> Int f2 :: Char -> F a T2
44 Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
45 Notice that neither instance is an orphan.
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 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
119 ; instEnv2 = (expectJust "checkFamInstConsistency") . 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.
180 ; skol_tvs <- tcInstSkolTyVars FamInstSkol
181 (tyConTyVars (famInstTyCon famInst))
182 ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
183 ; unless (null conflicts) $
184 conflictInstErr famInst (fst (head conflicts))
188 conflictInstErr :: FamInst -> FamInst -> TcRn ()
189 conflictInstErr famInst conflictingFamInst
190 = addFamInstLoc famInst $
191 addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
192 2 (pprFamInsts [famInst, conflictingFamInst]))
194 addFamInstLoc :: FamInst -> TcRn a -> TcRn a
195 addFamInstLoc famInst thing_inside
196 = setSrcSpan (mkSrcSpan loc loc) thing_inside
198 loc = getSrcLoc famInst
203 tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
204 -- Gets both the external-package inst-env
205 -- and the home-pkg inst env (includes module being compiled)
207 = do { eps <- getEps; env <- getGblEnv
208 ; return (eps_fam_inst_env eps, tcg_fam_inst_env env)