Commit 02aef112 authored by Ian Lynagh's avatar Ian Lynagh

Make -dppr-case-as-let a dynamic flag

parent ed7dbe82
......@@ -23,6 +23,7 @@ import DataCon
import TyCon
import Type
import Coercion
import DynFlags
import StaticFlags
import BasicTypes
import Util
......@@ -153,31 +154,30 @@ 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 <+> arrow]
],
pprCoreExpr rhs,
char '}'
]
= sdocWithDynFlags $ \dflags ->
if dopt Opt_PprCaseAsLet dflags
then 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
]
else 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 <+> arrow]
],
pprCoreExpr rhs,
char '}'
]
where
ppr_bndr = pprBndr CaseBind
......
......@@ -308,6 +308,9 @@ data DynFlag
| Opt_HelpfulErrors
| Opt_DeferTypeErrors
-- output style opts
| Opt_PprCaseAsLet
-- temporary flags
| Opt_RunCPS
| Opt_RunCPSZ
......@@ -1788,6 +1791,8 @@ dynamic_flags = [
, Flag "fpackage-trust" (NoArg setPackageTrust)
, Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None))
]
++ map (mkFlag turnOn "d" setDynFlag ) dFlags
++ map (mkFlag turnOff "dno-" unSetDynFlag) dFlags
++ map (mkFlag turnOn "f" setDynFlag ) fFlags
++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags
++ map (mkFlag turnOn "f" setWarningFlag ) fWarningFlags
......@@ -1908,6 +1913,11 @@ fWarningFlags = [
( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ),
( "warn-unsupported-calling-conventions", Opt_WarnUnsupportedCallingConventions, nop ) ]
-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@
dFlags :: [FlagSpec DynFlag]
dFlags = [
( "ppr-case-as-let", Opt_PprCaseAsLet, nop ) ]
-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
fFlags :: [FlagSpec DynFlag]
fFlags = [
......
......@@ -28,7 +28,6 @@ module StaticFlags (
-- Output style options
opt_PprCols,
opt_PprCaseAsLet,
opt_PprStyle_Debug, opt_TraceLevel,
opt_NoDebugOutput,
......@@ -250,10 +249,6 @@ opt_SuppressUniques :: Bool
opt_SuppressUniques
= lookUp (fsLit "-dsuppress-uniques")
-- | Display case expressions with a single alternative as strict let bindings
opt_PprCaseAsLet :: Bool
opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let")
-- | Set the maximum width of the dumps
-- If GHC's command line options are bad then the options parser uses the
-- pretty printer display the error message. In this case the staticFlags
......
......@@ -2724,7 +2724,7 @@
<row>
<entry><option>-dppr-case-as-let</option></entry>
<entry>Print single alternative case expressions as strict lets.</entry>
<entry>static</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
......
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