2 % (c) The University of Glasgow 2006
5 FamInstEnv: Type checked family instance declarations
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and fix
11 -- any warnings in the module. See
12 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 FamInst(..), famInstTyCon, famInstTyVars,
17 pprFamInst, pprFamInstHdr, pprFamInsts,
18 famInstHead, mkLocalFamInst, mkImportedFamInst,
20 FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,
21 extendFamInstEnv, extendFamInstEnvList,
22 famInstEnvElts, familyInstances,
24 lookupFamInstEnv, lookupFamInstEnvUnify,
30 #include "HsVersions.h"
54 %************************************************************************
56 \subsection{Type checked family instance heads}
58 %************************************************************************
62 = FamInst { fi_fam :: Name -- Family name
63 -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
64 -- Just (tc, tys) -> tc
66 -- Used for "rough matching"; same idea as for class instances
67 , fi_tcs :: [Maybe Name] -- Top of type args
68 -- INVARIANT: fi_tcs = roughMatchTcs fi_tys
70 -- Used for "proper matching"; ditto
71 , fi_tvs :: TyVarSet -- Template tyvars for full match
72 , fi_tys :: [Type] -- Full arg types
73 -- INVARIANT: fi_tvs = tyConTyVars fi_tycon
74 -- fi_tys = case tyConFamInst_maybe fi_tycon of
75 -- Just (_, tys) -> tys
77 , fi_tycon :: TyCon -- Representation tycon
80 -- Obtain the representation tycon of a family instance.
82 famInstTyCon :: FamInst -> TyCon
83 famInstTyCon = fi_tycon
85 famInstTyVars = fi_tvs
89 instance NamedThing FamInst where
90 getName = getName . fi_tycon
92 instance Outputable FamInst where
95 -- Prints the FamInst as a family instance declaration
96 pprFamInst :: FamInst -> SDoc
98 = hang (pprFamInstHdr famInst)
99 2 (ptext SLIT("--") <+> pprNameLoc (getName famInst))
101 pprFamInstHdr :: FamInst -> SDoc
102 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
103 = pprTyConSort <+> pprHead
105 pprHead = pprTypeApp fam (ppr fam) tys
106 pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
107 | isNewTyCon tycon = ptext SLIT("newtype instance")
108 | isSynTyCon tycon = ptext SLIT("type instance")
109 | otherwise = panic "FamInstEnv.pprFamInstHdr"
111 pprFamInsts :: [FamInst] -> SDoc
112 pprFamInsts finsts = vcat (map pprFamInst finsts)
114 famInstHead :: FamInst -> ([TyVar], TyCon, [Type])
115 famInstHead (FamInst {fi_tycon = tycon})
116 = case tyConFamInst_maybe tycon of
117 Nothing -> panic "FamInstEnv.famInstHead"
118 Just (fam, tys) -> (tyConTyVars tycon, fam, tys)
120 -- Make a family instance representation from a tycon. This is used for local
121 -- instances, where we can safely pull on the tycon.
123 mkLocalFamInst :: TyCon -> FamInst
125 = case tyConFamInst_maybe tycon of
126 Nothing -> panic "FamInstEnv.mkLocalFamInst"
129 fi_fam = tyConName fam,
130 fi_tcs = roughMatchTcs tys,
131 fi_tvs = mkVarSet . tyConTyVars $ tycon,
136 -- Make a family instance representation from the information found in an
137 -- unterface file. In particular, we get the rough match info from the iface
138 -- (instead of computing it here).
140 mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst
141 mkImportedFamInst fam mb_tcs tycon
145 fi_tvs = mkVarSet . tyConTyVars $ tycon,
146 fi_tys = case tyConFamInst_maybe tycon of
147 Nothing -> panic "FamInstEnv.mkImportedFamInst"
148 Just (_, tys) -> tys,
154 %************************************************************************
158 %************************************************************************
160 InstEnv maps a family name to the list of known instances for that family.
163 type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances
165 type FamInstEnvs = (FamInstEnv, FamInstEnv)
166 -- External package inst-env, Home-package inst-env
169 = FamIE [FamInst] -- The instances for a particular family, in any order
170 Bool -- True <=> there is an instance of form T a b c
171 -- If *not* then the common case of looking up
172 -- (T a b c) can fail immediately
175 -- * The fs_tvs are distinct in each FamInst
176 -- of a range value of the map (so we can safely unify them)
178 emptyFamInstEnvs :: (FamInstEnv, FamInstEnv)
179 emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)
181 emptyFamInstEnv :: FamInstEnv
182 emptyFamInstEnv = emptyUFM
184 famInstEnvElts :: FamInstEnv -> [FamInst]
185 famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts]
187 familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]
188 familyInstances (pkg_fie, home_fie) fam
189 = get home_fie ++ get pkg_fie
191 get env = case lookupUFM env fam of
192 Just (FamIE insts _) -> insts
195 extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv
196 extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis
198 extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv
199 extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs})
200 = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar)
202 add (FamIE items tyvar) _ = FamIE (ins_item:items)
204 ins_tyvar = not (any isJust mb_tcs)
207 %************************************************************************
209 Looking up a family instance
211 %************************************************************************
213 @lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.
214 Multiple matches are only possible in case of type families (not data
215 families), and then, it doesn't matter which match we choose (as the
216 instances are guaranteed confluent).
218 We return the matching family instances and the type instance at which it
219 matches. For example, if we lookup 'T [Int]' and have a family instance
221 data instance T [a] = ..
226 coe :Co:R42T a :: T [a] ~ :R42T a
228 we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.
231 type FamInstMatch = (FamInst, [Type]) -- Matching type instance
233 lookupFamInstEnv :: FamInstEnvs
234 -> TyCon -> [Type] -- What we are looking for
235 -> [FamInstMatch] -- Successful matches
236 lookupFamInstEnv (pkg_ie, home_ie) fam tys
237 | not (isOpenTyCon fam)
240 = home_matches ++ pkg_matches
242 rough_tcs = roughMatchTcs tys
243 all_tvs = all isNothing rough_tcs
244 home_matches = lookup home_ie
245 pkg_matches = lookup pkg_ie
248 lookup env = case lookupUFM env fam of
249 Nothing -> [] -- No instances for this class
250 Just (FamIE insts has_tv_insts)
251 -- Short cut for common case:
252 -- The thing we are looking up is of form (C a
253 -- b c), and the FamIE has no instances of
254 -- that form, so don't bother to search
255 | all_tvs && not has_tv_insts -> []
256 | otherwise -> find insts
260 find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
261 fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
262 -- Fast check for no match, uses the "rough match" fields
263 | instanceCantMatch rough_tcs mb_tcs
267 | Just subst <- tcMatchTys tpl_tvs tpl_tys tys
268 = (item, substTyVars subst (tyConTyVars tycon)) : find rest
270 -- No match => try next
275 While @lookupFamInstEnv@ uses a one-way match, the next function
276 @lookupFamInstEnvUnify@ uses two-way matching (ie, unification). This is
277 needed to check for overlapping instances.
279 For class instances, these two variants of lookup are combined into one
280 function (cf, @InstEnv@). We don't do that for family instances as the
281 results of matching and unification are used in two different contexts.
282 Moreover, matching is the wildly more frequently used operation in the case of
283 indexed synonyms and we don't want to slow that down by needless unification.
286 lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
287 -> [(FamInstMatch, TvSubst)]
288 lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
289 | not (isOpenTyCon fam)
292 = home_matches ++ pkg_matches
294 rough_tcs = roughMatchTcs tys
295 all_tvs = all isNothing rough_tcs
296 home_matches = lookup home_ie
297 pkg_matches = lookup pkg_ie
300 lookup env = case lookupUFM env fam of
301 Nothing -> [] -- No instances for this class
302 Just (FamIE insts has_tv_insts)
303 -- Short cut for common case:
304 -- The thing we are looking up is of form (C a
305 -- b c), and the FamIE has no instances of
306 -- that form, so don't bother to search
307 | all_tvs && not has_tv_insts -> []
308 | otherwise -> find insts
312 find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs,
313 fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
314 -- Fast check for no match, uses the "rough match" fields
315 | instanceCantMatch rough_tcs mb_tcs
319 = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs,
320 (ppr fam <+> ppr tys <+> ppr all_tvs) $$
321 (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys)
323 -- Unification will break badly if the variables overlap
324 -- They shouldn't because we allocate separate uniques for them
325 case tcUnifyTys bind_fn tpl_tys tys of
326 Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon)
328 ((item, rep_tys), subst) : find rest
331 -- See explanation at @InstEnv.bind_fn@.
333 bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
337 %************************************************************************
339 Looking up a family instance
341 %************************************************************************
344 topNormaliseType :: FamInstEnvs
346 -> Maybe (Coercion, Type)
348 -- Get rid of *outermost* (or toplevel)
351 -- using appropriate coercions.
352 -- By "outer" we mean that toplevelNormaliseType guarantees to return
353 -- a type that does not have a reducible redex (F ty1 .. tyn) as its
354 -- outermost form. It *can* return something like (Maybe (F ty)), where
355 -- (F ty) is a redex.
357 -- Its a bit like Type.repType, but handles type families too
359 topNormaliseType env ty
362 go :: [TyCon] -> Type -> Maybe (Coercion, Type)
363 go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
366 go rec_nts (TyConApp tc tys) -- Expand newtypes
367 | Just co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes]
368 = if tc `elem` rec_nts -- in Type.lhs
370 else let nt_co = mkTyConApp co_con tys
371 in add_co nt_co rec_nts' nt_rhs
373 nt_rhs = newTyConInstRhs tc tys
374 rec_nts' | isRecursiveTyCon tc = tc:rec_nts
375 | otherwise = rec_nts
377 go rec_nts (TyConApp tc tys) -- Expand open tycons
379 , (ACo co, ty) <- normaliseTcApp env tc tys
380 = -- The ACo says "something happened"
381 -- Note that normaliseType fully normalises, but it has do to so
385 go rec_nts ty = Nothing
388 = case go rec_nts ty of
389 Nothing -> Just (co, ty)
390 Just (co', ty') -> Just (mkTransCoercion co co', ty')
394 normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type)
395 normaliseTcApp env tc tys
396 = let -- First normalise the arg types so that they'll match
397 -- when we lookup in in the instance envt
398 (cois, ntys) = mapAndUnzip (normaliseType env) tys
399 tycon_coi = mkTyConAppCoI tc ntys cois
400 in -- Now try the top-level redex
401 case lookupFamInstEnv env tc ntys of
402 -- A matching family instance exists
403 [(fam_inst, tys)] -> (fix_coi, nty)
405 rep_tc = famInstTyCon fam_inst
406 co_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
407 co = mkTyConApp co_tycon tys
408 first_coi = mkTransCoI tycon_coi (ACo co)
409 (rest_coi,nty) = normaliseType env (mkTyConApp rep_tc tys)
410 fix_coi = mkTransCoI first_coi rest_coi
412 -- No unique matching family instance exists;
413 -- we do not do anything
414 other -> (tycon_coi, TyConApp tc ntys)
416 normaliseType :: FamInstEnvs -- environment with family instances
418 -> (CoercionI, Type) -- (coercion,new type), where
419 -- co :: old-type ~ new_type
420 -- Normalise the input type, by eliminating *all* type-function redexes
421 -- Returns with IdCo if nothing happens
424 | Just ty' <- coreView ty = normaliseType env ty'
425 normaliseType env ty@(TyConApp tc tys)
426 = normaliseTcApp env tc tys
427 normaliseType env ty@(AppTy ty1 ty2)
428 = let (coi1,nty1) = normaliseType env ty1
429 (coi2,nty2) = normaliseType env ty2
430 in (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2)
431 normaliseType env ty@(FunTy ty1 ty2)
432 = let (coi1,nty1) = normaliseType env ty1
433 (coi2,nty2) = normaliseType env ty2
434 in (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2)
435 normaliseType env ty@(ForAllTy tyvar ty1)
436 = let (coi,nty1) = normaliseType env ty1
437 in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
438 normaliseType env ty@(NoteTy note ty1)
439 = let (coi,nty1) = normaliseType env ty1
440 in (coi,NoteTy note nty1)
441 normaliseType env ty@(TyVarTy _)
443 normaliseType env (PredTy predty)
444 = normalisePred env predty
447 normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
448 normalisePred env (ClassP cls tys)
449 = let (cois,tys') = mapAndUnzip (normaliseType env) tys
450 in (mkClassPPredCoI cls tys' cois, PredTy $ ClassP cls tys')
451 normalisePred env (IParam ipn ty)
452 = let (coi,ty') = normaliseType env ty
453 in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
454 normalisePred env (EqPred ty1 ty2)
455 = let (coi1,ty1') = normaliseType env ty1
456 (coi2,ty2') = normaliseType env ty2
457 in (mkEqPredCoI ty1' coi1 ty2' coi2, PredTy $ EqPred ty1' ty2')