2 % (c) The University of Glasgow 2006
5 FamInstEnv: Type checked family instance declarations
9 FamInst(..), famInstTyCon, famInstTyVars,
10 pprFamInst, pprFamInstHdr, pprFamInsts,
11 famInstHead, mkLocalFamInst, mkImportedFamInst,
13 FamInstEnvs, FamInstEnv, emptyFamInstEnv,
14 extendFamInstEnv, extendFamInstEnvList,
15 famInstEnvElts, familyInstances,
17 lookupFamInstEnv, lookupFamInstEnvUnify
20 #include "HsVersions.h"
40 %************************************************************************
42 \subsection{Type checked family instance heads}
44 %************************************************************************
48 = FamInst { fi_fam :: Name -- Family name
49 -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
50 -- Just (tc, tys) -> tc
52 -- Used for "rough matching"; same idea as for class instances
53 , fi_tcs :: [Maybe Name] -- Top of type args
54 -- INVARIANT: fi_tcs = roughMatchTcs is_tys
56 -- Used for "proper matching"; ditto
57 , fi_tvs :: TyVarSet -- Template tyvars for full match
58 , fi_tys :: [Type] -- Full arg types
59 -- INVARIANT: fi_tvs = tyConTyVars fi_tycon
60 -- fi_tys = case tyConFamInst_maybe fi_tycon of
61 -- Just (_, tys) -> tys
63 , fi_tycon :: TyCon -- Representation tycon
66 -- Obtain the representation tycon of a family instance.
68 famInstTyCon :: FamInst -> TyCon
69 famInstTyCon = fi_tycon
71 famInstTyVars = fi_tvs
75 instance NamedThing FamInst where
76 getName = getName . fi_tycon
78 instance Outputable FamInst where
81 -- Prints the FamInst as a family instance declaration
82 pprFamInst :: FamInst -> SDoc
84 = hang (pprFamInstHdr famInst)
85 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcLoc famInst)))
87 pprFamInstHdr :: FamInst -> SDoc
88 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
89 = pprTyConSort <+> pprHead
91 pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys
92 pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
93 | isNewTyCon tycon = ptext SLIT("newtype instance")
94 | isSynTyCon tycon = ptext SLIT("type instance")
95 | otherwise = panic "FamInstEnv.pprFamInstHdr"
97 pprFamInsts :: [FamInst] -> SDoc
98 pprFamInsts finsts = vcat (map pprFamInst finsts)
100 famInstHead :: FamInst -> ([TyVar], TyCon, [Type])
101 famInstHead (FamInst {fi_tycon = tycon})
102 = case tyConFamInst_maybe tycon of
103 Nothing -> panic "FamInstEnv.famInstHead"
104 Just (fam, tys) -> (tyConTyVars tycon, fam, tys)
106 -- Make a family instance representation from a tycon. This is used for local
107 -- instances, where we can safely pull on the tycon.
109 mkLocalFamInst :: TyCon -> FamInst
111 = case tyConFamInst_maybe tycon of
112 Nothing -> panic "FamInstEnv.mkLocalFamInst"
115 fi_fam = tyConName fam,
116 fi_tcs = roughMatchTcs tys,
117 fi_tvs = mkVarSet . tyConTyVars $ tycon,
122 -- Make a family instance representation from the information found in an
123 -- unterface file. In particular, we get the rough match info from the iface
124 -- (instead of computing it here).
126 mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst
127 mkImportedFamInst fam mb_tcs tycon
131 fi_tvs = mkVarSet . tyConTyVars $ tycon,
132 fi_tys = case tyConFamInst_maybe tycon of
133 Nothing -> panic "FamInstEnv.mkImportedFamInst"
134 Just (_, tys) -> tys,
140 %************************************************************************
144 %************************************************************************
146 InstEnv maps a family name to the list of known instances for that family.
149 type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances
151 type FamInstEnvs = (FamInstEnv, FamInstEnv)
152 -- External package inst-env, Home-package inst-env
155 = FamIE [FamInst] -- The instances for a particular family, in any order
156 Bool -- True <=> there is an instance of form T a b c
157 -- If *not* then the common case of looking up
158 -- (T a b c) can fail immediately
161 -- * The fs_tvs are distinct in each FamInst
162 -- of a range value of the map (so we can safely unify them)
164 emptyFamInstEnv :: FamInstEnv
165 emptyFamInstEnv = emptyUFM
167 famInstEnvElts :: FamInstEnv -> [FamInst]
168 famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts]
170 familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
171 familyInstances (pkg_fie, home_fie) fam
172 = get home_fie ++ get pkg_fie
174 get env = case lookupUFM env fam of
175 Just (FamIE insts _) -> insts
178 extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
179 extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
181 extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
182 extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
183 = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar)
185 add (FamIE items tyvar) _ = FamIE (ins_item:items)
187 ins_tyvar = not (any isJust mb_tcs)
190 %************************************************************************
192 \subsection{Looking up a family instance}
194 %************************************************************************
196 @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
197 Multiple matches are only possible in case of type families (not data
198 families), and then, it doesn't matter which match we choose (as the
199 instances are guaranteed confluent).
202 lookupFamInstEnv :: FamInstEnvs
203 -> TyCon -> [Type] -- What we are looking for
204 -> [(TvSubst, FamInst)] -- Successful matches
205 lookupFamInstEnv (pkg_ie, home_ie) fam tys
206 = home_matches ++ pkg_matches
208 rough_tcs = roughMatchTcs tys
209 all_tvs = all isNothing rough_tcs
210 home_matches = lookup home_ie
211 pkg_matches = lookup pkg_ie
214 lookup env = case lookupUFM env fam of
215 Nothing -> [] -- No instances for this class
216 Just (FamIE insts has_tv_insts)
217 -- Short cut for common case:
218 -- The thing we are looking up is of form (C a
219 -- b c), and the FamIE has no instances of
220 -- that form, so don't bother to search
221 | all_tvs && not has_tv_insts -> []
222 | otherwise -> find insts
226 find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
227 fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
228 -- Fast check for no match, uses the "rough match" fields
229 | instanceCantMatch rough_tcs mb_tcs
233 | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
234 = (subst, item) : find rest
236 -- No match => try next
241 While @lookupFamInstEnv@ uses a one-way match, the next function
242 @lookupFamInstEnvUnify@ uses two-way matching (ie, unification). This is
243 needed to check for overlapping instances.
245 For class instances, these two variants of lookup are combined into one
246 function (cf, @InstEnv@). We don't do that for family instances as the
247 results of matching and unification are used in two different contexts.
248 Moreover, matching is the wildly more frequently used operation in the case of
249 indexed synonyms and we don't want to slow that down by needless unification.
252 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
253 -> [(TvSubst, FamInst)]
254 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
255 = home_matches ++ pkg_matches
257 rough_tcs = roughMatchTcs tys
258 all_tvs = all isNothing rough_tcs
259 home_matches = lookup home_ie
260 pkg_matches = lookup pkg_ie
263 lookup env = case lookupUFM env fam of
264 Nothing -> [] -- No instances for this class
265 Just (FamIE insts has_tv_insts)
266 -- Short cut for common case:
267 -- The thing we are looking up is of form (C a
268 -- b c), and the FamIE has no instances of
269 -- that form, so don't bother to search
270 | all_tvs && not has_tv_insts -> []
271 | otherwise -> find insts
275 find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
276 fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
277 -- Fast check for no match, uses the "rough match" fields
278 | instanceCantMatch rough_tcs mb_tcs
282 = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
283 (ppr fam <+> ppr tys <+> ppr all_tvs) $$
284 (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys)
286 -- Unification will break badly if the variables overlap
287 -- They shouldn't because we allocate separate uniques for them
288 case tcUnifyTys bind_fn tpl_tys tys of
289 Just subst -> (subst, item) : find rest
292 -- See explanation at @InstEnv.bind_fn@.
294 bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem