X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTypeRep.lhs;h=a3487a43776ae77d40bdb54c3a5f80752d57116b;hb=185995ebb5573136e9c2841c6525f3d0867f23b2;hp=1c74dc1b3e71dd052f4ff07c7d3f1279092a2b89;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 1c74dc1..a3487a4 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -10,41 +10,36 @@ module TypeRep ( 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 - mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX - - funTyCon -#ifdef DEBUG - , crudePprType -#endif + + 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" -import {-# SOURCE #-} DataCon( DataCon ) +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, mkWiredInName, mkInternalName ) -import OccName ( mkOccFS, mkKindOccFS, tcName ) -import BasicTypes ( IPName ) -import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon ) +import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName ) +import OccName ( mkOccFS, tcName ) +import BasicTypes ( IPName, tupleParens ) +import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon, isNewTyCon ) import Class ( Class ) -- others -import PrelNames ( gHC_PRIM, kindConKey, boxityConKey, liftedConKey, - unliftedConKey, typeConKey, anyBoxConKey, - funTyConKey - ) -import SrcLoc ( noSrcLoc ) +import PrelNames ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey ) import Outputable \end{code} @@ -119,7 +114,7 @@ Similarly splitForAllTys and splitFunTys can get into a loop. 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 @@ -149,34 +144,20 @@ to cut all loops. The other members of the loop may be marked 'non-recursive'. \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 + | TyConApp -- Application of a TyCon, including newtypes TyCon -- *Invariant* saturated appliations of FunTyCon and -- 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.] + -- However, *unsaturated* type synonyms, and FunTyCons + -- do appear as TyConApps. (Unsaturated type synonyms + -- can appear as the RHS of a type synonym, for exmaple.) [Type] -- Might not be saturated. | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2] @@ -245,118 +226,6 @@ represented by evidence (a dictionary, for example, of type (predRepTy p). %************************************************************************ %* * -\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} - ------------------------------------------- -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 %* * %************************************************************************ @@ -370,6 +239,21 @@ 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} @@ -382,8 +266,8 @@ data TyThing = AnId Id 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 @@ -396,39 +280,134 @@ funTyConName = mkWiredInName gHC_PRIM funTyConKey Nothing -- No parent object (ATyCon funTyCon) -- Relevant TyCon + BuiltInSyntax \end{code} - %************************************************************************ %* * - Crude printing - For debug purposes, we may want to print a type directly +\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} -#ifdef DEBUG -crudePprType :: Type -> SDoc -crudePprType (TyVarTy tv) = ppr tv -crudePprType (AppTy t1 t2) = crudePprType t1 <+> (parens (crudePprType t2)) -crudePprType (FunTy t1 t2) = crudePprType t1 <+> (parens (crudePprType t2)) -crudePprType (TyConApp tc tys) = ppr_tc_app (ppr tc <> pp_nt tc) tys -crudePprType (NewTcApp tc tys) = ptext SLIT("") <+> ppr_tc_app (ppr tc <> pp_nt tc) tys -crudePprType (ForAllTy tv ty) = sep [ptext SLIT("forall") <+> - parens (ppr tv <+> crudePprType (tyVarKind tv)) <> dot, - crudePprType ty] -crudePprType (PredTy st) = braces (crudePprPredTy st) -crudePprType (NoteTy (SynNote ty1) ty2) = crudePprType ty1 -crudePprType (NoteTy other ty) = crudePprType ty - -crudePprPredTy (ClassP cls tys) = ppr_tc_app (ppr cls) tys -crudePprPredTy (IParam ip ty) = ppr ip <> dcolon <> crudePprType ty - -ppr_tc_app :: SDoc -> [Type] -> SDoc -ppr_tc_app tc tys = tc <+> sep (map (parens . crudePprType) tys) - -pp_nt tc | isNewTyCon tc = ptext SLIT("(nt)") - | otherwise = empty -#endif -\end{code} \ No newline at end of file +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 = 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 (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 (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 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 + | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc + then ptext SLIT("") + else ptext SLIT("") + ) <> ppr tc + | otherwise = ppr tc + +------------------- +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} +