X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FFamInstEnv.lhs;h=f6e76a7161caebad2a4f798a0b92a80bb89f5675;hb=ced4c13ea3577e01556a2f76c2cc458c0be6c83c;hp=50c827f2223f73368c28aede19c1f39ac6f59e91;hpb=027e6be20af2e59e2ec720042d23ef06d9a7d4c1;p=ghc-hetmet.git diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 50c827f..f6e76a7 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -36,8 +36,6 @@ import Outputable import Maybes import Util import FastString - -import Maybe \end{code} @@ -90,14 +88,23 @@ pprFamInst famInst 2 (ptext (sLit "--") <+> pprNameLoc (getName famInst)) pprFamInstHdr :: FamInst -> SDoc -pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) - = pprTyConSort <+> pprHead +pprFamInstHdr (FamInst {fi_tycon = rep_tc}) + = pprTyConSort <+> pp_instance <+> pprHead where - pprHead = pprTypeApp fam tys - pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance") - | isNewTyCon tycon = ptext (sLit "newtype instance") - | isSynTyCon tycon = ptext (sLit "type instance") - | otherwise = panic "FamInstEnv.pprFamInstHdr" + Just (fam_tc, tys) = tyConFamInst_maybe rep_tc + + -- For *associated* types, say "type T Int = blah" + -- For *top level* type instances, say "type instance T Int = blah" + pp_instance + | isTyConAssoc fam_tc = empty + | otherwise = ptext (sLit "instance") + + pprHead = pprTypeApp fam_tc tys + pprTyConSort | isDataTyCon rep_tc = ptext (sLit "data") + | isNewTyCon rep_tc = ptext (sLit "newtype") + | isSynTyCon rep_tc = ptext (sLit "type") + | isAbstractTyCon rep_tc = ptext (sLit "data") + | otherwise = panic "FamInstEnv.pprFamInstHdr" pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) @@ -228,7 +235,7 @@ lookupFamInstEnv -> [FamInstMatch] -- Successful matches lookupFamInstEnv - = lookup_fam_inst_env match + = lookup_fam_inst_env match True where match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys @@ -245,7 +252,7 @@ lookupFamInstEnvConflicts -- unique supply to hand lookupFamInstEnvConflicts envs fam_inst skol_tvs - = lookup_fam_inst_env my_unify envs fam tys' + = lookup_fam_inst_env my_unify False envs fam tys' where inst_tycon = famInstTyCon fam_inst (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts" @@ -275,12 +282,13 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs | otherwise = not (old_rhs `tcEqType` new_rhs) where old_tycon = famInstTyCon old_fam_inst - old_rhs = mkTyConApp old_tycon (substTyVars subst (tyConTyVars old_tycon)) + old_tvs = tyConTyVars old_tycon + old_rhs = mkTyConApp old_tycon (substTyVars subst old_tvs) new_rhs = mkTyConApp inst_tycon (substTyVars subst skol_tvs) \end{code} While @lookupFamInstEnv@ uses a one-way match, the next function -@lookupFamInstEnvUnify@ uses two-way matching (ie, unification). This is +@lookupFamInstEnvConflicts@ 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 @@ -297,13 +305,17 @@ type MatchFun = FamInst -- The FamInst template -> [Type] -- Target to match against -> Maybe TvSubst +type OneSidedMatch = Bool -- Are optimisations that are only valid for + -- one sided matches allowed? + lookup_fam_inst_env -- The worker, local to this module :: MatchFun + -> OneSidedMatch -> FamInstEnvs -> TyCon -> [Type] -- What we are looking for -> [FamInstMatch] -- Successful matches -lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys - | not (isOpenTyCon fam) +lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys + | not (isFamilyTyCon fam) = [] | otherwise = ASSERT( n_tys >= arity ) -- Family type applications must be saturated @@ -323,7 +335,7 @@ lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys -------------- rough_tcs = roughMatchTcs match_tys - all_tvs = all isNothing rough_tcs + all_tvs = all isNothing rough_tcs && one_sided -------------- lookup env = case lookupUFM env fam of @@ -412,7 +424,7 @@ topNormaliseType env ty | otherwise = rec_nts go rec_nts (TyConApp tc tys) -- Expand open tycons - | isOpenTyCon tc + | isFamilyTyCon tc , (ACo co, ty) <- normaliseTcApp env tc tys = -- The ACo says "something happened" -- Note that normaliseType fully normalises, but it has do to so @@ -433,7 +445,7 @@ 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 tc ntys cois + tycon_coi = mkTyConAppCoI tc cois in -- Now try the top-level redex case lookupFamInstEnv env tc ntys of -- A matching family instance exists @@ -464,16 +476,16 @@ normaliseType env (TyConApp 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) + in (mkAppTyCoI coi1 coi2, mkAppTy 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) + in (mkFunTyCoI coi1 coi2, mkFunTy nty1 nty2) normaliseType env (ForAllTy tyvar ty1) = let (coi,nty1) = normaliseType env ty1 - in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1) + in (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1) normaliseType _ ty@(TyVarTy _) - = (IdCo,ty) + = (IdCo ty,ty) normaliseType env (PredTy predty) = normalisePred env predty @@ -481,12 +493,12 @@ normaliseType env (PredTy predty) normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type) normalisePred env (ClassP cls tys) = let (cois,tys') = mapAndUnzip (normaliseType env) tys - in (mkClassPPredCoI cls tys' cois, PredTy $ ClassP cls tys') + in (mkClassPPredCoI cls cois, PredTy $ ClassP cls tys') normalisePred env (IParam ipn ty) = let (coi,ty') = normaliseType env ty in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty') normalisePred env (EqPred ty1 ty2) = let (coi1,ty1') = normaliseType env ty1 (coi2,ty2') = normaliseType env ty2 - in (mkEqPredCoI ty1' coi1 ty2' coi2, PredTy $ EqPred ty1' ty2') + in (mkEqPredCoI coi1 coi2, PredTy $ EqPred ty1' ty2') \end{code}