PredType(..), -- to friends
Kind, ThetaType, -- Synonyms
- TyVarSubst,
-
- superKind, superBoxity, -- KX and BX respectively
- liftedBoxity, unliftedBoxity, -- :: BX
- openKindCon, -- :: KX
- typeCon, -- :: BX -> KX
- liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
- isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind,
- mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
funTyCon,
-- Pretty-printing
- pprKind, pprParendKind,
- pprType, pprParendType,
- pprPred, pprTheta, pprThetaArrow, pprClassPred
+ pprType, pprParendType, pprTyThingCategory,
+ pprPred, pprTheta, pprThetaArrow, pprClassPred,
+
+ -- Re-export fromKind
+ liftedTypeKind, unliftedTypeKind, openTypeKind,
+ isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
+ mkArrowKind, mkArrowKinds,
+ pprKind, pprParendKind
) where
#include "HsVersions.h"
import {-# SOURCE #-} DataCon( DataCon, dataConName )
-- friends:
-import Var ( Id, TyVar, tyVarKind )
-import VarEnv ( TyVarEnv )
+import Kind
+import Var ( Var, Id, TyVar, tyVarKind )
import VarSet ( TyVarSet )
-import Name ( Name, NamedThing(..), mkWiredInName, mkInternalName )
-import OccName ( mkOccFS, mkKindOccFS, tcName )
+import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName )
+import OccName ( mkOccNameFS, tcName, parenSymOcc )
import BasicTypes ( IPName, tupleParens )
-import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon,
- tyConArity, tupleTyConBoxity, isTupleTyCon, tyConName )
+import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon, isNewTyCon )
import Class ( Class )
-- others
-import PrelNames ( gHC_PRIM, kindConKey, boxityConKey, liftedConKey,
- unliftedConKey, typeConKey, anyBoxConKey,
- funTyConKey, listTyConKey, parrTyConKey,
- hasKey
- )
-import SrcLoc ( noSrcLoc )
+import PrelNames ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey )
import Outputable
\end{code}
Solution:
-* Newtypes are always represented using NewTcApp, never as TyConApp.
+* 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
\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.
-
- | 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.
+ -- 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
TyNote
Type -- The expanded version
-data TyNote
- = FTVNote TyVarSet -- The free type variables of the noted expression
-
- | 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.
+data TyNote = FTVNote TyVarSet -- The free type variables of the noted expression
\end{code}
-------------------------------------
%************************************************************************
%* *
-\subsection{Kinds}
-%* *
-%************************************************************************
-
-Kinds
-~~~~~
-kind :: KX = kind -> kind
-
- | Type liftedness -- (Type *) is printed as just *
- -- (Type #) is printed as just #
-
- | 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, or indeed type schemes,
- 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
-
-\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) []
-
-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 liftedBoxityCon []
-unliftedBoxity = TyConApp unliftedBoxityCon []
-
-liftedBoxityCon = mkKindCon liftedConName superBoxity
-unliftedBoxityCon = mkKindCon unliftedConName superBoxity
-\end{code}
-
-------------------------------------------
-Define kinds: Type, Type *, Type #, OpenKind
-
-\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 []
-\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
-
-isSuperKind (TyConApp tc []) = tyConName tc == superKindName
-isSuperKind other = False
-\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
-\end{code}
-
-
-%************************************************************************
-%* *
TyThing
%* *
%************************************************************************
| 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)
+ 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
We define a few wired-in type constructors here to avoid module knots
\begin{code}
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind)
- -- You might think that (->) should have type (? -> ? -> *), and you'd be right
+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
-- a prefix way, thus: (->) Int# Int#. And this is unusual.
funTyConName = mkWiredInName gHC_PRIM
- (mkOccFS tcName FSLIT("(->)"))
+ (mkOccNameFS tcName FSLIT("(->)"))
funTyConKey
Nothing -- No parent object
(ATyCon funTyCon) -- Relevant TyCon
+ BuiltInSyntax
\end{code}
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)
+pprClassPred clas tys = parenSymOcc (getOccName clas) (ppr clas)
+ <+> sep (map pprParendType tys)
pprTheta :: ThetaType -> SDoc
pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
-- 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 (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 $
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 _ _)
+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 (FTVNote _) ty) = split1 tvs ty
- split1 tvs ty = (reverse tvs, ty)
+ 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 (FTVNote _) ty) = split2 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
+ = ppr_tc tc
ppr_tc_app p tc [ty]
| tc `hasKey` listTyConKey = brackets (pprType ty)
| tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]")
= tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
| otherwise
= maybeParen p TyConPrec $
- ppr tc <+> sep (map (ppr_type TyConPrec) tys)
+ 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
-
-
--------------------
-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