pprFamInst, pprFamInstHdr, pprFamInsts,
famInstHead, mkLocalFamInst, mkImportedFamInst,
- FamInstEnvs, FamInstEnv, emptyFamInstEnv,
+ FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,
extendFamInstEnv, extendFamInstEnvList,
famInstEnvElts, familyInstances,
lookupFamInstEnv, lookupFamInstEnvUnify,
-- Normalisation
- toplevelNormaliseFamInst
+ topNormaliseType
) where
#include "HsVersions.h"
import VarSet
import Var
import Name
-import OccName
-import SrcLoc
import UniqFM
import Outputable
import Maybes
famInstTyCon :: FamInst -> TyCon
famInstTyCon = fi_tycon
+famInstTyVars :: FamInst -> TyVarSet
famInstTyVars = fi_tvs
\end{code}
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})
= pprTyConSort <+> pprHead
where
- pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys
+ 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")
-- * The fs_tvs are distinct in each FamInst
-- of a range value of the map (so we can safely unify them)
+emptyFamInstEnvs :: (FamInstEnv, FamInstEnv)
+emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)
+
emptyFamInstEnv :: FamInstEnv
emptyFamInstEnv = emptyUFM
%************************************************************************
%* *
-\subsection{Looking up a family instance}
+ Looking up a family instance
%* *
%************************************************************************
-> TyCon -> [Type] -- What we are looking for
-> [FamInstMatch] -- Successful matches
lookupFamInstEnv (pkg_ie, home_ie) fam tys
+ | not (isOpenTyCon fam)
+ = []
+ | otherwise
= home_matches ++ pkg_matches
where
rough_tcs = roughMatchTcs tys
\begin{code}
lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type]
- -> [(FamInstMatch)]
+ -> [(FamInstMatch, TvSubst)]
lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys
+ | not (isOpenTyCon fam)
+ = []
+ | otherwise
= home_matches ++ pkg_matches
where
rough_tcs = roughMatchTcs 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}
---------------------------------------
--- Normalisation
+%************************************************************************
+%* *
+ Looking up a family instance
+%* *
+%************************************************************************
\begin{code}
- -- get rid of TOPLEVEL type functions by rewriting them
- -- i.e. treating their equations as a TRS
-toplevelNormaliseFamInst :: FamInstEnvs ->
- Type ->
- (CoercionI,Type)
-toplevelNormaliseFamInst env ty
- | Just ty' <- tcView ty = normaliseFamInst env ty'
-toplevelNormaliseFamInst env ty@(TyConApp tyCon tys)
- | isOpenTyCon tyCon
- = normaliseFamInst env ty
-toplevelNormaliseFamInst env ty
- = (IdCo,ty)
+topNormaliseType :: FamInstEnvs
+ -> Type
+ -> Maybe (Coercion, Type)
+
+-- 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.
+
+-- Its a bit like Type.repType, but handles type families too
+
+topNormaliseType env ty
+ = 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')
- -- get rid of ALL type functions by rewriting them
- -- i.e. treating their equations as a TRS
-normaliseFamInst :: FamInstEnvs -> -- environment with family instances
- Type -> -- old type
- (CoercionI,Type) -- (coercion,new type)
-normaliseFamInst env ty
- | Just ty' <- tcView ty = normaliseFamInst env ty'
-normaliseFamInst env ty@(TyConApp tyCon tys) =
- let (cois,ntys) = mapAndUnzip (normaliseFamInst env) tys
- tycon_coi = mkTyConAppCoI tyCon ntys cois
- maybe_ty_co = lookupFamInst env tyCon ntys
- in case maybe_ty_co of
- -- a matching family instance exists
- Just (ty',co) ->
- let first_coi = mkTransCoI tycon_coi (ACo co)
- (rest_coi,nty) = normaliseFamInst env ty'
- fix_coi = mkTransCoI first_coi rest_coi
- in (fix_coi,nty)
- -- no matching family instance exists
+---------------
+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 tc ntys cois
+ in -- Now try the top-level redex
+ case lookupFamInstEnv env tc ntys of
+ -- A matching family instance exists
+ [(fam_inst, tys)] -> (fix_coi, nty)
+ where
+ rep_tc = famInstTyCon fam_inst
+ co_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
+ co = mkTyConApp co_tycon tys
+ first_coi = mkTransCoI tycon_coi (ACo co)
+ (rest_coi,nty) = normaliseType env (mkTyConApp rep_tc tys)
+ fix_coi = mkTransCoI first_coi rest_coi
+
+ -- No unique matching family instance exists;
-- we do not do anything
- Nothing ->
- (tycon_coi,TyConApp tyCon ntys)
-normaliseFamInst env ty@(AppTy ty1 ty2) =
- let (coi1,nty1) = normaliseFamInst env ty1
- (coi2,nty2) = normaliseFamInst env ty2
- in (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2)
-normaliseFamInst env ty@(FunTy ty1 ty2) =
- let (coi1,nty1) = normaliseFamInst env ty1
- (coi2,nty2) = normaliseFamInst env ty2
- in (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2)
-normaliseFamInst env ty@(ForAllTy tyvar ty1) =
- let (coi,nty1) = normaliseFamInst env ty1
- in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
-normaliseFamInst env ty@(NoteTy note ty1) =
- let (coi,nty1) = normaliseFamInst env ty1
- in (mkNoteTyCoI note coi,NoteTy note nty1)
-normaliseFamInst env ty@(TyVarTy _) =
- (IdCo,ty)
-normaliseFamInst env (PredTy predty) =
- normaliseFamInstPred env predty
-
-normaliseFamInstPred :: FamInstEnvs -> PredType -> (CoercionI,Type)
-normaliseFamInstPred env (ClassP cls tys) =
- let (cois,tys') = mapAndUnzip (normaliseFamInst env) tys
+ _ -> (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
+ | 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 :: 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')
-normaliseFamInstPred env (IParam ipn ty) =
- let (coi,ty') = normaliseFamInst env ty
+normalisePred env (IParam ipn ty)
+ = let (coi,ty') = normaliseType env ty
in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
-normaliseFamInstPred env (EqPred ty1 ty2) =
- let (coi1,ty1') = normaliseFamInst env ty1
- (coi2,ty2') = normaliseFamInst env ty2
+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')
-
-lookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> Maybe (Type,Coercion)
-
--- (lookupFamInst F tys) looks for a top-level instance
--- co : forall a. F tys' = G a
--- (The rhs is always of form G a; see Note [The FamInst structure]
--- in FamInst.)
--- where we can instantiate 'a' with t to make tys'[t/a] = tys
--- Hence (co t) : F tys ~ G t
--- Then we return (Just (G t, co t))
-
-lookupFamInst env tycon tys
- | not (isOpenTyCon tycon) -- Dead code; fix.
- = Nothing
- | otherwise
- = case lookupFamInstEnv env tycon tys of
- [(subst, fam_inst)] ->
- Just (mkTyConApp rep_tc substituted_vars, mkTyConApp coercion_tycon substituted_vars)
- where -- NB: invariant of lookupFamInstEnv is that (tyConTyVars rep_tc)
- -- is in the domain of the substitution
- rep_tc = famInstTyCon fam_inst
- coercion_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
- substituted_vars = substTyVars subst (tyConTyVars rep_tc)
- other -> Nothing
\end{code}
projects / ghc-hetmet.git / blobdiff