mkTyConApp, mkTyConTy,
tyConAppTyCon, tyConAppArgs,
splitTyConApp_maybe, splitTyConApp,
- splitNewTyConApp_maybe, splitNewTyConApp,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
-- (Newtypes)
- newTyConInstRhs,
+ newTyConInstRhs, carefullySplitNewType_maybe,
-- (Type families)
- tyFamInsts,
+ tyFamInsts, predFamInsts,
-- (Source types)
mkPredTy, mkPredTys, mkFamilyTyConApp,
Kind, SimpleKind, KindVar,
-- ** Deconstructing Kinds
- kindFunResult, splitKindFunTys, splitKindFunTysN,
+ kindFunResult, splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
-- ** Common Kinds and SuperKinds
liftedTypeKind, unliftedTypeKind, openTypeKind,
-- * Type free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- typeKind,
+ typeKind, expandTypeSynonyms,
-- * Tidying type related things up for printing
tidyType, tidyTypes,
emptyTvSubstEnv, emptyTvSubst,
mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
- getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, extendTvInScopeList,
extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
isEmptyTvSubst,
-- ** Performing substitution on types
- substTy, substTys, substTyWith, substTheta,
+ substTy, substTys, substTyWith, substTysWith, substTheta,
substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
- pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
+ pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
pprSourceTyCon
) where
tcView _ = Nothing
-----------------------------------------------
+expandTypeSynonyms :: Type -> Type
+-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out
+-- just the ones that discard type variables (e.g. type Funny a = Int)
+-- But we don't know which those are currently, so we just expand all.
+expandTypeSynonyms ty
+ = go ty
+ where
+ go (TyConApp tc tys)
+ | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
+ = go (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
+ | otherwise
+ = TyConApp tc (map go tys)
+ go (TyVarTy tv) = TyVarTy tv
+ go (AppTy t1 t2) = AppTy (go t1) (go t2)
+ go (FunTy t1 t2) = FunTy (go t1) (go t2)
+ go (ForAllTy tv t) = ForAllTy tv (go t)
+ go (PredTy p) = PredTy (go_pred p)
+
+ go_pred (ClassP c ts) = ClassP c (map go ts)
+ go_pred (IParam ip t) = IParam ip (go t)
+ go_pred (EqPred t1 t2) = EqPred (go t1) (go t2)
+
+-----------------------------------------------
{-# INLINE kindView #-}
kindView :: Kind -> Maybe Kind
-- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's
repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
repSplitAppTy_maybe (TyConApp tc tys)
- | not (isOpenSynTyCon tc) || length tys > tyConArity tc
+ | isDecomposableTyCon tc || length tys > tyConArity tc
= case snocView tys of -- never create unsaturated type family apps
Just (tys', ty') -> Just (TyConApp tc tys', ty')
Nothing -> Nothing
split _ (AppTy ty arg) args = split ty ty (arg:args)
split _ (TyConApp tc tc_args) args
= let -- keep type families saturated
- n | isOpenSynTyCon tc = tyConArity tc
- | otherwise = 0
- (tc_args1, tc_args2) = splitAt n tc_args
+ n | isDecomposableTyCon tc = 0
+ | otherwise = tyConArity tc
+ (tc_args1, tc_args2) = splitAt n tc_args
in
(TyConApp tc tc_args1, tc_args2 ++ args)
split _ (FunTy ty1 ty2) args = ASSERT( null args )
\begin{code}
mkFunTy :: Type -> Type -> Type
-- ^ Creates a function type from the given argument and result type
-mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res
-mkFunTy arg res = FunTy arg res
+mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res
+mkFunTy arg res = FunTy arg res
mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = foldr mkFunTy ty tys
splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
splitTyConApp_maybe _ = Nothing
--- | Sometimes we do NOT want to look through a @newtype@. When case matching
--- on a newtype we want a convenient way to access the arguments of a @newtype@
--- constructor so as to properly form a coercion, and so we use 'splitNewTyConApp'
--- instead of 'splitTyConApp_maybe'
-splitNewTyConApp :: Type -> (TyCon, [Type])
-splitNewTyConApp ty = case splitNewTyConApp_maybe ty of
- Just stuff -> stuff
- Nothing -> pprPanic "splitNewTyConApp" (ppr ty)
-splitNewTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
-splitNewTyConApp_maybe ty | Just ty' <- tcView ty = splitNewTyConApp_maybe ty'
-splitNewTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
-splitNewTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
-splitNewTyConApp_maybe _ = Nothing
-
newTyConInstRhs :: TyCon -> [Type] -> Type
--- ^ Unwrap one 'layer' of newtype on a type constructor and it's arguments, using an
+-- ^ Unwrap one 'layer' of newtype on a type constructor and its arguments, using an
-- eta-reduced version of the @newtype@ if possible
newTyConInstRhs tycon tys
= ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
-- | Looks through:
--
-- 1. For-alls
---
-- 2. Synonyms
---
-- 3. Predicates
---
--- 4. Usage annotations
---
--- 5. All newtypes, including recursive ones, but not newtype families
+-- 4. All newtypes, including recursive ones, but not newtype families
--
-- It's useful in the back end of the compiler.
repType :: Type -> Type
go rec_nts (ForAllTy _ ty) -- Look through foralls
= go rec_nts ty
- go rec_nts ty@(TyConApp tc tys) -- Expand newtypes
- | Just _co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes]
- = if tc `elem` rec_nts -- in Type.lhs
- then ty
- else go 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 newtypes
+ | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys
+ = go rec_nts' ty'
go _ ty = ty
+carefullySplitNewType_maybe :: [TyCon] -> TyCon -> [Type] -> Maybe ([TyCon],Type)
+-- Return the representation of a newtype, unless
+-- we've seen it already: see Note [Expanding newtypes]
+carefullySplitNewType_maybe rec_nts tc tys
+ | isNewTyCon tc
+ , not (tc `elem` rec_nts) = Just (rec_nts', newTyConInstRhs tc tys)
+ | otherwise = Nothing
+ where
+ rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+ | otherwise = rec_nts
+
+
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
-- of inspecting the type directly.
\begin{code}
mkForAllTy :: TyVar -> Type -> Type
mkForAllTy tyvar ty
- = mkForAllTys [tyvar] ty
+ = ForAllTy tyvar ty
-- | Wraps foralls over the type using the provided 'TyVar's from left to right
mkForAllTys :: [TyVar] -> Type -> Type
(mkForAllTys (drop n_args tvs) rho_ty)
| otherwise -- Too many type args
= ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty ) -- Zero case gives infnite loop!
- applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
- (drop n_tvs arg_tys)
+ applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty)
+ (drop n_tvs arg_tys)
where
(tvs, rho_ty) = splitForAllTys orig_fun_ty
n_tvs = length tvs
tyFamInsts (FunTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
tyFamInsts (AppTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
tyFamInsts (ForAllTy _ ty) = tyFamInsts ty
+tyFamInsts (PredTy pty) = predFamInsts pty
+
+-- | Finds type family instances occuring in a predicate type after expanding
+-- synonyms.
+predFamInsts :: PredType -> [(TyCon, [Type])]
+predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys)
+predFamInsts (IParam _ ty) = tyFamInsts ty
+predFamInsts (EqPred ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
\end{code}
\begin{code}
tcEqType :: Type -> Type -> Bool
--- ^ Type equality on source types. Does not look through @newtypes@ or 'PredType's
+-- ^ Type equality on source types. Does not look through @newtypes@ or
+-- 'PredType's, but it does look through type synonyms.
tcEqType t1 t2 = isEqual $ cmpType t1 t2
tcEqTypes :: [Type] -> [Type] -> Bool
tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
tcCmpType :: Type -> Type -> Ordering
--- ^ Type ordering on source types. Does not look through @newtypes@ or 'PredType's
+-- ^ Type ordering on source types. Does not look through @newtypes@ or
+-- 'PredType's, but it does look through type synonyms.
tcCmpType t1 t2 = cmpType t1 t2
tcCmpTypes :: [Type] -> [Type] -> Ordering
setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
-extendTvInScope :: TvSubst -> [Var] -> TvSubst
-extendTvInScope (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
+extendTvInScope :: TvSubst -> Var -> TvSubst
+extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env
+
+extendTvInScopeList :: TvSubst -> [Var] -> TvSubst
+extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst
extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty)
substTyWith tvs tys = ASSERT( length tvs == length tys )
substTy (zipOpenTvSubst tvs tys)
+-- | Type substitution making use of an 'TvSubst' that
+-- is assumed to be open, see 'zipOpenTvSubst'
+substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
+substTysWith tvs tys = ASSERT( length tvs == length tys )
+ substTys (zipOpenTvSubst tvs tys)
+
-- | Substitute within a 'Type'
substTy :: TvSubst -> Type -> Type
substTy subst ty | isEmptyTvSubst subst = ty
splitKindFunTys :: Kind -> ([Kind],Kind)
splitKindFunTys k = splitFunTys k
+splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
+splitKindFunTy_maybe = splitFunTy_maybe
+
-- | Essentially 'splitFunTysN' on kinds
splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
splitKindFunTysN k = splitFunTysN k