X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=a3c1f6f4235e67ccd9d475cf05356abdd34758be;hb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa;hp=864f4bdcb021d2d556a182b1d1115326cff96d67;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 864f4bd..a3c1f6f 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -1,11 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1996-1998 % -%************************************************************************ -%* * -\section[PprCore]{Printing of Core syntax, including for interfaces} -%* * -%************************************************************************ + +Printing of Core syntax \begin{code} module PprCore ( @@ -17,33 +15,24 @@ module PprCore ( #include "HsVersions.h" import CoreSyn -import CostCentre ( pprCostCentreCore ) -import Var ( Var ) -import Id ( Id, idType, isDataConWorkId_maybe, idArity, - idInfo, globalIdDetails, isGlobalId, isExportedId - ) -import Var ( TyVar, isTyVar, tyVarKind ) -import IdInfo ( IdInfo, megaSeqIdInfo, - inlinePragInfo, occInfo, newDemandInfo, - lbvarInfo, hasNoLBVarInfo, - arityInfo, ppArityInfo, - specInfo, pprNewStrictness, - workerInfo, ppWorkerInfo, - newStrictnessInfo, cafInfo, ppCafInfo, specInfoRules - ) -import NewDemand ( isTop ) +import CostCentre +import Var +import Id +import IdInfo +import NewDemand #ifdef OLD_STRICTNESS -import Id ( idDemandInfo ) -import IdInfo ( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo ) +import Id +import IdInfo #endif -import DataCon ( dataConTyCon ) -import TyCon ( tupleTyConBoxity, isTupleTyCon ) -import Type ( pprParendType, pprType, pprParendKind ) -import BasicTypes ( tupleParens, isNoOcc, isAlwaysActive ) -import Util ( lengthIs ) +import DataCon +import TyCon +import Type +import Coercion +import BasicTypes +import Util import Outputable -import FastString ( mkFastString ) +import FastString \end{code} %************************************************************************ @@ -122,6 +111,14 @@ ppr_expr add_par (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd ppr_expr add_par (Var name) = ppr name ppr_expr add_par (Lit lit) = ppr lit +ppr_expr add_par (Cast expr co) + = add_par $ + sep [pprParendExpr expr, + ptext SLIT("`cast`") <+> parens (pprCo co)] + where + pprCo co = sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)] + + ppr_expr add_par expr@(Lam _ _) = let (bndrs, body) = collectBinders expr @@ -135,7 +132,7 @@ ppr_expr add_par expr@(App fun arg) let pp_args = sep (map pprArg args) val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples - pp_tup_args = sep (punctuate comma (map pprArg val_args)) + pp_tup_args = sep (punctuate comma (map pprCoreExpr val_args)) in case fun of Var f -> case isDataConWorkId_maybe f of @@ -156,11 +153,9 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)]) = add_par $ sep [sep [ptext SLIT("case") <+> pprCoreExpr expr, ifPprDebug (braces (ppr ty)), - hsep [ptext SLIT("of"), - ppr_bndr var, - char '{', - ppr_case_pat con args - ]], + sep [ptext SLIT("of") <+> ppr_bndr var, + char '{' <+> ppr_case_pat con args] + ], pprCoreExpr rhs, char '}' ] @@ -214,27 +209,6 @@ ppr_expr add_par (Let bind expr) ppr_expr add_par (Note (SCC cc) expr) = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr]) -#ifdef DEBUG -ppr_expr add_par (Note (Coerce to_ty from_ty) expr) - = add_par $ - getPprStyle $ \ sty -> - if debugStyle sty then - sep [ptext SLIT("__coerce") <+> - sep [pprParendType to_ty, pprParendType from_ty], - pprParendExpr expr] - else - sep [hsep [ptext SLIT("__coerce"), pprParendType to_ty], - pprParendExpr expr] -#else -ppr_expr add_par (Note (Coerce to_ty from_ty) expr) - = add_par $ - sep [sep [ptext SLIT("__coerce"), nest 2 (pprParendType to_ty)], - pprParendExpr expr] -#endif - -ppr_expr add_par (Note InlineCall expr) - = add_par (ptext SLIT("__inline_call") <+> pprParendExpr expr) - ppr_expr add_par (Note InlineMe expr) = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr @@ -254,7 +228,7 @@ ppr_case_pat con@(DataAlt dc) args tc = dataConTyCon dc ppr_case_pat con args - = ppr con <+> hsep (map ppr_bndr args) <+> arrow + = ppr con <+> sep (map ppr_bndr args) <+> arrow where ppr_bndr = pprBndr CaseBind @@ -279,8 +253,13 @@ pprCoreBinder LetBind binder -- Lambda bound type variables are preceded by "@" pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr) --- Case bound things don't get a signature or a herald -pprCoreBinder CaseBind bndr = pprUntypedBinder bndr +-- Case bound things don't get a signature or a herald, unless we have debug on +pprCoreBinder CaseBind bndr + = getPprStyle $ \ sty -> + if debugStyle sty then + parens (pprTypedBinder bndr) + else + pprUntypedBinder bndr pprUntypedBinder binder | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind @@ -319,7 +298,7 @@ pprIdBndrInfo info doc | no_info = empty | otherwise - = brackets $ hcat [ppr prag_info, ppr occ_info, + = brackets $ hsep [ppr prag_info, ppr occ_info, ppr dmd_info, ppr lbv_info #ifdef OLD_STRICTNESS , ppr (demandInfo id) @@ -375,10 +354,9 @@ pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) - = doubleQuotes (ftext name) <+> ppr act <+> - sep [ - ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)), - nest 2 (ppr fn <+> sep (map pprArg tpl_args)), - nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs) - ] <+> semi + = hang (doubleQuotes (ftext name) <+> ppr act) + 4 (sep [ptext SLIT("forall") <+> braces (sep (map pprTypedBinder tpl_vars)), + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), + nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs) + ]) \end{code}