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

3 files changed, 28 insertions, 5 deletions

diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index b87d381567..c78516a1f7 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,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
 
diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs
index 431414a1d5..c58262649b 100644
--- a/compiler/main/StaticFlagParser.hs
+++ b/compiler/main/StaticFlagParser.hs
@@ -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)
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index f9be713d32..880206417d 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -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")