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, emptyFamInstEnvs,
14 extendFamInstEnv, extendFamInstEnvList,
15 famInstEnvElts, familyInstances,
17 lookupFamInstEnv, lookupFamInstEnvUnify,
23 #include "HsVersions.h"
47 %************************************************************************
49 \subsection{Type checked family instance heads}
51 %************************************************************************
55 = FamInst { fi_fam :: Name -- Family name
56 -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
57 -- Just (tc, tys) -> tc
59 -- Used for "rough matching"; same idea as for class instances
60 , fi_tcs :: [Maybe Name] -- Top of type args
61 -- INVARIANT: fi_tcs = roughMatchTcs fi_tys
63 -- Used for "proper matching"; ditto
64 , fi_tvs :: TyVarSet -- Template tyvars for full match
65 , fi_tys :: [Type] -- Full arg types
66 -- INVARIANT: fi_tvs = tyConTyVars fi_tycon
67 -- fi_tys = case tyConFamInst_maybe fi_tycon of
68 -- Just (_, tys) -> tys
70 , fi_tycon :: TyCon -- Representation tycon
73 -- Obtain the representation tycon of a family instance.
75 famInstTyCon :: FamInst -> TyCon
76 famInstTyCon = fi_tycon
78 famInstTyVars = fi_tvs
82 instance NamedThing FamInst where
83 getName = getName . fi_tycon
85 instance Outputable FamInst where
88 -- Prints the FamInst as a family instance declaration
89 pprFamInst :: FamInst -> SDoc
91 = hang (pprFamInstHdr famInst)
92 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan famInst)))
94 pprFamInstHdr :: FamInst -> SDoc
95 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
96 = pprTyConSort <+> pprHead
98 pprHead = pprTypeApp fam (ppr fam) tys
99 pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
100 | isNewTyCon tycon = ptext SLIT("newtype instance")
101 | isSynTyCon tycon = ptext SLIT("type instance")
102 | otherwise = panic "FamInstEnv.pprFamInstHdr"
104 pprFamInsts :: [FamInst] -> SDoc
105 pprFamInsts finsts = vcat (map pprFamInst finsts)
107 famInstHead :: FamInst -> ([TyVar], TyCon, [Type])
108 famInstHead (FamInst {fi_tycon = tycon})
109 = case tyConFamInst_maybe tycon of
110 Nothing -> panic "FamInstEnv.famInstHead"
111 Just (fam, tys) -> (tyConTyVars tycon, fam, tys)
113 -- Make a family instance representation from a tycon. This is used for local
114 -- instances, where we can safely pull on the tycon.
116 mkLocalFamInst :: TyCon -> FamInst
118 = case tyConFamInst_maybe tycon of
119 Nothing -> panic "FamInstEnv.mkLocalFamInst"
122 fi_fam = tyConName fam,
123 fi_tcs = roughMatchTcs tys,
124 fi_tvs = mkVarSet . tyConTyVars $ tycon,
129 -- Make a family instance representation from the information found in an
130 -- unterface file. In particular, we get the rough match info from the iface
131 -- (instead of computing it here).
133 mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst
134 mkImportedFamInst fam mb_tcs tycon
138 fi_tvs = mkVarSet . tyConTyVars $ tycon,
139 fi_tys = case tyConFamInst_maybe tycon of
140 Nothing -> panic "FamInstEnv.mkImportedFamInst"
141 Just (_, tys) -> tys,
147 %************************************************************************
151 %************************************************************************
153 InstEnv maps a family name to the list of known instances for that family.
156 type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances
158 type FamInstEnvs = (FamInstEnv, FamInstEnv)
159 -- External package inst-env, Home-package inst-env
162 = FamIE [FamInst] -- The instances for a particular family, in any order
163 Bool -- True <=> there is an instance of form T a b c
164 -- If *not* then the common case of looking up
165 -- (T a b c) can fail immediately
168 -- * The fs_tvs are distinct in each FamInst
169 -- of a range value of the map (so we can safely unify them)
171 emptyFamInstEnvs :: (FamInstEnv, FamInstEnv)
172 emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)
174 emptyFamInstEnv :: FamInstEnv
175 emptyFamInstEnv = emptyUFM
177 famInstEnvElts :: FamInstEnv -> [FamInst]
178 famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts]
180 familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
181 familyInstances (pkg_fie, home_fie) fam
182 = get home_fie ++ get pkg_fie
184 get env = case lookupUFM env fam of
185 Just (FamIE insts _) -> insts
188 extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
189 extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
191 extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
192 extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
193 = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar)
195 add (FamIE items tyvar) _ = FamIE (ins_item:items)
197 ins_tyvar = not (any isJust mb_tcs)
200 %************************************************************************
202 Looking up a family instance
204 %************************************************************************
206 @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
207 Multiple matches are only possible in case of type families (not data
208 families), and then, it doesn't matter which match we choose (as the
209 instances are guaranteed confluent).
211 We return the matching family instances and the type instance at which it
212 matches. For example, if we lookup 'T [Int]' and have a family instance
214 data instance T [a] = ..
219 coe :Co:R42T a :: T [a] ~ :R42T a
221 we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.
224 type FamInstMatch = (FamInst, [Type]) -- Matching type instance
226 lookupFamInstEnv :: FamInstEnvs
227 -> TyCon -> [Type] -- What we are looking for
228 -> [FamInstMatch] -- Successful matches
229 lookupFamInstEnv (pkg_ie, home_ie) fam tys
230 | not (isOpenTyCon fam)
233 = home_matches ++ pkg_matches
235 rough_tcs = roughMatchTcs tys
236 all_tvs = all isNothing rough_tcs
237 home_matches = lookup home_ie
238 pkg_matches = lookup pkg_ie
241 lookup env = case lookupUFM env fam of
242 Nothing -> [] -- No instances for this class
243 Just (FamIE insts has_tv_insts)
244 -- Short cut for common case:
245 -- The thing we are looking up is of form (C a
246 -- b c), and the FamIE has no instances of
247 -- that form, so don't bother to search
248 | all_tvs && not has_tv_insts -> []
249 | otherwise -> find insts
253 find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
254 fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
255 -- Fast check for no match, uses the "rough match" fields
256 | instanceCantMatch rough_tcs mb_tcs
260 | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
261 = (item, substTyVars subst (tyConTyVars tycon)) : find rest
263 -- No match => try next
268 While @lookupFamInstEnv@ uses a one-way match, the next function
269 @lookupFamInstEnvUnify@ uses two-way matching (ie, unification). This is
270 needed to check for overlapping instances.
272 For class instances, these two variants of lookup are combined into one
273 function (cf, @InstEnv@). We don't do that for family instances as the
274 results of matching and unification are used in two different contexts.
275 Moreover, matching is the wildly more frequently used operation in the case of
276 indexed synonyms and we don't want to slow that down by needless unification.
279 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
281 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
282 | not (isOpenTyCon fam)
285 = home_matches ++ pkg_matches
287 rough_tcs = roughMatchTcs tys
288 all_tvs = all isNothing rough_tcs
289 home_matches = lookup home_ie
290 pkg_matches = lookup pkg_ie
293 lookup env = case lookupUFM env fam of
294 Nothing -> [] -- No instances for this class
295 Just (FamIE insts has_tv_insts)
296 -- Short cut for common case:
297 -- The thing we are looking up is of form (C a
298 -- b c), and the FamIE has no instances of
299 -- that form, so don't bother to search
300 | all_tvs && not has_tv_insts -> []
301 | otherwise -> find insts
305 find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
306 fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
307 -- Fast check for no match, uses the "rough match" fields
308 | instanceCantMatch rough_tcs mb_tcs
312 = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
313 (ppr fam <+> ppr tys <+> ppr all_tvs) $$
314 (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys)
316 -- Unification will break badly if the variables overlap
317 -- They shouldn't because we allocate separate uniques for them
318 case tcUnifyTys bind_fn tpl_tys tys of
319 Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon)
321 (item, rep_tys) : find rest
324 -- See explanation at @InstEnv.bind_fn@.
326 bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
330 %************************************************************************
332 Looking up a family instance
334 %************************************************************************
337 topNormaliseType :: FamInstEnvs
339 -> Maybe (Coercion, Type)
341 -- Get rid of *outermost* (or toplevel) type functions by rewriting them
342 -- By "outer" we mean that toplevelNormaliseType guarantees to return
343 -- a type that does not have a reducible redex (F ty1 .. tyn) as its
344 -- outermost form. It *can* return something like (Maybe (F ty)), where
345 -- (F ty) is a redex.
347 topNormaliseType env ty
348 | Just ty' <- tcView ty = topNormaliseType env ty'
350 topNormaliseType env ty@(TyConApp tc tys)
352 , (ACo co, ty) <- normaliseType env ty
355 topNormaliseType env ty
359 normaliseType :: FamInstEnvs -- environment with family instances
361 -> (CoercionI,Type) -- (coercion,new type), where
362 -- co :: old-type ~ new_type
363 -- Normalise the input type, by eliminating all type-function redexes
366 | Just ty' <- coreView ty = normaliseType env ty'
368 normaliseType env ty@(TyConApp tyCon tys)
369 = let -- First normalise the arg types
370 (cois, ntys) = mapAndUnzip (normaliseType env) tys
371 tycon_coi = mkTyConAppCoI tyCon ntys cois
372 in -- Now try the top-level redex
373 case lookupFamInstEnv env tyCon ntys of
374 -- A matching family instance exists
375 [(fam_inst, tys)] -> (fix_coi, nty)
377 rep_tc = famInstTyCon fam_inst
378 co_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
379 co = mkTyConApp co_tycon tys
380 first_coi = mkTransCoI tycon_coi (ACo co)
381 (rest_coi,nty) = normaliseType env (mkTyConApp rep_tc tys)
382 fix_coi = mkTransCoI first_coi rest_coi
384 -- No unique matching family instance exists;
385 -- we do not do anything
386 other -> (tycon_coi, TyConApp tyCon ntys)
390 normaliseType env ty@(AppTy ty1 ty2)
391 = let (coi1,nty1) = normaliseType env ty1
392 (coi2,nty2) = normaliseType env ty2
393 in (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2)
394 normaliseType env ty@(FunTy ty1 ty2)
395 = let (coi1,nty1) = normaliseType env ty1
396 (coi2,nty2) = normaliseType env ty2
397 in (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2)
398 normaliseType env ty@(ForAllTy tyvar ty1)
399 = let (coi,nty1) = normaliseType env ty1
400 in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
401 normaliseType env ty@(NoteTy note ty1)
402 = let (coi,nty1) = normaliseType env ty1
403 in (mkNoteTyCoI note coi,NoteTy note nty1)
404 normaliseType env ty@(TyVarTy _)
406 normaliseType env (PredTy predty)
407 = normalisePred env predty
409 normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
410 normalisePred env (ClassP cls tys)
411 = let (cois,tys') = mapAndUnzip (normaliseType env) tys
412 in (mkClassPPredCoI cls tys' cois, PredTy $ ClassP cls tys')
413 normalisePred env (IParam ipn ty)
414 = let (coi,ty') = normaliseType env ty
415 in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
416 normalisePred env (EqPred ty1 ty2)
417 = let (coi1,ty1') = normaliseType env ty1
418 (coi2,ty2') = normaliseType env ty2
419 in (mkEqPredCoI ty1' coi1 ty2' coi2, PredTy $ EqPred ty1' ty2')