Type - public interface
\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 Type (
-- re-exports from TypeRep
TyThing(..), Type, PredType(..), ThetaType,
splitTyConApp_maybe, splitTyConApp,
splitNewTyConApp_maybe, splitNewTyConApp,
- repType, repType', typePrimRep, coreView, tcView, kindView,
+ repType, typePrimRep, coreView, tcView, kindView, rttiView,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy, dropForAlls,
newTyConInstRhs,
-- Lifting and boxity
- isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType,
- isStrictType, isStrictPred,
+ isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
+ isPrimitiveType, isStrictType, isStrictPred,
-- Free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
typeKind, addFreeTyVars,
+ -- Type families
+ tyFamInsts,
+
-- Tidying up for printing
tidyType, tidyTypes,
tidyOpenType, tidyOpenTypes,
-- Comparison
coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
- tcEqPred, tcCmpPred, tcEqTypeX,
+ tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
-- Seq
seqType, seqTypes,
substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
-- Pretty-printing
- pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprForAll,
+ pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind
) where
tcView ty = Nothing
-----------------------------------------------
+rttiView :: Type -> Type
+-- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism
+rttiView (ForAllTy _ ty) = rttiView ty
+rttiView (NoteTy _ ty) = rttiView ty
+rttiView (FunTy PredTy{} ty) = rttiView ty
+rttiView (FunTy NoteTy{} ty) = rttiView ty
+rttiView ty@TyConApp{} | Just ty' <- coreView ty
+ = rttiView ty'
+rttiView (TyConApp tc tys) = mkTyConApp tc (map rttiView tys)
+rttiView ty = ty
+
+-----------------------------------------------
{-# INLINE kindView #-}
kindView :: Kind -> Maybe Kind
-- C.f. coreView, tcView
-- Does the AppTy split, but assumes that any view stuff is already done
repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
-repSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
- Just (tys', ty') -> Just (TyConApp tc tys', ty')
- Nothing -> Nothing
-repSplitAppTy_maybe other = Nothing
+repSplitAppTy_maybe (TyConApp tc tys)
+ | not (isOpenSynTyCon 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
+repSplitAppTy_maybe _other = Nothing
-------------
splitAppTy :: Type -> (Type, Type)
splitAppTy ty = case splitAppTy_maybe ty of
where
split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args
split orig_ty (AppTy ty arg) args = split ty ty (arg:args)
- split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
+ split orig_ty (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
+ in
+ (TyConApp tc tc_args1, tc_args2 ++ args)
split orig_ty (FunTy ty1 ty2) args = ASSERT( null args )
(TyConApp funTyCon [], [ty1,ty2])
split orig_ty ty args = (orig_ty, args)
splitNewTyConApp_maybe other = Nothing
newTyConInstRhs :: TyCon -> [Type] -> Type
-newTyConInstRhs tycon tys =
- let (tvs, ty) = newTyConRhs tycon in substTyWith tvs tys ty
+-- Unwrap one 'layer' of newtype
+-- Use the eta'd version if possible
+newTyConInstRhs tycon tys
+ = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
+ mkAppTys (substTyWith tvs tys1 ty) tys2
+ where
+ (tvs, ty) = newTyConEtadRhs tycon
+ (tys1, tys2) = splitAtList tvs tys
\end{code}
interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
+Note [Expanding newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+When expanding a type to expose a data-type constructor, we need to be
+careful about newtypes, lest we fall into an infinite loop. Here are
+the key examples:
+
+ newtype Id x = MkId x
+ newtype Fix f = MkFix (f (Fix f))
+ newtype T = MkT (T -> T)
+
+ Type Expansion
+ --------------------------
+ T T -> T
+ Fix Maybe Maybe (Fix Maybe)
+ Id (Id Int) Int
+ Fix Id NO NO NO
+
+Notice that we can expand T, even though it's recursive.
+And we can expand Id (Id Int), even though the Id shows up
+twice at the outer level.
+
+So, when expanding, we keep track of when we've seen a recursive
+newtype at outermost level; and bale out if we see it again.
+
+
Representation types
~~~~~~~~~~~~~~~~~~~~
repType looks through
\begin{code}
repType :: Type -> Type
-- Only applied to types of kind *; hence tycons are saturated
-repType ty | Just ty' <- coreView ty = repType ty'
-repType (ForAllTy _ ty) = repType ty
-repType (TyConApp tc tys)
- | isNewTyCon tc
- , (tvs, rep_ty) <- newTyConRep tc
- = -- Recursive newtypes are opaque to coreView
- -- but we must expand them here. Sure to
- -- be saturated because repType is only applied
- -- to types of kind *
- ASSERT( tys `lengthIs` tyConArity tc )
- repType (substTyWith tvs tys rep_ty)
-
-repType ty = ty
-
--- repType' aims to be a more thorough version of repType
--- For now it simply looks through the TyConApp args too
-repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined
- | otherwise = go1 ty
- where
- go1 = go . repType
- go (TyConApp tc tys) = mkTyConApp tc (map repType' tys)
- go ty = ty
+repType ty
+ = go [] ty
+ where
+ go :: [TyCon] -> Type -> Type
+ go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
+ = go rec_nts ty'
+
+ 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 ty = ty
-- ToDo: this could be moved to the code generator, using splitTyConApp instead
%************************************************************************
%* *
+\subsection{Type families}
+%* *
+%************************************************************************
+
+Type family instances occuring in a type after expanding synonyms.
+
+\begin{code}
+tyFamInsts :: Type -> [(TyCon, [Type])]
+tyFamInsts ty
+ | Just exp_ty <- tcView ty = tyFamInsts exp_ty
+tyFamInsts (TyVarTy _) = []
+tyFamInsts (TyConApp tc tys)
+ | isOpenSynTyCon tc = [(tc, tys)]
+ | otherwise = concat (map tyFamInsts tys)
+tyFamInsts (FunTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
+tyFamInsts (AppTy ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
+tyFamInsts (ForAllTy _ ty) = tyFamInsts ty
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{TidyType}
%* *
%************************************************************************
-- Should only be applied to *types*; hence the assert
isAlgType :: Type -> Bool
-isAlgType ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
- isAlgTyCon tc
- other -> False
+isAlgType ty
+ = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
+ isAlgTyCon tc
+ _other -> False
+
+-- Should only be applied to *types*; hence the assert
+isClosedAlgType :: Type -> Bool
+isClosedAlgType ty
+ = case splitTyConApp_maybe ty of
+ Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
+ isAlgTyCon tc && not (isOpenTyCon tc)
+ _other -> False
\end{code}
@isStrictType@ computes whether an argument (or let RHS) should
tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
\end{code}
+Checks whether the second argument is a subterm of the first. (We don't care
+about binders, as we are only interested in syntactic subterms.)
+
+\begin{code}
+tcPartOfType :: Type -> Type -> Bool
+tcPartOfType t1 t2
+ | tcEqType t1 t2 = True
+tcPartOfType t1 t2
+ | Just t2' <- tcView t2 = tcPartOfType t1 t2'
+tcPartOfType _ (TyVarTy _) = False
+tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2
+tcPartOfType t1 (AppTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2
+tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts
+tcPartOfType t1 (NoteTy _ t2) = tcPartOfType t1 t2
+
+tcPartOfPred :: Type -> PredType -> Bool
+tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2
+tcPartOfPred t1 (ClassP _ ts) = any (tcPartOfType t1) ts
+tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+\end{code}
+
Now here comes the real worker
\begin{code}