Use dumpSDoc functions to output rules (#7060)

Make -ddump-rules, -ddump-rule-firings and -ddump-rule-rewrites
behave like the other -ddump flags, by using the dumpSDoc function
instance of pprDefiniteTrace.

compiler/main/TidyPgm.lhs

@@ -54,6 +54,7 @@ import FastBool hiding ( fastOr )
 import SrcLoc
 import Util
 import FastString
+import qualified ErrUtils as Err
 
 import Control.Monad
 import Data.Function
@@ -372,11 +373,10 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 
           -- If the endPass didn't print the rules, but ddump-rules is
           -- on, print now
-        ; dumpIfSet dflags (dopt Opt_D_dump_rules dflags
-                     && (not (dopt Opt_D_dump_simpl dflags)))
-                    CoreTidy
-                    (ptext (sLit "rules"))
-                    (pprRulesForUser tidy_rules)
+        ; unless (dopt Opt_D_dump_simpl dflags) $
+            Err.dumpIfSet_dyn dflags Opt_D_dump_rules
+              (showSDoc dflags (ppr CoreTidy <+> ptext (sLit "rules")))
+              (pprRulesForUser tidy_rules)
 
           -- Print one-line size info
         ; let cs = coreBindsStats tidy_binds

compiler/simplCore/Simplify.lhs

@@ -43,13 +43,14 @@ import Rules            ( lookupRule, getRules )
 import BasicTypes       ( isMarkedStrict, Arity )
 import TysPrim          ( realWorldStatePrimTy )
 import BasicTypes       ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
-import MonadUtils	( foldlM, mapAccumLM )
+import MonadUtils	( foldlM, mapAccumLM, liftIO )
 import Maybes           ( orElse, isNothing )
 import Data.List        ( mapAccumL )
 import Outputable
 import FastString
 import Pair
 import Util
+import ErrUtils
 \end{code}
 
 
@@ -1565,23 +1566,26 @@ tryRules env rules fn args call_cont
 
              do { checkedTick (RuleFired (ru_name rule))
                 ; dflags <- getDynFlags
-                ; trace_dump dflags rule rule_rhs $
-                  return (Just (ruleArity rule, rule_rhs)) }}}
+                ; trace_dump dflags rule rule_rhs
+                ; return (Just (ruleArity rule, rule_rhs)) }}}
   where
-    trace_dump dflags rule rule_rhs stuff
-      | not (dopt Opt_D_dump_rule_firings dflags)
-      , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff
-
-      | not (dopt Opt_D_dump_rule_rewrites dflags)
-      = pprDefiniteTrace dflags "Rule fired:" (ftext (ru_name rule)) stuff
+    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]
+
+      | dopt Opt_D_dump_rule_firings dflags
+      = liftIO . dumpSDoc dflags Opt_D_dump_rule_firings "" $
+          vcat [text "Rule fired",
+                ftext (ru_name rule)]
 
       | otherwise
-      = pprDefiniteTrace dflags "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])
-           stuff
+      = return ()
+
 \end{code}
 
 Note [Rules for recursive functions]