X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FFamInstEnv.lhs;h=eb31751678daf8add4ec0422749daec5759187f6;hp=ec50fbc7e414118703da697fc2d7f7e4f8cd6d83;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hpb=91923f12046713b115003e184f7098ee00c00028 diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index ec50fbc..eb31751 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -1,30 +1,38 @@ -\section[FamInstEnv]{Type checked family instance declarations} +% +% (c) The University of Glasgow 2006 +% + +FamInstEnv: Type checked family instance declarations \begin{code} module FamInstEnv ( - FamInst(..), famInstTyCon, extractFamInsts, + FamInst(..), famInstTyCon, famInstTyVars, pprFamInst, pprFamInstHdr, pprFamInsts, - {-famInstHead, mkLocalFamInst, mkImportedFamInst-} + famInstHead, mkLocalFamInst, mkImportedFamInst, FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList, famInstEnvElts, familyInstances, - {-lookupFamInstEnv-} + + lookupFamInstEnv, lookupFamInstEnvUnify ) where #include "HsVersions.h" -import TcType ( Type ) -import Type ( TyThing (ATyCon), pprParendType ) -import TyCon ( TyCon, isDataTyCon, isNewTyCon, isSynTyCon, - tyConName, tyConTyVars, tyConFamInst_maybe ) -import VarSet ( TyVarSet, mkVarSet ) -import Name ( Name, getOccName, NamedThing(..), getSrcLoc ) -import OccName ( parenSymOcc ) -import SrcLoc ( pprDefnLoc ) -import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM ) +import InstEnv +import Unify +import TcGadt +import TcType +import Type +import TyCon +import VarSet +import Var +import Name +import OccName +import SrcLoc +import UniqFM import Outputable -import Monad ( mzero ) +import Maybe \end{code} @@ -37,6 +45,11 @@ import Monad ( mzero ) \begin{code} data FamInst = FamInst { fi_fam :: Name -- Family name + + -- Used for "rough matching"; same idea as for class instances + , fi_tcs :: [Maybe Name] -- Top of type args + + -- Used for "proper matching"; ditto , fi_tvs :: TyVarSet -- Template tyvars for full match , fi_tys :: [Type] -- Full arg types @@ -48,20 +61,7 @@ data FamInst famInstTyCon :: FamInst -> TyCon famInstTyCon = fi_tycon --- Extract all family instances. --- -extractFamInsts :: [TyThing] -> [FamInst] -extractFamInsts tythings - = do { ATyCon tycon <- tythings - ; case tyConFamInst_maybe tycon of - Nothing -> mzero - Just (fam, tys) -> - return $ FamInst { fi_fam = tyConName fam - , fi_tvs = mkVarSet . tyConTyVars $ tycon - , fi_tys = tys - , fi_tycon = tycon - } - } +famInstTyVars = fi_tvs \end{code} \begin{code} @@ -90,6 +90,44 @@ pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) + +famInstHead :: FamInst -> ([TyVar], TyCon, [Type]) +famInstHead (FamInst {fi_tycon = tycon}) + = case tyConFamInst_maybe tycon of + Nothing -> panic "FamInstEnv.famInstHead" + Just (fam, tys) -> (tyConTyVars tycon, fam, tys) + +-- Make a family instance representation from a tycon. This is used for local +-- instances, where we can safely pull on the tycon. +-- +mkLocalFamInst :: TyCon -> FamInst +mkLocalFamInst tycon + = case tyConFamInst_maybe tycon of + Nothing -> panic "FamInstEnv.mkLocalFamInst" + Just (fam, tys) -> + FamInst { + fi_fam = tyConName fam, + fi_tcs = roughMatchTcs tys, + fi_tvs = mkVarSet . tyConTyVars $ tycon, + fi_tys = tys, + fi_tycon = tycon + } + +-- Make a family instance representation from the information found in an +-- unterface file. In particular, we get the rough match info from the iface +-- (instead of computing it here). +-- +mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst +mkImportedFamInst fam mb_tcs tycon + = FamInst { + fi_fam = fam, + fi_tcs = mb_tcs, + fi_tvs = mkVarSet . tyConTyVars $ tycon, + fi_tys = case tyConFamInst_maybe tycon of + Nothing -> panic "FamInstEnv.mkImportedFamInst" + Just (_, tys) -> tys, + fi_tycon = tycon + } \end{code} @@ -102,7 +140,13 @@ pprFamInsts finsts = vcat (map pprFamInst finsts) InstEnv maps a family name to the list of known instances for that family. \begin{code} -type FamInstEnv = UniqFM [FamInst] -- Maps a family to its instances +type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances + +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 + -- If *not* then the common case of looking up + -- (T a b c) can fail immediately -- INVARIANTS: -- * The fs_tvs are distinct in each FamInst @@ -112,23 +156,179 @@ emptyFamInstEnv :: FamInstEnv emptyFamInstEnv = emptyUFM famInstEnvElts :: FamInstEnv -> [FamInst] -famInstEnvElts = concat . eltsUFM +famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts] familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] familyInstances (pkg_fie, home_fie) fam = get home_fie ++ get pkg_fie where get env = case lookupUFM env fam of - Just insts -> insts - Nothing -> [] + Just (FamIE insts _) -> insts + Nothing -> [] extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm}) - = addToUFM_C add inst_env cls_nm [ins_item] +extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) + = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar) + where + add (FamIE items tyvar) _ = FamIE (ins_item:items) + (ins_tyvar || tyvar) + ins_tyvar = not (any isJust mb_tcs) +\end{code} + +%************************************************************************ +%* * +\subsection{Looking up a family instance} +%* * +%************************************************************************ + +@lookupFamInstEnvExact@ looks up in a @FamInstEnv@ using an exact match. +This is used when we want the @TyCon@ of a particular family instance (e.g., +during deriving classes). + +\begin{code} +{- NOT NEEDED ANY MORE +lookupFamInstEnvExact :: (FamInstEnv -- External package inst-env + ,FamInstEnv) -- Home-package inst-env + -> TyCon -> [Type] -- What we are looking for + -> Maybe FamInst +lookupFamInstEnvExact (pkg_ie, home_ie) fam tys + = home_matches `mplus` pkg_matches where - add items _ = ins_item:items -\end{code} + 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 -> 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 -> Nothing + | otherwise -> find insts + -------------- + find [] = Nothing + find (item@(FamInst { fi_tcs = mb_tcs, fi_tys = tpl_tys }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + -- Proper check + | tcEqTypes tpl_tys tys + = Just item + + -- No match => try next + | otherwise + = find rest +-} +\end{code} + +@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. +Multiple matches are only possible in case of type families (not data +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 + -> TyCon -> [Type] -- What we are looking for + -> [(TvSubst, FamInst)] -- Successful matches +lookupFamInstEnv (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 + + -- Proper check + | Just subst <- tcMatchTys tpl_tvs tpl_tys tys + = (subst, item) : find rest + + -- No match => try next + | 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}