1 The @FamInst@ type: family instance heads
5 checkFamInstConsistency, tcExtendLocalFamInstEnv
27 %************************************************************************
29 Optimised overlap checking for family instances
31 %************************************************************************
33 For any two family instance modules that we import directly or indirectly, we
34 check whether the instances in the two modules are consistent, *unless* we can
35 be certain that the instances of the two modules have already been checked for
36 consistency during the compilation of modules that we import.
38 Why do we need to check? Consider
39 module X1 where module X2 where
41 type instance F T1 b = Int type instance F a T2 = Char
42 f1 :: F T1 a -> Int f2 :: Char -> F a T2
45 Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
46 Notice that neither instance is an orphan.
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 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
120 ; instEnv2 = (expectJust "checkFamInstConsistency") . 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.
181 ; skol_tvs <- tcInstSkolTyVars FamInstSkol (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