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"
44 %************************************************************************
46 \subsection{Type checked family instance heads}
48 %************************************************************************
52 = FamInst { fi_fam :: Name -- Family name
53 -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
54 -- Just (tc, tys) -> tc
56 -- Used for "rough matching"; same idea as for class instances
57 , fi_tcs :: [Maybe Name] -- Top of type args
58 -- INVARIANT: fi_tcs = roughMatchTcs fi_tys
60 -- Used for "proper matching"; ditto
61 , fi_tvs :: TyVarSet -- Template tyvars for full match
62 , fi_tys :: [Type] -- Full arg types
63 -- INVARIANT: fi_tvs = tyConTyVars fi_tycon
64 -- fi_tys = case tyConFamInst_maybe fi_tycon of
65 -- Just (_, tys) -> tys
67 , fi_tycon :: TyCon -- Representation tycon
70 -- Obtain the representation tycon of a family instance.
72 famInstTyCon :: FamInst -> TyCon
73 famInstTyCon = fi_tycon
75 famInstTyVars :: FamInst -> TyVarSet
76 famInstTyVars = fi_tvs
80 instance NamedThing FamInst where
81 getName = getName . fi_tycon
83 instance Outputable FamInst where
86 -- Prints the FamInst as a family instance declaration
87 pprFamInst :: FamInst -> SDoc
89 = hang (pprFamInstHdr famInst)
90 2 (ptext (sLit "--") <+> pprNameLoc (getName famInst))
92 pprFamInstHdr :: FamInst -> SDoc
93 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
94 = pprTyConSort <+> pprHead
96 pprHead = pprTypeApp fam tys
97 pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance")
98 | isNewTyCon tycon = ptext (sLit "newtype instance")
99 | isSynTyCon tycon = ptext (sLit "type instance")
100 | otherwise = panic "FamInstEnv.pprFamInstHdr"
102 pprFamInsts :: [FamInst] -> SDoc
103 pprFamInsts finsts = vcat (map pprFamInst finsts)
105 famInstHead :: FamInst -> ([TyVar], TyCon, [Type])
106 famInstHead (FamInst {fi_tycon = tycon})
107 = case tyConFamInst_maybe tycon of
108 Nothing -> panic "FamInstEnv.famInstHead"
109 Just (fam, tys) -> (tyConTyVars tycon, fam, tys)
111 -- Make a family instance representation from a tycon. This is used for local
112 -- instances, where we can safely pull on the tycon.
114 mkLocalFamInst :: TyCon -> FamInst
116 = case tyConFamInst_maybe tycon of
117 Nothing -> panic "FamInstEnv.mkLocalFamInst"
120 fi_fam = tyConName fam,
121 fi_tcs = roughMatchTcs tys,
122 fi_tvs = mkVarSet . tyConTyVars $ tycon,
127 -- Make a family instance representation from the information found in an
128 -- unterface file. In particular, we get the rough match info from the iface
129 -- (instead of computing it here).
131 mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst
132 mkImportedFamInst fam mb_tcs tycon
136 fi_tvs = mkVarSet . tyConTyVars $ tycon,
137 fi_tys = case tyConFamInst_maybe tycon of
138 Nothing -> panic "FamInstEnv.mkImportedFamInst"
139 Just (_, tys) -> tys,
145 %************************************************************************
149 %************************************************************************
151 InstEnv maps a family name to the list of known instances for that family.
154 type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances
156 type FamInstEnvs = (FamInstEnv, FamInstEnv)
157 -- External package inst-env, Home-package inst-env
160 = FamIE [FamInst] -- The instances for a particular family, in any order
161 Bool -- True <=> there is an instance of form T a b c
162 -- If *not* then the common case of looking up
163 -- (T a b c) can fail immediately
166 -- * The fs_tvs are distinct in each FamInst
167 -- of a range value of the map (so we can safely unify them)
169 emptyFamInstEnvs :: (FamInstEnv, FamInstEnv)
170 emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)
172 emptyFamInstEnv :: FamInstEnv
173 emptyFamInstEnv = emptyUFM
175 famInstEnvElts :: FamInstEnv -> [FamInst]
176 famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts]
178 familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
179 familyInstances (pkg_fie, home_fie) fam
180 = get home_fie ++ get pkg_fie
182 get env = case lookupUFM env fam of
183 Just (FamIE insts _) -> insts
186 extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
187 extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
189 extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
190 extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
191 = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar)
193 add (FamIE items tyvar) _ = FamIE (ins_item:items)
195 ins_tyvar = not (any isJust mb_tcs)
198 %************************************************************************
200 Looking up a family instance
202 %************************************************************************
204 @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
205 Multiple matches are only possible in case of type families (not data
206 families), and then, it doesn't matter which match we choose (as the
207 instances are guaranteed confluent).
209 We return the matching family instances and the type instance at which it
210 matches. For example, if we lookup 'T [Int]' and have a family instance
212 data instance T [a] = ..
217 coe :Co:R42T a :: T [a] ~ :R42T a
219 we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.
222 type FamInstMatch = (FamInst, [Type]) -- Matching type instance
224 lookupFamInstEnv :: FamInstEnvs
225 -> TyCon -> [Type] -- What we are looking for
226 -> [FamInstMatch] -- Successful matches
227 lookupFamInstEnv (pkg_ie, home_ie) fam tys
228 | not (isOpenTyCon fam)
231 = home_matches ++ pkg_matches
233 rough_tcs = roughMatchTcs tys
234 all_tvs = all isNothing rough_tcs
235 home_matches = lookup home_ie
236 pkg_matches = lookup pkg_ie
239 lookup env = case lookupUFM env fam of
240 Nothing -> [] -- No instances for this class
241 Just (FamIE insts has_tv_insts)
242 -- Short cut for common case:
243 -- The thing we are looking up is of form (C a
244 -- b c), and the FamIE has no instances of
245 -- that form, so don't bother to search
246 | all_tvs && not has_tv_insts -> []
247 | otherwise -> find insts
251 find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
252 fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
253 -- Fast check for no match, uses the "rough match" fields
254 | instanceCantMatch rough_tcs mb_tcs
258 | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
259 = (item, substTyVars subst (tyConTyVars tycon)) : find rest
261 -- No match => try next
266 While @lookupFamInstEnv@ uses a one-way match, the next function
267 @lookupFamInstEnvUnify@ uses two-way matching (ie, unification). This is
268 needed to check for overlapping instances.
270 For class instances, these two variants of lookup are combined into one
271 function (cf, @InstEnv@). We don't do that for family instances as the
272 results of matching and unification are used in two different contexts.
273 Moreover, matching is the wildly more frequently used operation in the case of
274 indexed synonyms and we don't want to slow that down by needless unification.
277 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
278 -> [(FamInstMatch, TvSubst)]
279 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
280 | not (isOpenTyCon fam)
283 = home_matches ++ pkg_matches
285 rough_tcs = roughMatchTcs tys
286 all_tvs = all isNothing rough_tcs
287 home_matches = lookup home_ie
288 pkg_matches = lookup pkg_ie
291 lookup env = case lookupUFM env fam of
292 Nothing -> [] -- No instances for this class
293 Just (FamIE insts has_tv_insts)
294 -- Short cut for common case:
295 -- The thing we are looking up is of form (C a
296 -- b c), and the FamIE has no instances of
297 -- that form, so don't bother to search
298 | all_tvs && not has_tv_insts -> []
299 | otherwise -> find insts
303 find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
304 fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
305 -- Fast check for no match, uses the "rough match" fields
306 | instanceCantMatch rough_tcs mb_tcs
310 = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
311 (ppr fam <+> ppr tys <+> ppr all_tvs) $$
312 (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys)
314 -- Unification will break badly if the variables overlap
315 -- They shouldn't because we allocate separate uniques for them
316 case tcUnifyTys instanceBindFun tpl_tys tys of
317 Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon)
319 ((item, rep_tys), subst) : find rest
323 %************************************************************************
325 Looking up a family instance
327 %************************************************************************
330 topNormaliseType :: FamInstEnvs
332 -> Maybe (Coercion, Type)
334 -- Get rid of *outermost* (or toplevel)
337 -- using appropriate coercions.
338 -- By "outer" we mean that toplevelNormaliseType guarantees to return
339 -- a type that does not have a reducible redex (F ty1 .. tyn) as its
340 -- outermost form. It *can* return something like (Maybe (F ty)), where
341 -- (F ty) is a redex.
343 -- Its a bit like Type.repType, but handles type families too
345 topNormaliseType env ty
348 go :: [TyCon] -> Type -> Maybe (Coercion, Type)
349 go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
352 go rec_nts (TyConApp tc tys) -- Expand newtypes
353 | Just co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes]
354 = if tc `elem` rec_nts -- in Type.lhs
356 else let nt_co = mkTyConApp co_con tys
357 in add_co nt_co rec_nts' nt_rhs
359 nt_rhs = newTyConInstRhs tc tys
360 rec_nts' | isRecursiveTyCon tc = tc:rec_nts
361 | otherwise = rec_nts
363 go rec_nts (TyConApp tc tys) -- Expand open tycons
365 , (ACo co, ty) <- normaliseTcApp env tc tys
366 = -- The ACo says "something happened"
367 -- Note that normaliseType fully normalises, but it has do to so
374 = case go rec_nts ty of
375 Nothing -> Just (co, ty)
376 Just (co', ty') -> Just (mkTransCoercion co co', ty')
380 normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type)
381 normaliseTcApp env tc tys
382 = let -- First normalise the arg types so that they'll match
383 -- when we lookup in in the instance envt
384 (cois, ntys) = mapAndUnzip (normaliseType env) tys
385 tycon_coi = mkTyConAppCoI tc ntys cois
386 in -- Now try the top-level redex
387 case lookupFamInstEnv env tc ntys of
388 -- A matching family instance exists
389 [(fam_inst, tys)] -> (fix_coi, nty)
391 rep_tc = famInstTyCon fam_inst
392 co_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
393 co = mkTyConApp co_tycon tys
394 first_coi = mkTransCoI tycon_coi (ACo co)
395 (rest_coi,nty) = normaliseType env (mkTyConApp rep_tc tys)
396 fix_coi = mkTransCoI first_coi rest_coi
398 -- No unique matching family instance exists;
399 -- we do not do anything
400 _ -> (tycon_coi, TyConApp tc ntys)
402 normaliseType :: FamInstEnvs -- environment with family instances
404 -> (CoercionI, Type) -- (coercion,new type), where
405 -- co :: old-type ~ new_type
406 -- Normalise the input type, by eliminating *all* type-function redexes
407 -- Returns with IdCo if nothing happens
410 | Just ty' <- coreView ty = normaliseType env ty'
411 normaliseType env (TyConApp tc tys)
412 = normaliseTcApp env tc tys
413 normaliseType env (AppTy ty1 ty2)
414 = let (coi1,nty1) = normaliseType env ty1
415 (coi2,nty2) = normaliseType env ty2
416 in (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2)
417 normaliseType env (FunTy ty1 ty2)
418 = let (coi1,nty1) = normaliseType env ty1
419 (coi2,nty2) = normaliseType env ty2
420 in (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2)
421 normaliseType env (ForAllTy tyvar ty1)
422 = let (coi,nty1) = normaliseType env ty1
423 in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
424 normaliseType _ ty@(TyVarTy _)
426 normaliseType env (PredTy predty)
427 = normalisePred env predty
430 normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
431 normalisePred env (ClassP cls tys)
432 = let (cois,tys') = mapAndUnzip (normaliseType env) tys
433 in (mkClassPPredCoI cls tys' cois, PredTy $ ClassP cls tys')
434 normalisePred env (IParam ipn ty)
435 = let (coi,ty') = normaliseType env ty
436 in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
437 normalisePred env (EqPred ty1 ty2)
438 = let (coi1,ty1') = normaliseType env ty1
439 (coi2,ty2') = normaliseType env ty2
440 in (mkEqPredCoI ty1' coi1 ty2' coi2, PredTy $ EqPred ty1' ty2')