1 The @FamInst@ type: family instance heads
5 checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs
24 import qualified Data.Map as Map
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 = Map ModulePair ()
77 listToSet :: [ModulePair] -> ModulePairSet
78 listToSet l = Map.fromList (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 directly 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 = extendFamInstEnvList emptyFamInstEnv
94 . md_fam_insts . hm_details
95 ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
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 = Map.keys $ criticalPairs `Map.difference` okPairs
104 -- the difference gives us the pairs we need to check now
107 ; mapM_ (check hpt_fam_insts) toCheckPairs
111 allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
113 check hpt_fam_insts (ModulePair m1 m2)
114 = do { env1 <- getFamInsts hpt_fam_insts m1
115 ; env2 <- getFamInsts hpt_fam_insts m2
116 ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))
117 (famInstEnvElts env1) }
119 getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
120 getFamInsts hpt_fam_insts mod
121 | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
122 | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
124 ; return (expectJust "checkFamInstConsistency" $
125 lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
127 doc = ppr mod <+> ptext (sLit "is a family-instance module")
130 %************************************************************************
132 Extending the family instance environment
134 %************************************************************************
137 -- Add new locally-defined family instances
138 tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
139 tcExtendLocalFamInstEnv fam_insts thing_inside
140 = do { env <- getGblEnv
141 ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
142 ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env,
143 tcg_fam_inst_env = inst_env' }
144 ; setGblEnv env' thing_inside
147 -- Check that the proposed new instance is OK,
148 -- and then add it to the home inst env
149 addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv
150 addLocalFamInst home_fie famInst
151 = do { -- Load imported instances, so that we report
152 -- overlaps correctly
154 ; let inst_envs = (eps_fam_inst_env eps, home_fie)
156 -- Check for conflicting instance decls
157 ; checkForConflicts inst_envs famInst
159 -- OK, now extend the envt
160 ; return (extendFamInstEnv home_fie famInst)
164 %************************************************************************
166 Checking an instance against conflicts with an instance env
168 %************************************************************************
170 Check whether a single family instance conflicts with those in two instance
171 environments (one for the EPS and one for the HPT).
174 checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
175 checkForConflicts inst_envs famInst
176 = do { -- To instantiate the family instance type, extend the instance
177 -- envt with completely fresh template variables
178 -- This is important because the template variables must
179 -- not overlap with anything in the things being looked up
180 -- (since we do unification).
181 -- We use tcInstSkolType because we don't want to allocate
182 -- fresh *meta* type variables.
184 ; skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst))
185 ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
186 ; unless (null conflicts) $
187 conflictInstErr famInst (fst (head conflicts))
191 conflictInstErr :: FamInst -> FamInst -> TcRn ()
192 conflictInstErr famInst conflictingFamInst
193 = addFamInstLoc famInst $
194 addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
195 2 (pprFamInsts [famInst, conflictingFamInst]))
197 addFamInstLoc :: FamInst -> TcRn a -> TcRn a
198 addFamInstLoc famInst thing_inside
199 = setSrcSpan (mkSrcSpan loc loc) thing_inside
201 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) }