\begin{code}
module TypeRep (
- Type(..), TyNote(..), PredType(..), -- Representation visible to friends
+ TyThing(..),
+ Type(..), TyNote(..), -- Representation visible
+ PredType(..), -- to friends
- Kind, ThetaType, RhoType, TauType, SigmaType, -- Synonyms
- TyVarSubst,
-
- superKind, superBoxity, -- KX and BX respectively
- liftedBoxity, unliftedBoxity, -- :: BX
- openKindCon, -- :: KX
- typeCon, -- :: BX -> KX
- liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
- mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
-
- usageKindCon, -- :: KX
- usageTypeKind, -- :: KX
- usOnceTyCon, usManyTyCon, -- :: $
- usOnce, usMany, -- :: $
-
- funTyCon
+ Kind, ThetaType, -- Synonyms
+
+ funTyCon,
+
+ -- Pretty-printing
+ pprType, pprParendType, pprTyThingCategory,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred,
+
+ -- Re-export fromKind
+ liftedTypeKind, unliftedTypeKind, openTypeKind,
+ isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
+ mkArrowKind, mkArrowKinds,
+ pprKind, pprParendKind
) where
#include "HsVersions.h"
--- friends:
-import Var ( TyVar )
-import VarEnv
-import VarSet
+import {-# SOURCE #-} DataCon( DataCon, dataConName )
-import Name ( Name )
-import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon )
-import Class ( Class )
+-- friends:
+import Kind
+import Var ( Var, Id, TyVar, tyVarKind )
+import VarSet ( TyVarSet )
+import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName )
+import OccName ( mkOccNameFS, tcName, parenSymOcc )
+import BasicTypes ( IPName, tupleParens )
+import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon, isNewTyCon )
+import Class ( Class )
-- others
-import PrelNames ( superKindName, superBoxityName, liftedConName,
- unliftedConName, typeConName, openKindConName,
- usageKindConName, usOnceTyConName, usManyTyConName,
- funTyConName
- )
+import PrelNames ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey )
+import Outputable
\end{code}
%************************************************************************
( a, b ) No Yes Yes Yes
[a] No Yes Yes Yes
+
+
+ ----------------------
+ 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}
-type SuperKind = Type
-type Kind = Type
-
-type TyVarSubst = TyVarEnv Type
-
data Type
- = TyVarTy TyVar
+ = TyVarTy TyVar
| AppTy
Type -- Function is *not* a TyConApp
- Type
+ Type -- It must be another AppTy, or TyVarTy
+ -- (or NoteTy of these)
- | TyConApp -- Application of a TyCon
- TyCon -- *Invariant* saturated appliations of FunTyCon and
+ | TyConApp -- Application of a TyCon, including newtypes *and* synonyms
+ TyCon -- *Invariant* saturated appliations of FunTyCon and
-- synonyms have their own constructors, below.
+ -- However, *unsaturated* FunTyCons do appear as TyConApps.
+ --
[Type] -- Might not be saturated.
+ -- Even type synonyms are not necessarily saturated;
+ -- for example unsaturated type synonyms can appear as the
+ -- RHS of a type synonym.
| FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
Type
TyVar
Type
- | PredTy -- A Haskell predicate
- PredType
-
- | UsageTy -- A usage-annotated type
- Type -- - Annotation of kind $ (i.e., usage annotation)
- Type -- - Annotated type
+ | PredTy -- A high level source type
+ PredType -- ...can be expanded to a representation type...
| NoteTy -- A type with a note attached
TyNote
Type -- The expanded version
-data TyNote
- = SynNote Type -- The unexpanded version of the type synonym; always a TyConApp
- | FTVNote TyVarSet -- The free type variables of the noted expression
-
-type ThetaType = [PredType]
-type RhoType = Type
-type TauType = Type
-type SigmaType = Type
+data TyNote = FTVNote TyVarSet -- The free type variables of the noted expression
\end{code}
-INVARIANT: UsageTys are optional, but may *only* appear immediately
-under a FunTy (either argument), or at top-level of a Type permitted
-to be annotated (such as the type of an Id). NoteTys are transparent
-for the purposes of this rule.
-
-------------------------------------
- Predicates
+ Source types
+
+A type of the form
+ 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
Consider these examples:
f :: (Eq a) => a -> Int
Predicates are represented inside GHC by PredType:
\begin{code}
-data PredType = ClassP Class [Type]
- | IParam Name Type
+data PredType
+ = ClassP Class [Type] -- Class predicate
+ | IParam (IPName Name) Type -- Implicit parameter
+
+type ThetaType = [PredType]
\end{code}
(We don't support TREX records yet, but the setup is designed
%************************************************************************
%* *
-\subsection{Kinds}
+ TyThing
%* *
%************************************************************************
-Kinds
-~~~~~
-kind :: KX = kind -> kind
-
- | 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 '?'
-
- | kv -- A kind variable; *only* happens during kind checking
-
-boxity :: BX = * -- Lifted
- | # -- Unlifted
- | bv -- A boxity variable; *only* happens during kind checking
-
-There's a little subtyping at the kind level:
- forall b. Type b <: OpenKind
-
-That is, a type of kind (Type b) is OK in a context requiring an OpenKind
-
-OpenKind, written '?', is used as the kind for certain type variables,
-in two situations:
-
-1. The universally quantified type variable(s) for special built-in
- things like error :: forall (a::?). String -> a.
- Here, the 'a' can be instantiated to a lifted or unlifted type.
-
-2. Kind '?' is also used when the typechecker needs to create a fresh
- type variable, one that may very well later be unified with a type.
- For example, suppose f::a, and we see an application (f x). Then a
- must be a function type, so we unify a with (b->c). But what kind
- are b and c? They can be lifted or unlifted types, so we give them
- kind '?'.
-
- When the type checker generalises over a bunch of type variables, it
- makes any that still have kind '?' into kind '*'. So kind '?' is never
- present in an inferred type.
-
-
-------------------------------------------
-Define KX, the type of a kind
- BX, the type of a boxity
+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}
-superKind :: SuperKind -- KX, the type of all kinds
-superKind = TyConApp (mkSuperKindCon superKindName) []
-
-superBoxity :: SuperKind -- BX, the type of all boxities
-superBoxity = TyConApp (mkSuperKindCon superBoxityName) []
-\end{code}
-
-------------------------------------------
-Define boxities: @*@ and @#@
-
-\begin{code}
-liftedBoxity, unliftedBoxity :: Kind -- :: BX
-liftedBoxity = TyConApp (mkKindCon liftedConName superBoxity) []
-
-unliftedBoxity = TyConApp (mkKindCon unliftedConName superBoxity) []
-\end{code}
-
-------------------------------------------
-Define kinds: Type, Type *, Type #, OpenKind, and UsageKind
-
-\begin{code}
-typeCon :: KindCon -- :: BX -> KX
-typeCon = mkKindCon typeConName (superBoxity `FunTy` superKind)
-
-liftedTypeKind, unliftedTypeKind, openTypeKind :: Kind -- Of superkind superKind
-
-liftedTypeKind = TyConApp typeCon [liftedBoxity]
-unliftedTypeKind = TyConApp typeCon [unliftedBoxity]
-
-openKindCon = mkKindCon openKindConName superKind
-openTypeKind = TyConApp openKindCon []
-
-usageKindCon = mkKindCon usageKindConName superKind
-usageTypeKind = TyConApp usageKindCon []
-\end{code}
-
-------------------------------------------
-Define arrow kinds
-
-\begin{code}
-mkArrowKind :: Kind -> Kind -> Kind
-mkArrowKind k1 k2 = k1 `FunTy` k2
-
-mkArrowKinds :: [Kind] -> Kind -> Kind
-mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
+data TyThing = AnId Id
+ | ADataCon DataCon
+ | ATyCon TyCon
+ | AClass Class
+
+instance Outputable TyThing where
+ ppr 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 -- 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}
We define a few wired-in type constructors here to avoid module knots
\begin{code}
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind)
+funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] 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
+ (mkOccNameFS tcName FSLIT("(->)"))
+ funTyConKey
+ Nothing -- No parent object
+ (ATyCon funTyCon) -- Relevant TyCon
+ BuiltInSyntax
\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}
+%* *
+%************************************************************************
+
+@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}
-usOnceTyCon = mkKindCon usOnceTyConName usageTypeKind
-usOnce = TyConApp usOnceTyCon []
-
-usManyTyCon = mkKindCon usManyTyConName usageTypeKind
-usMany = TyConApp usManyTyCon []
+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
+
+------------------
+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 = parenSymOcc (getOccName clas) (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 other ty2) = ppr_type p ty2
+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)
+ = -- 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_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) = split1 (tv:tvs) ty
+ split1 tvs (NoteTy _ ty) = split1 tvs ty
+ split1 tvs ty = (reverse tvs, ty)
+
+ split2 ps (NoteTy _ 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 _ ty) = split2 ps ty
+ split2 ps ty = (reverse ps, ty)
+
+ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
+ppr_tc_app p tc []
+ = ppr_tc 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 tc <+> sep (map (ppr_type TyConPrec) tys)
+
+ppr_tc :: TyCon -> SDoc
+ppr_tc tc = parenSymOcc (getOccName 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 [] = empty
+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
\end{code}
projects / ghc-hetmet.git / blobdiff