X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FFamInstEnv.lhs;h=60b55d10ce08c6c7b90b814062b3c9f6d51f0cff;hb=ff5ae6ab8ed907dcf6adc810791b756bab827ab3;hp=c44c2003ad85ca3ac1b5267cbb84f8c8766d94d0;hpb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;p=ghc-hetmet.git diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index c44c200..60b55d1 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -6,18 +6,22 @@ FamInstEnv: Type checked family instance declarations \begin{code} module FamInstEnv ( - FamInst(..), famInstTyCon, pprFamInst, pprFamInstHdr, pprFamInsts, + FamInst(..), famInstTyCon, famInstTyVars, + pprFamInst, pprFamInstHdr, pprFamInsts, famInstHead, mkLocalFamInst, mkImportedFamInst, - FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList, + FamInstEnvs, FamInstEnv, emptyFamInstEnv, + extendFamInstEnv, extendFamInstEnvList, famInstEnvElts, familyInstances, - lookupFamInstEnv + + lookupFamInstEnv, lookupFamInstEnvUnify ) where #include "HsVersions.h" import InstEnv import Unify +import TcGadt import TcType import Type import TyCon @@ -30,7 +34,6 @@ import UniqFM import Outputable import Maybe -import Monad \end{code} @@ -43,13 +46,19 @@ import Monad \begin{code} data FamInst = FamInst { fi_fam :: Name -- Family name + -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of + -- Just (tc, tys) -> tc -- Used for "rough matching"; same idea as for class instances , fi_tcs :: [Maybe Name] -- Top of type args + -- INVARIANT: fi_tcs = roughMatchTcs is_tys -- Used for "proper matching"; ditto , fi_tvs :: TyVarSet -- Template tyvars for full match , fi_tys :: [Type] -- Full arg types + -- INVARIANT: fi_tvs = tyConTyVars fi_tycon + -- fi_tys = case tyConFamInst_maybe fi_tycon of + -- Just (_, tys) -> tys , fi_tycon :: TyCon -- Representation tycon } @@ -58,6 +67,8 @@ data FamInst -- famInstTyCon :: FamInst -> TyCon famInstTyCon = fi_tycon + +famInstTyVars = fi_tvs \end{code} \begin{code} @@ -77,8 +88,7 @@ pprFamInstHdr :: FamInst -> SDoc pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) = pprTyConSort <+> pprHead where - pprHead = parenSymOcc (getOccName fam) (ppr fam) <+> - sep (map pprParendType tys) + pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance") | isNewTyCon tycon = ptext SLIT("newtype instance") | isSynTyCon tycon = ptext SLIT("type instance") @@ -138,6 +148,9 @@ InstEnv maps a family name to the list of known instances for that family. \begin{code} type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances +type FamInstEnvs = (FamInstEnv, FamInstEnv) + -- External package inst-env, Home-package inst-env + data FamilyInstEnv = FamIE [FamInst] -- The instances for a particular family, in any order Bool -- True <=> there is an instance of form T a b c @@ -172,7 +185,7 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) add (FamIE items tyvar) _ = FamIE (ins_item:items) (ins_tyvar || tyvar) ins_tyvar = not (any isJust mb_tcs) -\end{code} +\end{code} %************************************************************************ %* * @@ -186,8 +199,7 @@ families), and then, it doesn't matter which match we choose (as the instances are guaranteed confluent). \begin{code} -lookupFamInstEnv :: (FamInstEnv -- External package inst-env - ,FamInstEnv) -- Home-package inst-env +lookupFamInstEnv :: FamInstEnvs -> TyCon -> [Type] -- What we are looking for -> [(TvSubst, FamInst)] -- Successful matches lookupFamInstEnv (pkg_ie, home_ie) fam tys @@ -210,6 +222,7 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys | otherwise -> find insts -------------- + find [] = [] find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_tys = tpl_tys, fi_tycon = tycon }) : rest) -- Fast check for no match, uses the "rough match" fields @@ -224,3 +237,60 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys | otherwise = find rest \end{code} + +While @lookupFamInstEnv@ uses a one-way match, the next function +@lookupFamInstEnvUnify@ uses two-way matching (ie, unification). This is +needed to check for overlapping instances. + +For class instances, these two variants of lookup are combined into one +function (cf, @InstEnv@). We don't do that for family instances as the +results of matching and unification are used in two different contexts. +Moreover, matching is the wildly more frequently used operation in the case of +indexed synonyms and we don't want to slow that down by needless unification. + +\begin{code} +lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type] + -> [(TvSubst, FamInst)] +lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys + = home_matches ++ pkg_matches + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + home_matches = lookup home_ie + pkg_matches = lookup pkg_ie + + -------------- + lookup env = case lookupUFM env fam of + Nothing -> [] -- No instances for this class + Just (FamIE insts has_tv_insts) + -- Short cut for common case: + -- The thing we are looking up is of form (C a + -- b c), and the FamIE has no instances of + -- that form, so don't bother to search + | all_tvs && not has_tv_insts -> [] + | otherwise -> find insts + + -------------- + find [] = [] + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, + fi_tys = tpl_tys, fi_tycon = tycon }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + | otherwise + = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys <+> ppr all_tvs) $$ + (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys) + ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + case tcUnifyTys bind_fn tpl_tys tys of + Just subst -> (subst, item) : find rest + Nothing -> find rest + +-- See explanation at @InstEnv.bind_fn@. +-- +bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem + | otherwise = BindMe +\end{code}