[commit: ghc] master: Restore old output for -ddump-rule-firings #7060 (f8a00d0)

[Paolo Capriotti]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/f8a00d0e4ac1f94f6ccf3da3ee6c208cdbce8d65

>---------------------------------------------------------------

commit f8a00d0e4ac1f94f6ccf3da3ee6c208cdbce8d65
Author: Paolo Capriotti <p.capriotti at gmail.com>
Date:   Tue Jul 17 16:11:02 2012 +0100

    Restore old output for -ddump-rule-firings #7060
    
    Commit 3fcf5bdff7a22e22d7265535369cd8f867141ec1 made the output of
    -ddump-rule-firings and -ddump-rule-rewrites excessively verbose.
    
    Fixed by removing the extra blank lines and separator when the header
    of dump is empty.

>---------------------------------------------------------------

 compiler/main/ErrUtils.lhs      |    7 +++++--
 compiler/simplCore/Simplify.lhs |   19 ++++++++++---------
 2 files changed, 15 insertions(+), 11 deletions(-)

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index daa66f9..84722aa 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -251,8 +251,11 @@ dumpSDoc dflags dflag hdr doc
                         hClose handle
 
             -- write the dump to stdout
-            Nothing
-                 -> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
+            Nothing -> do
+              let (doc', severity)
+                    | null hdr  = (doc, SevOutput)
+                    | otherwise = (mkDumpDoc hdr doc, SevDump)
+              log_action dflags dflags severity noSrcSpan defaultDumpStyle doc'
 
 
 -- | Choose where to put a dump file based on DynFlags
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index df9013c..f2ed224 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1571,21 +1571,22 @@ tryRules env rules fn args call_cont
   where
     trace_dump dflags rule rule_rhs
       | dopt Opt_D_dump_rule_rewrites dflags
-      = liftIO . dumpSDoc dflags Opt_D_dump_rule_rewrites "" $
-           vcat [text "Rule fired",
-                 text "Rule:" <+> ftext (ru_name rule),
-                 text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)),
-                 text "After: " <+> pprCoreExpr rule_rhs,
-                 text "Cont:  " <+> ppr call_cont]
+      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
+          [ text "Rule:" <+> ftext (ru_name rule)
+          , text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args))
+          , text "After: " <+> pprCoreExpr rule_rhs
+          , text "Cont:  " <+> ppr call_cont ]
 
       | dopt Opt_D_dump_rule_firings dflags
-      = liftIO . dumpSDoc dflags Opt_D_dump_rule_firings "" $
-          vcat [text "Rule fired",
-                ftext (ru_name rule)]
+      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
+          ftext (ru_name rule)
 
       | otherwise
       = return ()
 
+    log_rule dflags dflag hdr details = liftIO . dumpSDoc dflags dflag "" $
+      sep [text hdr, nest 4 details]
+
 \end{code}
 
 Note [Rules for recursive functions]