X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTypeRep.lhs;h=90fb9a300f45e06ba7c8c19fd1bde3795fbad17f;hb=12e244ccac8f2215dcbdaceafe587a15b3f7bcf4;hp=a00b86f6280d47ddfd5798cc9bc962312e5417f8;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index a00b86f..90fb9a3 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -5,9 +5,11 @@ \begin{code} module TypeRep ( - Type(..), TyNote(..), SourceType(..), -- Representation visible to friends + TyThing(..), + Type(..), TyNote(..), -- Representation visible + PredType(..), -- to friends - Kind, TauType, PredType, ThetaType, -- Synonyms + Kind, ThetaType, -- Synonyms TyVarSubst, superKind, superBoxity, -- KX and BX respectively @@ -15,33 +17,40 @@ module TypeRep ( 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" --- 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 Var ( Id, TyVar, tyVarKind ) +import VarEnv ( TyVarEnv ) +import VarSet ( TyVarSet ) +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 ) -- 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} %************************************************************************ @@ -113,13 +122,28 @@ 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: 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. + +* 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 + -The TyCon still says "I'm a newtype", but we do not represent the -newtype application as a SourceType; instead as a TyConApp. +* 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'. %************************************************************************ @@ -132,7 +156,6 @@ newtype application as a SourceType; instead as a TyConApp. \begin{code} type SuperKind = Type type Kind = Type -type TauType = Type type TyVarSubst = TyVarEnv Type @@ -148,6 +171,19 @@ data Type -- 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 @@ -156,12 +192,8 @@ data Type TyVar Type - | SourceTy -- A high level source type - SourceType -- ...can be expanded to a representation type... - - | 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 @@ -175,26 +207,18 @@ data TyNote -- The type to which the note is attached is the expanded form. \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. - ------------------------------------- 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 @@ -204,12 +228,10 @@ Here the "Eq a" and "?x :: Int -> Int" and "r\l" are all called *predicates* Predicates are represented inside GHC by PredType: \begin{code} -data SourceType = ClassP Class [Type] -- Class predicate - | IParam Name Type -- Implicit parameter - | NType TyCon [Type] -- A *saturated*, *non-recursive* newtype application - -- [See notes at top about newtypes] +data PredType + = ClassP Class [Type] -- Class predicate + | IParam (IPName Name) Type -- Implicit parameter -type PredType = SourceType -- A subtype for predicates type ThetaType = [PredType] \end{code} @@ -239,8 +261,6 @@ 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 '?' @@ -266,8 +286,8 @@ in two situations: 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 '?'. + 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 @@ -279,6 +299,20 @@ 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) [] @@ -291,13 +325,15 @@ Define boxities: @*@ and @#@ \begin{code} liftedBoxity, unliftedBoxity :: Kind -- :: BX -liftedBoxity = TyConApp (mkKindCon liftedConName superBoxity) [] +liftedBoxity = TyConApp liftedBoxityCon [] +unliftedBoxity = TyConApp unliftedBoxityCon [] -unliftedBoxity = TyConApp (mkKindCon unliftedConName superBoxity) [] +liftedBoxityCon = mkKindCon liftedConName superBoxity +unliftedBoxityCon = mkKindCon unliftedConName superBoxity \end{code} ------------------------------------------ -Define kinds: Type, Type *, Type #, OpenKind, and UsageKind +Define kinds: Type, Type *, Type #, OpenKind \begin{code} typeCon :: KindCon -- :: BX -> KX @@ -310,9 +346,23 @@ 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 -usageKindCon = mkKindCon usageKindConName superKind -usageTypeKind = TyConApp usageKindCon [] +isOpenTypeKind (TyConApp tc []) = tyConName tc == openKindConName +isOpenTypeKind other = False + +isSuperKind (TyConApp tc []) = tyConName tc == superKindName +isSuperKind other = False \end{code} ------------------------------------------ @@ -329,6 +379,36 @@ mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds %************************************************************************ %* * + 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 (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 %* * %************************************************************************ @@ -337,19 +417,152 @@ 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 + -- 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("")) <> + 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}