X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FFamInstEnv.lhs;h=3bfe55d1f0a40945dc92dd9c7d251debcede60c6;hp=ee5558397ee9656279d0e48e0a683e0989fc280d;hb=467f588c25e6d7825a11eff018a67727b3dea71b;hpb=b15724ad3cae2a14c265683e8bb6f7d639dac251 diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index ee55583..3bfe55d 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -33,8 +33,6 @@ import Coercion import VarSet import Var import Name -import OccName -import SrcLoc import UniqFM import Outputable import Maybes @@ -75,6 +73,7 @@ data FamInst famInstTyCon :: FamInst -> TyCon famInstTyCon = fi_tycon +famInstTyVars :: FamInst -> TyVarSet famInstTyVars = fi_tvs \end{code} @@ -89,7 +88,7 @@ instance Outputable FamInst where pprFamInst :: FamInst -> SDoc pprFamInst famInst = hang (pprFamInstHdr famInst) - 2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan famInst))) + 2 (ptext SLIT("--") <+> pprNameLoc (getName famInst)) pprFamInstHdr :: FamInst -> SDoc pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) @@ -277,7 +276,7 @@ indexed synonyms and we don't want to slow that down by needless unification. \begin{code} lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type] - -> [(FamInstMatch)] + -> [(FamInstMatch, TvSubst)] lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys | not (isOpenTyCon fam) = [] @@ -318,11 +317,12 @@ lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys case tcUnifyTys bind_fn tpl_tys tys of Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon) in - (item, rep_tys) : find rest + ((item, rep_tys), subst) : find rest Nothing -> find rest -- See explanation at @InstEnv.bind_fn@. -- +bind_fn :: TyVar -> BindFlag bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem | otherwise = BindMe \end{code} @@ -335,42 +335,63 @@ bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem \begin{code} topNormaliseType :: FamInstEnvs - -> Type - -> Maybe (Coercion, Type) + -> Type + -> Maybe (Coercion, Type) --- Get rid of *outermost* (or toplevel) type functions by rewriting them +-- Get rid of *outermost* (or toplevel) +-- * type functions +-- * newtypes +-- using appropriate coercions. -- By "outer" we mean that toplevelNormaliseType guarantees to return -- a type that does not have a reducible redex (F ty1 .. tyn) as its -- outermost form. It *can* return something like (Maybe (F ty)), where -- (F ty) is a redex. -topNormaliseType env ty - | Just ty' <- tcView ty = topNormaliseType env ty' - -topNormaliseType env ty@(TyConApp tc tys) - | isOpenTyCon tc - , (ACo co, ty) <- normaliseType env ty - = Just (co, ty) +-- Its a bit like Type.repType, but handles type families too topNormaliseType env ty - = Nothing + = go [] ty + where + go :: [TyCon] -> Type -> Maybe (Coercion, Type) + go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms + = go rec_nts ty' + + go rec_nts (TyConApp tc tys) -- Expand newtypes + | Just co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes] + = if tc `elem` rec_nts -- in Type.lhs + then Nothing + else let nt_co = mkTyConApp co_con tys + in add_co nt_co rec_nts' nt_rhs + where + nt_rhs = newTyConInstRhs tc tys + rec_nts' | isRecursiveTyCon tc = tc:rec_nts + | otherwise = rec_nts + + go rec_nts (TyConApp tc tys) -- Expand open tycons + | isOpenTyCon tc + , (ACo co, ty) <- normaliseTcApp env tc tys + = -- The ACo says "something happened" + -- Note that normaliseType fully normalises, but it has do to so + -- to be sure that + add_co co rec_nts ty + + go _ _ = Nothing + + add_co co rec_nts ty + = case go rec_nts ty of + Nothing -> Just (co, ty) + Just (co', ty') -> Just (mkTransCoercion co co', ty') -normaliseType :: FamInstEnvs -- environment with family instances - -> Type -- old type - -> (CoercionI,Type) -- (coercion,new type), where - -- co :: old-type ~ new_type --- Normalise the input type, by eliminating all type-function redexes - -normaliseType env ty - | Just ty' <- coreView ty = normaliseType env ty' - -normaliseType env ty@(TyConApp tyCon tys) - = let -- First normalise the arg types +--------------- +normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type) +normaliseTcApp env tc tys + = let -- First normalise the arg types so that they'll match + -- when we lookup in in the instance envt (cois, ntys) = mapAndUnzip (normaliseType env) tys - tycon_coi = mkTyConAppCoI tyCon ntys cois + tycon_coi = mkTyConAppCoI tc ntys cois in -- Now try the top-level redex - case lookupFamInstEnv env tyCon ntys of + case lookupFamInstEnv env tc ntys of -- A matching family instance exists [(fam_inst, tys)] -> (fix_coi, nty) where @@ -383,29 +404,36 @@ normaliseType env ty@(TyConApp tyCon tys) -- No unique matching family instance exists; -- we do not do anything - other -> (tycon_coi, TyConApp tyCon ntys) - - where + _ -> (tycon_coi, TyConApp tc ntys) +--------------- +normaliseType :: FamInstEnvs -- environment with family instances + -> Type -- old type + -> (CoercionI, Type) -- (coercion,new type), where + -- co :: old-type ~ new_type +-- Normalise the input type, by eliminating *all* type-function redexes +-- Returns with IdCo if nothing happens -normaliseType env ty@(AppTy ty1 ty2) - = let (coi1,nty1) = normaliseType env ty1 - (coi2,nty2) = normaliseType env ty2 - in (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2) -normaliseType env ty@(FunTy ty1 ty2) - = let (coi1,nty1) = normaliseType env ty1 - (coi2,nty2) = normaliseType env ty2 - in (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2) -normaliseType env ty@(ForAllTy tyvar ty1) - = let (coi,nty1) = normaliseType env ty1 - in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1) -normaliseType env ty@(NoteTy note ty1) - = let (coi,nty1) = normaliseType env ty1 - in (mkNoteTyCoI note coi,NoteTy note nty1) -normaliseType env ty@(TyVarTy _) - = (IdCo,ty) +normaliseType env ty + | Just ty' <- coreView ty = normaliseType env ty' +normaliseType env (TyConApp tc tys) + = normaliseTcApp env tc tys +normaliseType env (AppTy ty1 ty2) + = let (coi1,nty1) = normaliseType env ty1 + (coi2,nty2) = normaliseType env ty2 + in (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2) +normaliseType env (FunTy ty1 ty2) + = let (coi1,nty1) = normaliseType env ty1 + (coi2,nty2) = normaliseType env ty2 + in (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2) +normaliseType env (ForAllTy tyvar ty1) + = let (coi,nty1) = normaliseType env ty1 + in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1) +normaliseType _ ty@(TyVarTy _) + = (IdCo,ty) normaliseType env (PredTy predty) - = normalisePred env predty + = normalisePred env predty +--------------- normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type) normalisePred env (ClassP cls tys) = let (cois,tys') = mapAndUnzip (normaliseType env) tys