X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FPprCore.lhs;h=c78516a1f7c7910245ec13ffa56fafca2f55c40e;hb=1e4f900ade324e2db2f886a11d7cb571ad5f180c;hp=209ebfbea0417a847216cf02b9878aa3c5b367fb;hpb=9cb6b74e9877e19efbd4db1c6a0b94997540bb47;p=ghc-hetmet.git diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 209ebfb..c78516a 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -152,11 +152,27 @@ ppr_expr add_par expr@(App {}) } ppr_expr add_par (Case expr var ty [(con,args,rhs)]) + | opt_PprCaseAsLet + = add_par $ + sep [sep [ ptext (sLit "let") + <+> char '{' + <+> ppr_case_pat con args + <+> ptext (sLit "~") + <+> ppr_bndr var + , ptext (sLit "<-") + <+> ppr_expr id expr + , char '}' + <+> ptext (sLit "in") + ] + , pprCoreExpr rhs + ] + + | otherwise = add_par $ sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, ifPprDebug (braces (ppr ty)), sep [ptext (sLit "of") <+> ppr_bndr var, - char '{' <+> ppr_case_pat con args] + char '{' <+> ppr_case_pat con args <+> arrow] ], pprCoreExpr rhs, char '}' @@ -218,23 +234,28 @@ ppr_expr add_par (Note (CoreNote s) expr) pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc pprCoreAlt (con, args, rhs) - = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs) + = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc ppr_case_pat (DataAlt dc) args | isTupleTyCon tc - = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow + = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) where ppr_bndr = pprBndr CaseBind tc = dataConTyCon dc ppr_case_pat con args - = ppr con <+> sep (map ppr_bndr args) <+> arrow + = ppr con <+> sep (map ppr_bndr args) where ppr_bndr = pprBndr CaseBind + +-- | Pretty print the argument in a function application. pprArg :: OutputableBndr a => Expr a -> SDoc -pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty +pprArg (Type ty) + | opt_SuppressTypeApplications = empty + | otherwise = ptext (sLit "@") <+> pprParendType ty + pprArg expr = pprParendExpr expr \end{code} @@ -247,7 +268,7 @@ instance OutputableBndr Var where pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder - | isTyVar binder = pprKindedTyVarBndr binder + | isTyCoVar binder = pprKindedTyVarBndr binder | otherwise = pprTypedBinder binder $$ ppIdInfo binder (idInfo binder) @@ -258,7 +279,7 @@ pprCoreBinder bind_site bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder - | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind + | isTyCoVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc @@ -266,7 +287,7 @@ pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc pprTypedLCBinder bind_site debug_on var | not debug_on && isDeadBinder var = char '_' | not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info - | isTyVar var = parens (pprKindedTyVarBndr var) + | isTyCoVar var = parens (pprKindedTyVarBndr var) | otherwise = parens (hang (pprIdBndr var) 2 (vcat [ dcolon <+> pprType (idType var), pp_unf])) where @@ -277,8 +298,9 @@ pprTypedLCBinder bind_site debug_on var pprTypedBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) pprTypedBinder binder - | isTyVar binder = pprKindedTyVarBndr binder - | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) + | isTyCoVar binder = pprKindedTyVarBndr binder + | opt_SuppressTypeSignatures = empty + | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) @@ -297,6 +319,8 @@ pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) pprIdBndrInfo :: IdInfo -> SDoc pprIdBndrInfo info + | opt_SuppressIdInfo = empty + | otherwise = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes where prag_info = inlinePragInfo info @@ -325,6 +349,8 @@ pprIdBndrInfo info \begin{code} ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo id info + | opt_SuppressIdInfo = empty + | otherwise = showAttributes [ (True, pp_scope <> ppr (idDetails id)) , (has_arity, ptext (sLit "Arity=") <> int arity) @@ -382,14 +408,15 @@ instance Outputable UnfoldingGuidance where instance Outputable UnfoldingSource where ppr InlineCompulsory = ptext (sLit "Compulsory") ppr (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w - ppr InlineRule = ptext (sLit "InlineRule") + ppr InlineStable = ptext (sLit "InlineStable") ppr InlineRhs = ptext (sLit "") instance Outputable Unfolding where - ppr NoUnfolding = ptext (sLit "No unfolding") - ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs - ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con - <+> brackets (pprWithCommas pprParendExpr ops) + ppr NoUnfolding = ptext (sLit "No unfolding") + ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs + ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar) + <+> ppr con + <+> brackets (pprWithCommas pprParendExpr ops) ppr (CoreUnfolding { uf_src = src , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf , uf_is_conlike=conlike, uf_is_cheap=cheap @@ -406,8 +433,8 @@ instance Outputable Unfolding where , ptext (sLit "Expandable=") <> ppr exp , ptext (sLit "Guidance=") <> ppr g ] pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs - pp_rhs | isInlineRuleSource src = pp_tmpl - | otherwise = empty + pp_rhs | isStableSource src = pp_tmpl + | otherwise = empty -- Don't print the RHS or we get a quadratic -- blowup in the size of the printout! \end{code}