X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=d01c710bfbc742a0626a5d6170aee1c614c8ec84;hb=b643165c4ac9d8a7864fbf268bd88b0b9a667443;hp=864f4bdcb021d2d556a182b1d1115326cff96d67;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 864f4bd..d01c710 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -1,49 +1,43 @@ % +% (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} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module PprCore ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprCoreAlt, pprRules ) where -#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} %************************************************************************ @@ -84,9 +78,9 @@ pprTopBind (NonRec binder expr) = ppr_binding (binder,expr) $$ text "" pprTopBind (Rec binds) - = vcat [ptext SLIT("Rec {"), + = vcat [ptext (sLit "Rec {"), vcat (map ppr_binding binds), - ptext SLIT("end Rec }"), + ptext (sLit "end Rec }"), text ""] \end{code} @@ -117,17 +111,25 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) -ppr_expr add_par (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd +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 in add_par $ - hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) 2 (pprCoreExpr body) ppr_expr add_par expr@(App fun arg) @@ -135,7 +137,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 @@ -154,13 +156,11 @@ ppr_expr add_par expr@(App fun arg) ppr_expr add_par (Case expr var ty [(con,args,rhs)]) = add_par $ - sep [sep [ptext SLIT("case") <+> pprCoreExpr expr, + 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 '}' ] @@ -169,10 +169,10 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)]) ppr_expr add_par (Case expr var ty alts) = add_par $ - sep [sep [ptext SLIT("case") + sep [sep [ptext (sLit "case") <+> pprCoreExpr expr <+> ifPprDebug (braces (ppr ty)), - ptext SLIT("of") <+> ppr_bndr var <+> char '{'], + ptext (sLit "of") <+> ppr_bndr var <+> char '{'], nest 2 (sep (punctuate semi (map pprCoreAlt alts))), char '}' ] @@ -187,60 +187,39 @@ ppr_expr add_par (Case expr var ty alts) ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = add_par $ vcat [ - hsep [ptext SLIT("let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + hsep [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], nest 2 (pprCoreExpr rhs), - ptext SLIT("} in"), + ptext (sLit "} in"), pprCoreExpr body ] --} ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = add_par - (hang (ptext SLIT("let {")) + (hang (ptext (sLit "let {")) 2 (hsep [ppr_binding (val_bdr,rhs), - ptext SLIT("} in")]) + ptext (sLit "} in")]) $$ pprCoreExpr expr) +-} --- general case (recursive case, too) +-- General case (recursive case, too) ppr_expr add_par (Let bind expr) = add_par $ - sep [hang (ptext keyword) 2 (ppr_bind bind), - hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)] + sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")), + pprCoreExpr expr] where keyword = case bind of - Rec _ -> SLIT("__letrec {") - NonRec _ _ -> SLIT("let {") + Rec _ -> (sLit "letrec {") + NonRec _ _ -> (sLit "let {") 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 + = add_par $ ptext (sLit "__inline_me") <+> pprParendExpr expr ppr_expr add_par (Note (CoreNote s) expr) = add_par $ - sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)], + sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)], pprParendExpr expr] pprCoreAlt (con, args, rhs) @@ -254,11 +233,11 @@ 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 -pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty +pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty pprArg expr = pprParendExpr expr \end{code} @@ -279,15 +258,20 @@ 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 + | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder pprTypedBinder binder - | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder + | isTyVar binder = ptext (sLit "@") <+> pprTyVarBndr binder | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder) pprTyVarBndr :: TyVar -> SDoc @@ -306,7 +290,7 @@ pprTyVarBndr tyvar pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) pprIdBndrInfo info - = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes + = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes where prag_info = inlinePragInfo info occ_info = occInfo info @@ -319,7 +303,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) @@ -331,7 +315,7 @@ pprIdBndrInfo info \begin{code} pprIdDetails :: Id -> SDoc pprIdDetails id | isGlobalId id = ppr (globalIdDetails id) - | isExportedId id = ptext SLIT("[Exported]") + | isExportedId id = ptext (sLit "[Exported]") | otherwise = empty ppIdInfo :: Id -> IdInfo -> SDoc @@ -346,7 +330,7 @@ ppIdInfo b info #endif pprNewStrictness (newStrictnessInfo info), if null rules then empty - else ptext SLIT("RULES:") <+> vcat (map pprRule rules) + else ptext (sLit "RULES:") <+> vcat (map pprRule rules) -- Inline pragma, occ, demand, lbvar info -- printed out with all binders (when debug is on); -- see PprCore.pprIdBndr @@ -370,15 +354,14 @@ pprRules rules = vcat (map pprRule rules) pprRule :: CoreRule -> SDoc pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) - = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name) + = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext 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}