X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=4f9a5e198ea3ee08cec896a086c5ac607688b3b8;hb=f0273cc816abafdd961c5f47dd8b0b02696f34f0;hp=0c9ad37be5f25e335268f7048ed91d9e11616b04;hpb=cae34044d89a87bd3da83b0e867b4a5d6994079a;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 0c9ad37..4f9a5e1 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -11,8 +11,8 @@ module PprCore ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprIdBndr, - pprCoreBinding, pprCoreBindings, - pprCoreRules, pprCoreRule + pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprCoreRules, pprCoreRule, pprIdCoreRule ) where #include "HsVersions.h" @@ -23,12 +23,13 @@ import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, idInfo, idInlinePragma, idDemandInfo, idOccInfo ) import Var ( isTyVar ) -import IdInfo ( IdInfo, megaSeqIdInfo, occInfo, +import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, - demandInfo, specInfo, + specInfo, cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, - cprInfo, ppCprInfo, lbvarInfo, - workerInfo, ppWorkerInfo + cprInfo, ppCprInfo, + workerInfo, ppWorkerInfo, + tyGenInfo, ppTyGenInfo ) import DataCon ( dataConTyCon ) import TyCon ( tupleTyConBoxity, isTupleTyCon ) @@ -70,6 +71,7 @@ pprCoreBinding = pprTopBind pprCoreEnv pprCoreExpr = ppr_noparend_expr pprCoreEnv pprParendExpr = ppr_parend_expr pprCoreEnv pprArg = ppr_arg pprCoreEnv +pprCoreAlt = ppr_alt pprCoreEnv pprCoreEnv = initCoreEnv pprCoreBinder \end{code} @@ -163,7 +165,7 @@ ppr_expr add_par pe expr@(Lam _ _) in add_par $ hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow) - 4 (ppr_noparend_expr pe body) + 2 (ppr_noparend_expr pe body) ppr_expr add_par pe expr@(App fun arg) = case collectArgs expr of { (fun, args) -> @@ -182,9 +184,9 @@ ppr_expr add_par pe expr@(App fun arg) tc = dataConTyCon dc saturated = length val_args == idArity f - other -> add_par (hang (pOcc pe f) 4 pp_args) + other -> add_par (hang (pOcc pe f) 2 pp_args) - other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args) + other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args) } ppr_expr add_par pe (Case expr var [(con,args,rhs)]) @@ -205,14 +207,12 @@ ppr_expr add_par pe (Case expr var alts) = add_par $ sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr, ptext SLIT("of") <+> ppr_bndr var <+> char '{'], - nest 4 (sep (punctuate semi (map ppr_alt alts))), + nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))), char '}' ] where ppr_bndr = pBndr pe CaseBind - ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args) - 4 (ppr_noparend_expr pe rhs) -- special cases: let ... in let ... -- ("disgusting" SLPJ) @@ -229,7 +229,7 @@ ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = add_par (hang (ptext SLIT("let {")) 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals]) - 4 (ppr_noparend_expr pe rhs), + 2 (ppr_noparend_expr pe rhs), ptext SLIT("} in")]) $$ ppr_noparend_expr pe expr) @@ -260,7 +260,7 @@ ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) #else ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) = add_par $ - sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)], + sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)], ppr_parend_expr pe expr] #endif @@ -270,12 +270,8 @@ ppr_expr add_par pe (Note InlineCall expr) ppr_expr add_par pe (Note InlineMe expr) = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr -ppr_expr add_par pe (Note (TermUsg u) expr) - = getPprStyle $ \ sty -> - if ifaceStyle sty then - ppr_expr add_par pe expr - else - add_par (ppr u <+> ppr_noparend_expr pe expr) +ppr_alt pe (con, args, rhs) + = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs) ppr_case_pat pe con@(DataAlt dc) args | isTupleTyCon tc @@ -313,7 +309,7 @@ pprCoreBinder LambdaBind bndr = pprTypedBinder bndr pprCoreBinder CaseBind bndr = pprUntypedBinder bndr pprUntypedBinder binder - | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder + | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder pprTypedBinder binder @@ -325,6 +321,7 @@ pprTypedBinder binder -- It's important that the type is parenthesised too, at least when -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ... +-- pprIdBndr does *not* print the type -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness pprIdBndr id = ppr id <+> (megaSeqIdInfo (idInfo id) `seq` @@ -340,6 +337,7 @@ ppIdInfo b info = hsep [ ppFlavourInfo (flavourInfo info), ppArityInfo a, + ppTyGenInfo g, ppWorkerInfo (workerInfo info), ppStrictnessInfo s, ppCafInfo c, @@ -351,6 +349,7 @@ ppIdInfo b info ] where a = arityInfo info + g = tyGenInfo info s = strictnessInfo info c = cafInfo info m = cprInfo info @@ -362,6 +361,9 @@ ppIdInfo b info pprCoreRules :: Id -> CoreRules -> SDoc pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules) +pprIdCoreRule :: IdCoreRule -> SDoc +pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule + pprCoreRule :: SDoc -> CoreRule -> SDoc pprCoreRule pp_fn (BuiltinRule _) = ifPprDebug (ptext SLIT("A built in rule")) @@ -370,7 +372,7 @@ pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs) = doubleQuotes (ptext name) <+> sep [ ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)), - nest 4 (pp_fn <+> sep (map pprArg tpl_args)), - nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs) + nest 2 (pp_fn <+> sep (map pprArg tpl_args)), + nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs) ] <+> semi \end{code}