X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTypeRep.lhs;h=7bb863a210e37841c77a8b7be7a6dac00985a439;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=5c4bd3315ac6788f873251a9c359df3f4f13216e;hpb=da95f4a039f7bc12b625338353df8399dec41c5e;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 5c4bd33..7bb863a 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -33,9 +33,9 @@ import Kind import Var ( Var, Id, TyVar, tyVarKind ) import VarSet ( TyVarSet ) import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName ) -import OccName ( mkOccFS, tcName ) +import OccName ( mkOccNameFS, tcName, parenSymOcc ) import BasicTypes ( IPName, tupleParens ) -import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon ) +import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon, isNewTyCon ) import Class ( Class ) -- others @@ -114,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 @@ -148,27 +148,19 @@ data Type = TyVarTy TyVar | AppTy - Type -- Function is *not* a TyConApp or NewTcApp + Type -- Function is *not* a TyConApp 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 @@ -185,12 +177,7 @@ data 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} ------------------------------------- @@ -286,7 +273,7 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif -- 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 @@ -327,7 +314,8 @@ 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))) @@ -351,21 +339,17 @@ instance Outputable name => OutputableBndr (IPName name) where -- 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 (if isRecursiveTyCon tc - then ptext SLIT("") - else ptext SLIT("") - ) <> - 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 $ @@ -374,26 +358,27 @@ ppr_type p (FunTy ty1 ty2) 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 (FTVNote _) arg -- Rather a disgusting case + 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(":]") @@ -402,9 +387,18 @@ ppr_tc_app p tc tys = 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("") + else ptext SLIT("")) + | otherwise = empty ------------------- +pprForAll [] = empty pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr tv | isLiftedTypeKind kind = ppr tv