Commit 1e4f900a authored by benl's avatar benl

Add -dppr-case-as-let to print "strict lets" as actual lets

parent aa1c7df2
......@@ -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,18 +234,18 @@ 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
......
......@@ -122,6 +122,8 @@ static_flags = [
------ Debugging ----------------------------------------------------
, Flag "dppr-debug" (PassFlag addOpt)
, Flag "dppr-user-length" (AnySuffix addOpt)
, Flag "dppr-case-as-let" (PassFlag addOpt)
, Flag "dsuppress-all" (PassFlag addOpt)
, Flag "dsuppress-uniques" (PassFlag addOpt)
, Flag "dsuppress-coercions" (PassFlag addOpt)
......@@ -129,7 +131,6 @@ static_flags = [
, Flag "dsuppress-type-applications" (PassFlag addOpt)
, Flag "dsuppress-idinfo" (PassFlag addOpt)
, Flag "dsuppress-type-signatures" (PassFlag addOpt)
, Flag "dppr-user-length" (AnySuffix addOpt)
, Flag "dopt-fuel" (AnySuffix addOpt)
, Flag "dtrace-level" (AnySuffix addOpt)
, Flag "dno-debug-output" (PassFlag addOpt)
......
......@@ -21,6 +21,7 @@ module StaticFlags (
-- Output style options
opt_PprUserLength,
opt_PprCaseAsLet,
opt_PprStyle_Debug, opt_TraceLevel,
opt_NoDebugOutput,
......@@ -230,6 +231,11 @@ opt_SuppressTypeSignatures
|| lookUp (fsLit "-dsuppress-type-signatures")
-- | Display case expressions with a single alternative as strict let bindings
opt_PprCaseAsLet :: Bool
opt_PprCaseAsLet
= lookUp (fsLit "-dppr-case-as-let")
opt_PprStyle_Debug :: Bool
opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment