%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
\section[TypeRep]{Type - friends' interface}
\begin{code}
module TypeRep (
TyThing(..),
Type(..),
PredType(..),
Kind, ThetaType,
funTyCon, funTyConName,
pprType, pprParendType, pprTypeApp,
pprTyThing, pprTyThingCategory,
pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind,
isLiftedTypeKindCon, isLiftedTypeKind,
mkArrowKind, mkArrowKinds, isCoercionKind,
coVarPred,
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
argTypeKindTyCon, ubxTupleKindTyCon,
unliftedTypeKindTyConName, openTypeKindTyConName,
ubxTupleKindTyConName, argTypeKindTyConName,
liftedTypeKindTyConName,
tySuperKind, coSuperKind,
isTySuperKind, isCoSuperKind,
tySuperKindTyCon, coSuperKindTyCon,
pprKind, pprParendKind
) where
#include "HsVersions.h"
import DataCon( DataCon, dataConName )
import Var
import Name
import BasicTypes
import TyCon
import Class
import PrelNames
import Outputable
import FastString
import Data.Data hiding ( TyCon )
\end{code}
----------------------
A note about newtypes
----------------------
Consider
newtype N = MkN Int
Then we want N to be represented as an Int, and that's what we arrange.
The front end of the compiler [TcType.lhs] treats N as opaque,
the back end treats it as transparent [Type.lhs].
There's a bit of a problem with recursive newtypes
newtype P = MkP P
newtype Q = MkQ (Q->Q)
Here the 'implicit expansion' we get from treating P and Q as transparent
would give rise to infinite types, which in turn makes eqType diverge.
Similarly splitForAllTys and splitFunTys can get into a loop.
Solution:
* Newtypes are always represented using TyConApp.
* For non-recursive newtypes, P, treat P just like a type synonym after
type-checking is done; i.e. it's opaque during type checking (functions
from TcType) but transparent afterwards (functions from Type).
"Treat P as a type synonym" means "all functions expand NewTcApps
on the fly".
Applications of the data constructor P simply vanish:
P x = x
* For recursive newtypes Q, treat the Q and its representation as
distinct right through the compiler. Applications of the data consructor
use a coerce:
Q = \(x::Q->Q). coerce Q x
They are rare, so who cares if they are a tiny bit less efficient.
The typechecker (TcTyDecls) identifies enough type construtors as 'recursive'
to cut all loops. The other members of the loop may be marked 'non-recursive'.
%************************************************************************
%* *
\subsection{The data type}
%* *
%************************************************************************
\begin{code}
data Type
= TyVarTy TyVar
| AppTy
Type
Type
| TyConApp
TyCon
[Type]
| FunTy
Type
Type
| ForAllTy
TyVar
Type
| PredTy
PredType
deriving (Data, Typeable)
type Kind = Type
type SuperKind = Type
\end{code}
-------------------------------------
Note [PredTy]
\begin{code}
data PredType
= ClassP Class [Type]
| IParam (IPName Name) Type
| EqPred Type Type
deriving (Data, Typeable)
type ThetaType = [PredType]
\end{code}
(We don't support TREX records yet, but the setup is designed
to expand to allow them.)
A Haskell qualified type, such as that for f,g,h above, is
represented using
* a FunTy for the double arrow
* with a PredTy as the function argument
The predicate really does turn into a real extra argument to the
function. If the argument has type (PredTy p) then the predicate p is
represented by evidence (a dictionary, for example, of type (predRepTy p).
Note [Equality predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~
forall a b. (a ~ S b) => a -> b
could be represented by
ForAllTy a (ForAllTy b (FunTy (PredTy (EqPred a (S b))) ...))
OR
ForAllTy a (ForAllTy b (ForAllTy (c::PredTy (EqPred a (S b))) ...))
The latter is what we do. (Unlike for class and implicit parameter
constraints, which do use FunTy.)
Reason:
* FunTy is always a *value* function
* ForAllTy is discarded at runtime
We often need to make a "wildcard" (c::PredTy..). We always use the same
name (wildCoVarName), since it's not mentioned.
%************************************************************************
%* *
TyThing
%* *
%************************************************************************
Despite the fact that DataCon has to be imported via a hi-boot route,
this module seems the right place for TyThing, because it's needed for
funTyCon and all the types in TysPrim.
\begin{code}
data TyThing = AnId Id
| ADataCon DataCon
| ATyCon TyCon
| AClass Class
instance Outputable TyThing where
ppr = pprTyThing
pprTyThing :: TyThing -> SDoc
pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
pprTyThingCategory :: TyThing -> SDoc
pprTyThingCategory (ATyCon _) = ptext (sLit "Type constructor")
pprTyThingCategory (AClass _) = ptext (sLit "Class")
pprTyThingCategory (AnId _) = ptext (sLit "Identifier")
pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor")
instance NamedThing TyThing where
getName (AnId id) = getName id
getName (ATyCon tc) = getName tc
getName (AClass cl) = getName cl
getName (ADataCon dc) = dataConName dc
\end{code}
%************************************************************************
%* *
Wired-in type constructors
%* *
%************************************************************************
We define a few wired-in type constructors here to avoid module knots
\begin{code}
funTyCon, tySuperKindTyCon, coSuperKindTyCon, liftedTypeKindTyCon,
openTypeKindTyCon, unliftedTypeKindTyCon,
ubxTupleKindTyCon, argTypeKindTyCon
:: TyCon
funTyConName, tySuperKindTyConName, coSuperKindTyConName, liftedTypeKindTyConName,
openTypeKindTyConName, unliftedTypeKindTyConName,
ubxTupleKindTyConName, argTypeKindTyConName
:: Name
funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName
coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName
liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind
openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind
unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind
argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind
tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
coSuperKindTyConName = mkPrimTyConName (fsLit "COERCION") coSuperKindTyConKey coSuperKindTyCon
liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon
argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon
funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
key
(ATyCon tycon)
BuiltInSyntax
kindTyConType :: TyCon -> Type
kindTyConType kind = TyConApp kind []
liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind
liftedTypeKind = kindTyConType liftedTypeKindTyCon
unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
openTypeKind = kindTyConType openTypeKindTyCon
argTypeKind = kindTyConType argTypeKindTyCon
ubxTupleKind = kindTyConType ubxTupleKindTyCon
mkArrowKind :: Kind -> Kind -> Kind
mkArrowKind k1 k2 = FunTy k1 k2
mkArrowKinds :: [Kind] -> Kind -> Kind
mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
tySuperKind, coSuperKind :: SuperKind
tySuperKind = kindTyConType tySuperKindTyCon
coSuperKind = kindTyConType coSuperKindTyCon
isTySuperKind :: SuperKind -> Bool
isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
isTySuperKind _ = False
isCoSuperKind :: SuperKind -> Bool
isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey
isCoSuperKind _ = False
isLiftedTypeKindCon :: TyCon -> Bool
isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey
isLiftedTypeKind :: Kind -> Bool
isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc
isLiftedTypeKind _ = False
isCoercionKind :: Kind -> Bool
isCoercionKind (PredTy (EqPred {})) = True
isCoercionKind _ = False
coVarPred :: CoVar -> PredType
coVarPred tv
= ASSERT( isCoVar tv )
case tyVarKind tv of
PredTy eq -> eq
other -> pprPanic "coVarPred" (ppr tv $$ ppr other)
\end{code}
%************************************************************************
%* *
\subsection{The external interface}
%* *
%************************************************************************
@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
defined to use this. @pprParendType@ is the same, except it puts
parens around the type, except for the atomic cases. @pprParendType@
works just by setting the initial context precedence very high.
\begin{code}
data Prec = TopPrec
| FunPrec
| TyConPrec
deriving( Eq, Ord )
maybeParen :: Prec -> Prec -> SDoc -> SDoc
maybeParen ctxt_prec inner_prec pretty
| ctxt_prec < inner_prec = pretty
| otherwise = parens pretty
pprType, pprParendType :: Type -> SDoc
pprType ty = ppr_type TopPrec ty
pprParendType ty = ppr_type TyConPrec ty
pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys
pprPred :: PredType -> SDoc
pprPred (ClassP cls tys) = pprClassPred cls tys
pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
pprPred (EqPred ty1 ty2) = pprEqPred (ty1,ty2)
pprEqPred :: (Type,Type) -> SDoc
pprEqPred (ty1,ty2) = sep [ ppr_type FunPrec ty1
, nest 2 (ptext (sLit "~"))
, ppr_type FunPrec ty2]
pprClassPred :: Class -> [Type] -> SDoc
pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
pprTheta :: ThetaType -> SDoc
pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
pprThetaArrow :: ThetaType -> SDoc
pprThetaArrow [] = empty
pprThetaArrow [pred]
| noParenPred pred = pprPred pred <+> darrow
pprThetaArrow preds = parens (sep (punctuate comma (map pprPred preds))) <+> darrow
noParenPred :: PredType -> Bool
noParenPred (ClassP {}) = True
noParenPred (EqPred {}) = True
noParenPred (IParam {}) = False
instance Outputable Type where
ppr ty = pprType ty
instance Outputable PredType where
ppr = pprPred
instance Outputable name => OutputableBndr (IPName name) where
pprBndr _ n = ppr n
pprKind, pprParendKind :: Kind -> SDoc
pprKind = pprType
pprParendKind = pprParendType
ppr_type :: Prec -> Type -> SDoc
ppr_type _ (TyVarTy tv)
| isSymOcc (getOccName tv) = parens (ppr tv)
| otherwise = ppr tv
ppr_type p (PredTy pred) = maybeParen p TyConPrec $
ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred)
ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
pprType t1 <+> ppr_type TyConPrec t2
ppr_type p ty@(ForAllTy _ _) = ppr_forall_type p ty
ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty
ppr_type p (FunTy ty1 ty2)
=
maybeParen p FunPrec $
sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
where
ppr_fun_tail (FunTy ty1 ty2)
| not (is_pred ty1) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
is_pred (PredTy {}) = True
is_pred _ = False
ppr_forall_type :: Prec -> Type -> SDoc
ppr_forall_type p ty
= maybeParen p FunPrec $
sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
where
(tvs, rho) = split1 [] ty
(ctxt, tau) = split2 [] rho
split1 tvs (ForAllTy tv ty)
| not (isCoVar tv) = split1 (tv:tvs) ty
split1 tvs ty = (reverse tvs, ty)
split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
split2 ps (ForAllTy tv ty)
| isCoVar tv = split2 (coVarPred tv : ps) ty
split2 ps ty = (reverse ps, ty)
ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
ppr_tc_app _ tc []
= ppr_tc tc
ppr_tc_app _ tc [ty]
| tc `hasKey` listTyConKey = brackets (pprType ty)
| tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pprType ty <> ptext (sLit ":]")
| tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*")
| tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
| tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)")
| tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)")
| tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
ppr_tc_app p tc tys
| isTupleTyCon tc && tyConArity tc == length tys
= tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
| otherwise
= ppr_type_app p (getName tc) tys
ppr_type_app :: Prec -> Name -> [Type] -> SDoc
ppr_type_app p tc tys
| is_sym_occ
, [ty1,ty2] <- tys
= maybeParen p FunPrec (sep [ppr_type FunPrec ty1,
pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2])
| otherwise
= maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc))
2 (sep (map pprParendType tys)))
where
is_sym_occ = isSymOcc (getOccName tc)
ppr_tc :: TyCon -> SDoc
ppr_tc tc
= pp_nt_debug <> ppr tc
where
pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
then ptext (sLit "<recnt>")
else ptext (sLit "<nt>"))
| otherwise = empty
pprForAll :: [TyVar] -> SDoc
pprForAll [] = empty
pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot
pprTvBndr :: TyVar -> SDoc
pprTvBndr tv | isLiftedTypeKind kind = ppr tv
| otherwise = parens (ppr tv <+> dcolon <+> pprKind kind)
where
kind = tyVarKind tv
\end{code}
Note [Infix type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
In Haskell 98 you can say
f :: (a ~> b) -> b
and the (~>) is considered a type variable. However, the type
pretty-printer in this module will just see (a ~> b) as
App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b")
So it'll print the type in prefix form. To avoid confusion we must
remember to parenthesise the operator, thus
(~>) a b -> b
See Trac #2766.