\begin{code}
module TypeRep (
+ TyThing(..),
Type(..), TyNote(..), -- Representation visible
- SourceType(..), -- to friends
+ PredType(..), -- to friends
- Kind, PredType, ThetaType, -- Synonyms
+ Kind, ThetaType, -- Synonyms
TyVarSubst,
superKind, superBoxity, -- KX and BX respectively
openKindCon, -- :: KX
typeCon, -- :: BX -> KX
liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
+ isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind,
mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
- usageKindCon, -- :: KX
- usageTypeKind, -- :: KX
- usOnceTyCon, usManyTyCon, -- :: $
- usOnce, usMany, -- :: $
+ funTyCon,
- funTyCon
+ -- Pretty-printing
+ pprKind, pprParendKind,
+ pprType, pprParendType,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
#include "HsVersions.h"
+import {-# SOURCE #-} DataCon( DataCon, dataConName )
+
-- friends:
-import Var ( TyVar )
+import Var ( Id, TyVar, tyVarKind )
import VarEnv ( TyVarEnv )
import VarSet ( TyVarSet )
-import Name ( Name )
-import BasicTypes ( IPName )
-import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon )
+import Name ( Name, NamedThing(..), mkWiredInName, mkInternalName )
+import OccName ( mkOccFS, mkKindOccFS, tcName )
+import BasicTypes ( IPName, tupleParens )
+import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon,
+ tyConArity, tupleTyConBoxity, isTupleTyCon, tyConName )
import Class ( Class )
-import Binary
-- others
-import PrelNames ( superKindName, superBoxityName, liftedConName,
- unliftedConName, typeConName, openKindConName,
- usageKindConName, usOnceTyConName, usManyTyConName,
- funTyConName
+import PrelNames ( gHC_PRIM, kindConKey, boxityConKey, liftedConKey,
+ unliftedConKey, typeConKey, anyBoxConKey,
+ funTyConKey, listTyConKey, parrTyConKey,
+ hasKey
)
+import SrcLoc ( noSrcLoc )
+import Outputable
\end{code}
%************************************************************************
would give rise to infinite types, which in turn makes eqType diverge.
Similarly splitForAllTys and splitFunTys can get into a loop.
-Solution: for recursive newtypes use a coerce, and treat the newtype
-and its representation as distinct right through the compiler. That's
-what you get if you use recursive newtypes. (They are rare, so who
-cares if they are a tiny bit less efficient.)
+Solution:
+
+* Newtypes are always represented using NewTcApp, never as TyConApp.
-So: non-recursive newtypes are represented using a SourceTy (see below)
- recursive newtypes are represented using a 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".
-The TyCon still says "I'm a newtype", but we do not represent the
-newtype application as a SourceType; instead as a TyConApp.
+ 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.
-NOTE: currently [March 02] we regard a newtype as 'recursive' if it's in a
-mutually recursive group. That's a bit conservative: only if there's a loop
-consisting only of newtypes do we need consider it as recursive. But it's
-not so easy to discover that, and the situation isn't that common.
+The typechecker (TcTyDecls) identifies enough type construtors as 'recursive'
+to cut all loops. The other members of the loop may be marked 'non-recursive'.
%************************************************************************
-- synonyms have their own constructors, below.
[Type] -- Might not be saturated.
+ | NewTcApp -- Application of a NewType TyCon. All newtype applications
+ TyCon -- show up like this until they are fed through newTypeRep,
+ -- which returns
+ -- * an ordinary TyConApp for non-saturated,
+ -- or recursive newtypes
+ --
+ -- * the representation type of the newtype for satuarted,
+ -- non-recursive ones
+ -- [But the result of a call to newTypeRep is always consumed
+ -- immediately; it never lives on in another type. So in any
+ -- type, newtypes are always represented with NewTcApp.]
+ [Type] -- Might not be saturated.
+
| FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
Type
Type
TyVar
Type
- | SourceTy -- A high level source type
- SourceType -- ...can be expanded to a representation type...
+ | PredTy -- A high level source type
+ PredType -- ...can be expanded to a representation type...
| NoteTy -- A type with a note attached
TyNote
| SynNote Type -- Used for type synonyms
-- The Type is always a TyConApp, and is the un-expanded form.
-- The type to which the note is attached is the expanded form.
-
\end{code}
-------------------------------------
Source types
A type of the form
- SourceTy sty
-represents a value whose type is the Haskell source type sty.
+ PredTy p
+represents a value whose type is the Haskell predicate p,
+where a predicate is what occurs before the '=>' in a Haskell type.
It can be expanded into its representation, but:
* The type checker must treat it as opaque
* The rest of the compiler treats it as transparent
-There are two main uses
- a) Haskell predicates
- b) newtypes
-
Consider these examples:
f :: (Eq a) => a -> Int
g :: (?x :: Int -> Int) => a -> Int
Predicates are represented inside GHC by PredType:
\begin{code}
-data SourceType
+data PredType
= ClassP Class [Type] -- Class predicate
| IParam (IPName Name) Type -- Implicit parameter
- | NType TyCon [Type] -- A *saturated*, *non-recursive* newtype application
- -- [See notes at top about newtypes]
-type PredType = SourceType -- A subtype for predicates
type ThetaType = [PredType]
\end{code}
| Type liftedness -- (Type *) is printed as just *
-- (Type #) is printed as just #
- | UsageKind -- Printed '$'; used for usage annotations
-
| OpenKind -- Can be lifted or unlifted
-- Printed '?'
BX, the type of a boxity
\begin{code}
+superKindName = kindQual FSLIT("KX") kindConKey
+superBoxityName = kindQual FSLIT("BX") boxityConKey
+liftedConName = kindQual FSLIT("*") liftedConKey
+unliftedConName = kindQual FSLIT("#") unliftedConKey
+openKindConName = kindQual FSLIT("?") anyBoxConKey
+typeConName = kindQual FSLIT("Type") typeConKey
+
+kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) noSrcLoc
+ -- Kinds are not z-encoded in interface file, hence mkKindOccFS
+ -- And they don't come from any particular module; indeed we always
+ -- want to print them unqualified. Hence the InternalName.
+\end{code}
+
+\begin{code}
superKind :: SuperKind -- KX, the type of all kinds
superKind = TyConApp (mkSuperKindCon superKindName) []
\end{code}
------------------------------------------
-Define kinds: Type, Type *, Type #, OpenKind, and UsageKind
+Define kinds: Type, Type *, Type #, OpenKind
\begin{code}
typeCon :: KindCon -- :: BX -> KX
openKindCon = mkKindCon openKindConName superKind
openTypeKind = TyConApp openKindCon []
+\end{code}
+
+\begin{code}
+isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind :: Kind -> Bool
+isLiftedTypeKind (TyConApp tc [TyConApp bc []]) = tyConName tc == typeConName &&
+ tyConName bc == liftedConName
+isLiftedTypeKind other = False
+
+isUnliftedTypeKind (TyConApp tc [TyConApp bc []]) = tyConName tc == typeConName &&
+ tyConName bc == unliftedConName
+isUnliftedTypeKind other = False
+
+isOpenTypeKind (TyConApp tc []) = tyConName tc == openKindConName
+isOpenTypeKind other = False
-usageKindCon = mkKindCon usageKindConName superKind
-usageTypeKind = TyConApp usageKindCon []
+isSuperKind (TyConApp tc []) = tyConName tc == superKindName
+isSuperKind other = False
\end{code}
------------------------------------------
mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
\end{code}
------------------------------------------------------------------------------
-Binary kinds for interface files
+
+%************************************************************************
+%* *
+ 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}
-instance Binary Kind where
- put_ bh k@(TyConApp tc [])
- | tc == openKindCon = putByte bh 0
- | tc == usageKindCon = putByte bh 1
- put_ bh k@(TyConApp tc [TyConApp bc _])
- | tc == typeCon && bc == liftedBoxityCon = putByte bh 2
- | tc == typeCon && bc == unliftedBoxityCon = putByte bh 3
- put_ bh (FunTy f a) = do putByte bh 4; put_ bh f; put_ bh a
- put_ bh _ = error "Binary.put(Kind): strange-looking Kind"
-
- get bh = do
- b <- getByte bh
- case b of
- 0 -> return openTypeKind
- 1 -> return usageTypeKind
- 2 -> return liftedTypeKind
- 3 -> return unliftedTypeKind
- _ -> do f <- get bh; a <- get bh; return (FunTy f a)
+data TyThing = AnId Id
+ | ADataCon DataCon
+ | ATyCon TyCon
+ | AClass Class
+
+instance Outputable TyThing where
+ ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
+ ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
+ ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
+ ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr (dataConName dc)
+
+instance NamedThing TyThing where -- Can't put this with the type
+ getName (AnId id) = getName id -- decl, because the DataCon instance
+ getName (ATyCon tc) = getName tc -- isn't visible there
+ getName (AClass cl) = getName cl
+ getName (ADataCon dc) = dataConName dc
\end{code}
+
%************************************************************************
%* *
\subsection{Wired-in type constructors
\begin{code}
funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind)
+ -- You might think that (->) should have type (? -> ? -> *), and you'd be right
+ -- But if we do that we get kind errors when saying
+ -- instance Control.Arrow (->)
+ -- becuase the expected kind is (*->*->*). The trouble is that the
+ -- expected/actual stuff in the unifier does not go contra-variant, whereas
+ -- the kind sub-typing does. Sigh. It really only matters if you use (->) in
+ -- a prefix way, thus: (->) Int# Int#. And this is unusual.
+
+funTyConName = mkWiredInName gHC_PRIM
+ (mkOccFS tcName FSLIT("(->)"))
+ funTyConKey
+ Nothing -- No parent object
+ (ATyCon funTyCon) -- Relevant TyCon
\end{code}
-------------------------------------------
-Usage tycons @.@ and @!@
-The usage tycons are of kind usageTypeKind (`$'). The types contain
-no values, and are used purely for usage annotation.
+%************************************************************************
+%* *
+\subsection{The external interface}
+%* *
+%************************************************************************
-\begin{code}
-usOnceTyCon = mkKindCon usOnceTyConName usageTypeKind
-usOnce = TyConApp usOnceTyCon []
+@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.
-usManyTyCon = mkKindCon usManyTyConName usageTypeKind
-usMany = TyConApp usManyTyCon []
+\begin{code}
+data Prec = TopPrec -- No parens
+ | FunPrec -- Function args; no parens for tycon apps
+ | TyConPrec -- Tycon args; no parens for atomic
+ 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
+
+------------------
+pprKind, pprParendKind :: Kind -> SDoc
+pprKind k = ppr_kind TopPrec k
+pprParendKind k = ppr_kind TyConPrec k
+
+------------------
+pprPred :: PredType -> SDoc
+pprPred (ClassP cls tys) = pprClassPred cls tys
+pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
+
+pprClassPred :: Class -> [Type] -> SDoc
+pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
+
+pprTheta :: ThetaType -> SDoc
+pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
+
+pprThetaArrow :: ThetaType -> SDoc
+pprThetaArrow theta
+ | null theta = empty
+ | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>")
+
+------------------
+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 -- Simple for now
+
+------------------
+ -- OK, here's the main printer
+
+ppr_type :: Prec -> Type -> SDoc
+ppr_type p (TyVarTy tv) = ppr tv
+ppr_type p (PredTy pred) = braces (ppr pred)
+ppr_type p (NoteTy (SynNote ty1) ty2) = ppr_type p ty1
+ppr_type p (NoteTy other ty2) = ppr_type p ty2
+
+ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
+ppr_type p (NewTcApp tc tys) = ifPprDebug (ptext SLIT("<nt>")) <>
+ ppr_tc_app p tc tys
+
+ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
+ pprType t1 <+> ppr_type TyConPrec t2
+
+ppr_type p (FunTy ty1 ty2)
+ = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
+ maybeParen p FunPrec $
+ sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
+ where
+ ppr_fun_tail (FunTy ty1 ty2) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
+ ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
+
+ppr_type p ty@(ForAllTy _ _)
+ = maybeParen p FunPrec $
+ sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
+ where
+ (tvs, rho) = split1 [] ty
+ (ctxt, tau) = split2 [] rho
+
+ split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+ split1 tvs (NoteTy (FTVNote _) ty) = split1 tvs ty
+ split1 tvs ty = (reverse tvs, ty)
+
+ split2 ps (NoteTy (FTVNote _) arg -- Rather a disgusting case
+ `FunTy` res) = split2 ps (arg `FunTy` res)
+ split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
+ split2 ps (NoteTy (FTVNote _) ty) = split2 ps ty
+ split2 ps ty = (reverse ps, ty)
+
+ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
+ppr_tc_app p tc []
+ = ppr tc
+ppr_tc_app p tc [ty]
+ | tc `hasKey` listTyConKey = brackets (pprType ty)
+ | tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]")
+ppr_tc_app p tc tys
+ | isTupleTyCon tc && tyConArity tc == length tys
+ = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
+ | otherwise
+ = maybeParen p TyConPrec $
+ ppr tc <+> sep (map (ppr_type TyConPrec) tys)
+
+-------------------
+pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
+
+pprTvBndr tv | isLiftedTypeKind kind = ppr tv
+ | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind)
+ where
+ kind = tyVarKind tv
+
+
+-------------------
+ppr_kind :: Prec -> Kind -> SDoc
+ppr_kind p k
+ | isOpenTypeKind k = ptext SLIT("?")
+ | isLiftedTypeKind k = ptext SLIT("*")
+ | isUnliftedTypeKind k = ptext SLIT("#")
+ppr_kind p (TyVarTy tv) = ppr tv
+ppr_kind p (FunTy k1 k2) = maybeParen p FunPrec $
+ sep [ ppr_kind FunPrec k1, arrow <+> pprKind k2]
+ppr_kind p other = ptext SLIT("STRANGE KIND:") <+> ppr_type p other
\end{code}
projects / ghc-hetmet.git / blobdiff