X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FFamInstEnv.lhs;h=65c253914e0025f6094903f55db57398255495cd;hb=27759873a8bd45c487a6e636f7a12c37e87f616f;hp=12df25d06ba4b140a6662b80ffb46f6eb115a031;hpb=3787d9878e4d62829a555f01b2a4c5866f24f303;p=ghc-hetmet.git diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 12df25d..65c2539 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -5,13 +5,6 @@ FamInstEnv: Type checked family instance declarations \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module FamInstEnv ( FamInst(..), famInstTyCon, famInstTyVars, pprFamInst, pprFamInstHdr, pprFamInsts, @@ -31,8 +24,6 @@ module FamInstEnv ( import InstEnv import Unify -import TcGadt -import TcType import Type import TypeRep import TyCon @@ -40,12 +31,11 @@ import Coercion import VarSet import Var import Name -import OccName -import SrcLoc import UniqFM import Outputable import Maybes import Util +import FastString import Maybe \end{code} @@ -82,6 +72,7 @@ data FamInst famInstTyCon :: FamInst -> TyCon famInstTyCon = fi_tycon +famInstTyVars :: FamInst -> TyVarSet famInstTyVars = fi_tvs \end{code} @@ -96,16 +87,16 @@ instance Outputable FamInst where pprFamInst :: FamInst -> SDoc pprFamInst famInst = hang (pprFamInstHdr famInst) - 2 (ptext SLIT("--") <+> pprNameLoc (getName famInst)) + 2 (ptext (sLit "--") <+> pprNameLoc (getName famInst)) pprFamInstHdr :: FamInst -> SDoc pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) = pprTyConSort <+> pprHead where - pprHead = pprTypeApp fam (ppr fam) tys - pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance") - | isNewTyCon tycon = ptext SLIT("newtype instance") - | isSynTyCon tycon = ptext SLIT("type instance") + 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" pprFamInsts :: [FamInst] -> SDoc @@ -227,8 +218,25 @@ desugared to we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. +Note [Over-saturated matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's ok to look up an over-saturated type constructor. E.g. + type family F a :: * -> * + type instance F (a,b) = Either (a->b) + +The type instance gives rise to a newtype TyCon (at a higher kind +which you can't do in Haskell!): + newtype FPair a b = FP (Either (a->b)) + +Then looking up (F (Int,Bool) Char) will return a FamInstMatch + (FPair, [Int,Bool,Char]) + +The "extra" type argument [Char] just stays on the end. + + \begin{code} type FamInstMatch = (FamInst, [Type]) -- Matching type instance + -- See Note [Over-saturated matches] lookupFamInstEnv :: FamInstEnvs -> TyCon -> [Type] -- What we are looking for @@ -237,13 +245,23 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys | not (isOpenTyCon fam) = [] | otherwise - = home_matches ++ pkg_matches + = ASSERT( n_tys >= arity ) -- Family type applications must be saturated + 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 + -- See Note [Over-saturated matches] + arity = tyConArity fam + n_tys = length tys + extra_tys = drop arity tys + (match_tys, add_extra_tys) + | arity > n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys) + | otherwise = (tys, \res_tys -> res_tys) + -- The second case is the common one, hence functional representation + -------------- lookup env = case lookupUFM env fam of Nothing -> [] -- No instances for this class @@ -264,8 +282,8 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys = find rest -- Proper check - | Just subst <- tcMatchTys tpl_tvs tpl_tys tys - = (item, substTyVars subst (tyConTyVars tycon)) : find rest + | Just subst <- tcMatchTys tpl_tvs tpl_tys match_tys + = (item, add_extra_tys $ substTyVars subst (tyConTyVars tycon)) : find rest -- No match => try next | otherwise @@ -322,16 +340,11 @@ lookupFamInstEnvUnify (pkg_ie, home_ie) fam 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 + case tcUnifyTys instanceBindFun tpl_tys tys of Just subst -> let rep_tys = substTyVars subst (tyConTyVars tycon) in ((item, rep_tys), subst) : find rest Nothing -> find rest - --- See explanation at @InstEnv.bind_fn@. --- -bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem - | otherwise = BindMe \end{code} %************************************************************************ @@ -382,7 +395,7 @@ topNormaliseType env ty -- to be sure that add_co co rec_nts ty - go rec_nts ty = Nothing + go _ _ = Nothing add_co co rec_nts ty = case go rec_nts ty of @@ -411,7 +424,7 @@ normaliseTcApp env tc tys -- No unique matching family instance exists; -- we do not do anything - other -> (tycon_coi, TyConApp tc ntys) + _ -> (tycon_coi, TyConApp tc ntys) --------------- normaliseType :: FamInstEnvs -- environment with family instances -> Type -- old type @@ -422,26 +435,23 @@ normaliseType :: FamInstEnvs -- environment with family instances normaliseType env ty | Just ty' <- coreView ty = normaliseType env ty' -normaliseType env ty@(TyConApp tc tys) +normaliseType env (TyConApp tc tys) = normaliseTcApp env tc tys -normaliseType env ty@(AppTy ty1 ty2) +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 ty@(FunTy ty1 ty2) +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 ty@(ForAllTy tyvar ty1) +normaliseType env (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 (coi,NoteTy note nty1) -normaliseType env ty@(TyVarTy _) +normaliseType _ ty@(TyVarTy _) = (IdCo,ty) normaliseType env (PredTy predty) - = normalisePred env predty + = normalisePred env predty --------------- normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)