Add GHC-API logging hooks

* Add 'dumpAction' hook to DynFlags.

It allows GHC API users to catch dumped intermediate codes and
information. The format of the dump (Core, Stg, raw text, etc.) is now
reported allowing easier automatic handling.

* Add 'traceAction' hook to DynFlags.

Some dumps go through the trace mechanism (for instance unfoldings that
have been considered for inlining). This is problematic because:
1) dumps aren't written into files even with -ddump-to-file on
2) dumps are written on stdout even with GHC API
3) in this specific case, dumping depends on unsafe globally stored
DynFlags which is bad for GHC API users

We introduce 'traceAction' hook which allows GHC API to catch those
traces and to avoid using globally stored DynFlags.

* Avoid dumping empty logs via dumpAction/traceAction (but still write
empty files to keep the existing behavior)

37 files changed, 323 insertions, 193 deletions

diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
index 1486dde365..713656c6ff 100644
--- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs
+++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -90,7 +90,7 @@ tracePm herald doc = do
   dflags <- getDynFlags
   printer <- mkPrintUnqualifiedDs
   liftIO $ dumpIfSet_dyn_printer printer dflags
-            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))
+            Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc))
 
 -- | Generate a fresh `Id` of a given type
 mkPmId :: Type -> DsM Id
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 071ec9442e..fbabea8f66 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -45,7 +45,7 @@ cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline")
      tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
 
      (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops
-     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)
+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms)
 
      return (srtInfo, cmms)
 
@@ -92,7 +92,7 @@ cpsTop hsc_env proc =
                pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
                   minimalProcPointSet (targetPlatform dflags) call_pps g
                dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
-                     (ppr l $$ ppr pp $$ ppr g)
+                     FormatCMM (ppr l $$ ppr pp $$ ppr g)
                return pp
              else
                return call_pps
@@ -112,15 +112,15 @@ cpsTop hsc_env proc =
 
        ------------- CAF analysis ----------------------------------------------
        let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g
-       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)
+       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv)
 
        g <- if splitting_proc_points
             then do
                ------------- Split into separate procedures -----------------------
                let pp_map = {-# SCC "procPointAnalysis" #-}
                             procPointAnalysis proc_points g
-               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $
-                    ppr pp_map
+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"
+                  FormatCMM (ppr pp_map)
                g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
                     splitAtProcPoints dflags l call_pps proc_points pp_map
                                       (CmmProc h l v g)
@@ -151,7 +151,7 @@ cpsTop hsc_env proc =
         dump = dumpGraph dflags
 
         dumps flag name
-           = mapM_ (dumpWith dflags flag name . ppr)
+           = mapM_ (dumpWith dflags flag name FormatCMM . ppr)
 
         condPass flag pass g dumpflag dumpname =
             if gopt flag dflags
@@ -347,7 +347,7 @@ runUniqSM m = do
 dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
 dumpGraph dflags flag name g = do
   when (gopt Opt_DoCmmLinting dflags) $ do_lint g
-  dumpWith dflags flag name (ppr g)
+  dumpWith dflags flag name FormatCMM (ppr g)
  where
   do_lint g = case cmmLintGraph dflags g of
                  Just err -> do { fatalErrorMsg dflags err
@@ -355,12 +355,13 @@ dumpGraph dflags flag name g = do
                                 }
                  Nothing  -> return ()
 
-dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
-dumpWith dflags flag txt sdoc = do
-  dumpIfSet_dyn dflags flag txt sdoc
+dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
+dumpWith dflags flag txt fmt sdoc = do
+  dumpIfSet_dyn dflags flag txt fmt sdoc
   when (not (dopt flag dflags)) $
     -- If `-ddump-cmm-verbose -ddump-to-file` is specified,
     -- dump each Cmm pipeline stage output to a separate file.  #16930
     when (dopt Opt_D_dump_cmm_verbose dflags)
-      $ dumpSDoc dflags alwaysQualify flag txt sdoc
-  dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt sdoc
+      $ dumpAction dflags (mkDumpStyle dflags alwaysQualify)
+                   (dumpOptionsFromFlag flag) txt fmt sdoc
+  dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 3ebad40adb..6f551c009f 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -259,8 +259,10 @@ dumpPassResult :: DynFlags
                -> CoreProgram -> [CoreRule]
                -> IO ()
 dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
-  = do { forM_ mb_flag $ \flag ->
-           Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
+  = do { forM_ mb_flag $ \flag -> do
+           let sty = mkDumpStyle dflags unqual
+           dumpAction dflags sty (dumpOptionsFromFlag flag)
+              (showSDoc dflags hdr) FormatCore dump_doc
 
          -- Report result size
          -- This has the side effect of forcing the intermediate to be evaluated
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index de3c96ba45..d4451e9ff8 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -138,7 +138,7 @@ simpleOptPgm :: DynFlags -> Module
 -- See Note [The simple optimiser]
 simpleOptPgm dflags this_mod binds rules
   = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
-                       (pprCoreBindings occ_anald_binds $$ pprRules rules );
+            FormatCore (pprCoreBindings occ_anald_binds $$ pprRules rules );
 
        ; return (reverse binds', rules') }
   where
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 3ce2afc6b8..227ad8542c 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -209,7 +209,7 @@ corePrepExpr dflags hsc_env expr =
     us <- mkSplitUniqSupply 's'
     initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
     let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
-    dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
+    dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)
     return new_expr
 
 corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index 6535d37307..65f0e9b8f8 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -65,6 +65,7 @@ import Util
 import Outputable
 import ForeignCall
 import Name
+import ErrUtils
 
 import qualified Data.ByteString as BS
 import Data.List
@@ -1280,10 +1281,10 @@ traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a
 traceInline dflags inline_id str doc result
  | Just prefix <- inlineCheck dflags
  =  if prefix `isPrefixOf` occNameString (getOccName inline_id)
-      then pprTrace str doc result
+      then traceAction dflags str doc result
       else result
  | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
- = pprTrace str doc result
+ = traceAction dflags str doc result
  | otherwise
  = result
 
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 8a823906af..6930af6e0b 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -111,7 +111,8 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
      hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
      modBreaks <- mkModBreaks hsc_env mod tickCount entries
 
-     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1)
+     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell
+       (pprLHsBinds binds1)
 
      return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
 
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index f5aa6f0785..48edd61b1b 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -270,7 +270,7 @@ deSugarExpr hsc_env tc_expr = do {
        ; case mb_core_expr of
             Nothing   -> return ()
             Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"
-                         (pprCoreExpr expr)
+                         FormatCore (pprCoreExpr expr)
 
        ; return (msgs, mb_core_expr) }
 
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index ece728a288..4a8e138daf 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -107,7 +107,8 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
 
         dumpIfSet_dyn dflags Opt_D_dump_BCOs
-           "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
+           "Proto-BCOs" FormatByteCode
+           (vcat (intersperse (char ' ') (map ppr proto_bcos)))
 
         cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)
           (case modBreaks of
@@ -175,7 +176,8 @@ coreExprToBCOs hsc_env this_mod expr
       when (notNull mallocd)
            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
 
-      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
+      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode
+         (ppr proto_bco)
 
       assembleOneBCO hsc_env proto_bco
   where dflags = hsc_dflags hsc_env
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index a9bf9a87e9..373369e733 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -91,6 +91,7 @@ pprintClosureCommand bindThings force str = do
          Just subst' -> do { dflags <- GHC.getSessionDynFlags
                            ; liftIO $
                                dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
+                                 FormatText
                                  (fsep $ [text "RTTI Improvement for", ppr id,
                                   text "old substitution:" , ppr subst,
                                   text "new substitution:" , ppr subst'])
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index cb9e183c1a..02948d67c8 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -167,7 +167,7 @@ mkFullIface hsc_env partial_iface = do
       addFingerprints hsc_env partial_iface
 
     -- Debug printing
-    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" (pprModIface full_iface)
+    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)
 
     return full_iface
 
@@ -311,7 +311,7 @@ mkIface_ hsc_env
           mi_doc_hdr     = doc_hdr,
           mi_decl_docs   = decl_docs,
           mi_arg_docs    = arg_docs,
-          mi_final_exts        = () }
+          mi_final_exts  = () }
   where
      cmp_rule     = comparing ifRuleName
      -- Compare these lexicographically by OccName, *not* by unique,
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index b463693a82..5b37f83ee6 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -189,7 +189,8 @@ cmmLlvmGen cmm@CmmProc{} = do
                     {-# SCC "llvm_fix_regs" #-}
                     fixStgRegisters dflags cmm
 
-    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
+    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm"
+      FormatCMM (pprCmmGroup [fixed_cmm])
 
     -- generate llvm code from cmm
     llvmBC <- withClearVars $ genLlvmProc fixed_cmm
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index eaa49fc50e..f43c3dcf75 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -337,10 +337,10 @@ getLlvmPlatform :: LlvmM Platform
 getLlvmPlatform = getDynFlag targetPlatform
 
 -- | Dumps the document if the corresponding flag has been set by the user
-dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
-dumpIfSetLlvm flag hdr doc = do
+dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
+dumpIfSetLlvm flag hdr fmt doc = do
   dflags <- getDynFlags
-  liftIO $ dumpIfSet_dyn dflags flag hdr doc
+  liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc
 
 -- | Prints the given contents to the output handle
 renderLlvm :: Outp.SDoc -> LlvmM ()
@@ -353,7 +353,7 @@ renderLlvm sdoc = do
                (Outp.mkCodeStyle Outp.CStyle) sdoc
 
     -- Dump, if requested
-    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
+    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc
     return ()
 
 -- | Marks a variable as "used"
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 6b70366f45..2b9770c78e 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -212,7 +212,9 @@ outputForeignStubs dflags mod location stubs
         createDirectoryIfMissing True (takeDirectory stub_h)
 
         dumpIfSet_dyn dflags Opt_D_dump_foreign
-                      "Foreign export header file" stub_h_output_d
+                      "Foreign export header file"
+                      FormatC
+                      stub_h_output_d
 
         -- we need the #includes from the rts package for the stub files
         let rts_includes =
@@ -230,7 +232,7 @@ outputForeignStubs dflags mod location stubs
                 ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr
 
         dumpIfSet_dyn dflags Opt_D_dump_foreign
-                      "Foreign export stubs" stub_c_output_d
+                      "Foreign export stubs" FormatC stub_c_output_d
 
         stub_c_file_exists
            <- outputForeignStubs_help stub_c stub_c_output_w
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d3cd6577ab..94cee4a7cd 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
 
 -------------------------------------------------------------------------------
 --
@@ -282,7 +283,8 @@ import ToolSettings
 import Foreign.C        ( CInt(..) )
 import System.IO.Unsafe ( unsafeDupablePerformIO )
 import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn
-                               , getCaretDiagnostic )
+                               , getCaretDiagnostic, DumpAction, TraceAction
+                               , defaultDumpAction, defaultTraceAction )
 import Json
 import SysTools.Terminal ( stderrSupportsAnsiColors )
 import SysTools.BaseDir ( expandToolDir, expandTopDir )
@@ -1211,6 +1213,8 @@ data DynFlags = DynFlags {
 
   -- | MsgDoc output action: use "ErrUtils" instead of this if you can
   log_action            :: LogAction,
+  dump_action           :: DumpAction,
+  trace_action          :: TraceAction,
   flushOut              :: FlushOut,
   flushErr              :: FlushErr,
 
@@ -2096,7 +2100,9 @@ defaultDynFlags mySettings llvmConfig =
 
         -- Logging
 
-        log_action = defaultLogAction,
+        log_action   = defaultLogAction,
+        dump_action  = defaultDumpAction,
+        trace_action = defaultTraceAction,
 
         flushOut = defaultFlushOut,
         flushErr = defaultFlushErr,
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index c66496bc61..b5dab7ea35 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
 
 module ErrUtils (
         -- * Basic types
@@ -41,8 +42,10 @@ module ErrUtils (
 
         -- * Dump files
         dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
-        mkDumpDoc, dumpSDoc, dumpSDocForUser,
-        dumpSDocWithStyle,
+        dumpOptionsFromFlag, DumpOptions (..),
+        DumpFormat (..), DumpAction, dumpAction, defaultDumpAction,
+        TraceAction, traceAction, defaultTraceAction,
+        touchDumpFile,
 
         -- * Issuing messages during compilation
         putMsg, printInfoForUser, printOutputForUser,
@@ -442,23 +445,23 @@ dumpIfSet dflags flag hdr doc
                             (defaultDumpStyle dflags)
                             (mkDumpDoc hdr doc)
 
--- | a wrapper around 'dumpSDoc'.
+-- | a wrapper around 'dumpAction'.
 -- First check whether the dump flag is set
 -- Do nothing if it is unset
-dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
-dumpIfSet_dyn dflags flag hdr doc
-  = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc
+dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
+dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify
 
--- | a wrapper around 'dumpSDoc'.
+-- | a wrapper around 'dumpAction'.
 -- First check whether the dump flag is set
 -- Do nothing if it is unset
 --
--- Unlike 'dumpIfSet_dyn',
--- has a printer argument but no header argument
-dumpIfSet_dyn_printer :: PrintUnqualified
-                      -> DynFlags -> DumpFlag -> SDoc -> IO ()
-dumpIfSet_dyn_printer printer dflags flag doc
-  = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc
+-- Unlike 'dumpIfSet_dyn', has a printer argument
+dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String
+                         -> DumpFormat -> SDoc -> IO ()
+dumpIfSet_dyn_printer printer dflags flag hdr fmt doc
+  = when (dopt flag dflags) $ do
+      let sty = mkDumpStyle dflags printer
+      dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc
 
 mkDumpDoc :: String -> SDoc -> SDoc
 mkDumpDoc hdr doc
@@ -469,11 +472,16 @@ mkDumpDoc hdr doc
      where
         line = text (replicate 20 '=')
 
+
+-- | Ensure that a dump file is created even if it stays empty
+touchDumpFile :: DynFlags -> DumpOptions -> IO ()
+touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ()))
+
 -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
 -- file, otherwise 'Nothing'.
-withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
-withDumpFileHandle dflags flag action = do
-    let mFile = chooseDumpFile dflags flag
+withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO ()
+withDumpFileHandle dflags dumpOpt action = do
+    let mFile = chooseDumpFile dflags dumpOpt
     case mFile of
       Just fileName -> do
         let gdref = generatedDumps dflags
@@ -494,31 +502,15 @@ withDumpFileHandle dflags flag action = do
       Nothing -> action Nothing
 
 
-dumpSDoc, dumpSDocForUser
-  :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
-
--- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style.
-dumpSDoc dflags print_unqual
-  = dumpSDocWithStyle dump_style dflags
-  where dump_style = mkDumpStyle dflags print_unqual
-
--- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style.
-dumpSDocForUser dflags print_unqual
-  = dumpSDocWithStyle user_style dflags
-  where user_style = mkUserStyle dflags print_unqual AllTheWay
-
 -- | Write out a dump.
 -- If --dump-to-file is set then this goes to a file.
 -- otherwise emit to stdout.
 --
 -- When @hdr@ is empty, we print in a more compact format (no separators and
 -- blank lines)
---
--- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
--- is used; it is not used to decide whether to dump the output
-dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
-dumpSDocWithStyle sty dflags flag hdr doc =
-    withDumpFileHandle dflags flag writeDump
+dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO ()
+dumpSDocWithStyle sty dflags dumpOpt hdr doc =
+    withDumpFileHandle dflags dumpOpt writeDump
   where
     -- write dump to file
     writeDump (Just handle) = do
@@ -544,12 +536,12 @@ dumpSDocWithStyle sty dflags flag hdr doc =
 
 -- | Choose where to put a dump file based on DynFlags
 --
-chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
-chooseDumpFile dflags flag
+chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath
+chooseDumpFile dflags dumpOpt
 
-        | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file
+        | gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt
         , Just prefix <- getPrefix
-        = Just $ setDir (prefix ++ (beautifyDumpName flag))
+        = Just $ setDir (prefix ++ dumpSuffix dumpOpt)
 
         | otherwise
         = Nothing
@@ -569,16 +561,39 @@ chooseDumpFile dflags flag
                          Just d  -> d </> f
                          Nothing ->       f
 
--- | Build a nice file name from name of a 'DumpFlag' constructor
-beautifyDumpName :: DumpFlag -> String
-beautifyDumpName Opt_D_th_dec_file = "th.hs"
-beautifyDumpName flag
- = let str = show flag
-       suff = case stripPrefix "Opt_D_" str of
-              Just x -> x
-              Nothing -> panic ("Bad flag name: " ++ str)
-       dash = map (\c -> if c == '_' then '-' else c) suff
-   in dash
+-- | Dump options
+--
+-- Dumps are printed on stdout by default except when the `dumpForcedToFile`
+-- field is set to True.
+--
+-- When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are
+-- written into a file whose suffix is given in the `dumpSuffix` field.
+--
+data DumpOptions = DumpOptions
+   { dumpForcedToFile :: Bool   -- ^ Must be dumped into a file, even if
+                                --   -ddump-to-file isn't set
+   , dumpSuffix       :: String -- ^ Filename suffix used when dumped into
+                                --   a file
+   }
+
+-- | Create dump options from a 'DumpFlag'
+dumpOptionsFromFlag :: DumpFlag -> DumpOptions
+dumpOptionsFromFlag Opt_D_th_dec_file =
+   DumpOptions                        -- -dth-dec-file dumps expansions of TH
+      { dumpForcedToFile = True       -- splices into MODULE.th.hs even when
+      , dumpSuffix       = "th.hs"    -- -ddump-to-file isn't set
+      }
+dumpOptionsFromFlag flag =
+   DumpOptions
+      { dumpForcedToFile = False
+      , dumpSuffix       = suffix -- build a suffix from the flag name
+      }                           -- e.g. -ddump-asm => ".dump-asm"
+   where
+      str  = show flag
+      suff = case stripPrefix "Opt_D_" str of
+             Just x  -> x
+             Nothing -> panic ("Bad flag name: " ++ str)
+      suffix = map (\c -> if c == '_' then '-' else c) suff
 
 
 -- -----------------------------------------------------------------------------
@@ -738,7 +753,7 @@ withTiming' dflags what force_result prtimings action
                            <+> text "megabytes")
 
                   whenPrintTimings $
-                      dumpIfSet_dyn dflags Opt_D_dump_timings ""
+                      dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText
                           $ text $ showSDocOneLine dflags
                           $ hsep [ what <> colon
                                  , text "alloc=" <> ppr alloc
@@ -919,3 +934,43 @@ of the execution through the various labels) and ghc.totals.txt (total time
 spent in each label).
 
 -}
+
+
+-- | Format of a dump
+--
+-- Dump formats are loosely defined: dumps may contain various additional
+-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint
+-- (e.g. for syntax highlighters).
+data DumpFormat
+   = FormatHaskell   -- ^ Haskell
+   | FormatCore      -- ^ Core
+   | FormatSTG       -- ^ STG
+   | FormatByteCode  -- ^ ByteCode
+   | FormatCMM       -- ^ Cmm
+   | FormatASM       -- ^ Assembly code
+   | FormatC         -- ^ C code/header
+   | FormatLLVM      -- ^ LLVM bytecode
+   | FormatText      -- ^ Unstructured dump
+   deriving (Show,Eq)
+
+type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String
+                  -> DumpFormat -> SDoc -> IO ()
+
+type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a
+
+-- | Default action for 'dumpAction' hook
+defaultDumpAction :: DumpAction
+defaultDumpAction dflags sty dumpOpt title _fmt doc = do
+   dumpSDocWithStyle sty dflags dumpOpt title doc
+
+-- | Default action for 'traceAction' hook
+defaultTraceAction :: TraceAction
+defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc
+
+-- | Helper for `dump_action`
+dumpAction :: DumpAction
+dumpAction dflags = dump_action dflags dflags
+
+-- | Helper for `trace_action`
+traceAction :: TraceAction
+traceAction dflags = trace_action dflags dflags
diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot
index 6f180af546..a2ba51b304 100644
--- a/compiler/main/ErrUtils.hs-boot
+++ b/compiler/main/ErrUtils.hs-boot
@@ -1,10 +1,33 @@
+{-# LANGUAGE RankNTypes #-}
+
 module ErrUtils where
 
 import GhcPrelude
-import Outputable (SDoc, PrintUnqualified )
+import Outputable (SDoc, PprStyle )
 import SrcLoc (SrcSpan)
 import Json
-import {-# SOURCE #-} DynFlags ( DynFlags, DumpFlag )
+import {-# SOURCE #-} DynFlags ( DynFlags )
+
+type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String
+                  -> DumpFormat -> SDoc -> IO ()
+
+type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a
+
+data DumpOptions = DumpOptions
+   { dumpForcedToFile :: Bool
+   , dumpSuffix       :: String
+   }
+
+data DumpFormat
+  = FormatHaskell
+  | FormatCore
+  | FormatSTG
+  | FormatByteCode
+  | FormatCMM
+  | FormatASM
+  | FormatC
+  | FormatLLVM
+  | FormatText
 
 data Severity
   = SevOutput
@@ -21,6 +44,7 @@ type MsgDoc = SDoc
 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
 mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
 getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
-dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
+defaultDumpAction :: DumpAction
+defaultTraceAction :: TraceAction
 
 instance ToJson Severity
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 9daecdb550..81f3caa033 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -356,12 +356,12 @@ hscParse' mod_summary
         POk pst rdr_module -> do
             let (warns, errs) = getMessages pst dflags
             logWarnings warns
-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
-                                   ppr rdr_module
-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
-                                   showAstData NoBlankSrcSpan rdr_module
-            liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
-                                   ppSourceStats False rdr_module
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
+                        FormatHaskell (ppr rdr_module)
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"
+                        FormatHaskell (showAstData NoBlankSrcSpan rdr_module)
+            liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
+                        FormatText (ppSourceStats False rdr_module)
             when (not $ isEmptyBag errs) $ throwErrors errs
 
             -- To get the list of extra source files, we take the list
@@ -412,8 +412,8 @@ extract_renamed_stuff mod_summary tc_result = do
     let rn_info = getRenamedStuff tc_result
 
     dflags <- getDynFlags
-    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $
-                           showAstData NoBlankSrcSpan rn_info
+    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer"
+                FormatHaskell (showAstData NoBlankSrcSpan rn_info)
 
     -- Create HIE files
     when (gopt Opt_WriteHie dflags) $ do
@@ -1457,7 +1457,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
                       cmmToRawCmm dflags cmms
 
             let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
-                              (ppr a)
+                              FormatCMM (ppr a)
                             return a
                 rawcmms1 = Stream.mapM dump rawcmms0
 
@@ -1506,13 +1506,14 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
     let dflags = hsc_dflags hsc_env
     cmm <- ioMsgMaybe $ parseCmmFile dflags filename
     liftIO $ do
-        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" (ppr cmm)
+        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm)
         let -- Make up a module name to give the NCG. We can't pass bottom here
             -- lest we reproduce #11784.
             mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
             cmm_mod = mkModule (thisPackage dflags) mod_name
         (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm
-        dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" (ppr cmmgroup)
+        dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm"
+          FormatCMM (ppr cmmgroup)
         rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
         _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
              rawCmms
@@ -1550,7 +1551,7 @@ doCodeGen hsc_env this_mod data_tycons
         -- to proc-point splitting).
 
     let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg
-                       "Cmm produced by codegen" (ppr a)
+                       "Cmm produced by codegen" FormatCMM (ppr a)
                      return a
 
         ppr_stream1 = Stream.mapM dump1 cmm_stream
@@ -1561,7 +1562,7 @@ doCodeGen hsc_env this_mod data_tycons
              in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1
 
         dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
-                        "Output Cmm" (ppr a)
+                        "Output Cmm" FormatCMM (ppr a)
                      return a
 
         ppr_stream2 = Stream.mapM dump2 pipeline_stream
@@ -1853,9 +1854,10 @@ hscParseThingWithLocation source linenumber parser str
 
         POk pst thing -> do
             logWarningsReportErrors (getMessages pst dflags)
-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
-                                   showAstData NoBlankSrcSpan thing
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
+                        FormatHaskell (ppr thing)
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"
+                        FormatHaskell (showAstData NoBlankSrcSpan thing)
             return thing
 
 
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 04e50ebca8..ac48c3f24f 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -639,6 +639,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
                Just subst -> do
                  let dflags = hsc_dflags hsc_env
                  dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
+                   FormatText
                    (fsep [text "RTTI Improvement for", ppr id, equals,
                           ppr subst])
 
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index b3ee7f5e6c..9feffe7cb5 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -85,7 +85,7 @@ import CmdLineParser
 import System.Environment ( getEnv )
 import FastString
 import ErrUtils         ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, compilationProgressMsg,
-                          withTiming )
+                          withTiming, DumpFormat (..) )
 import Exception
 
 import System.Directory
@@ -1616,6 +1616,7 @@ mkPackageState dflags dbs preload0 = do
       mod_map = Map.union mod_map1 mod_map2
 
   dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map"
+    FormatText
     (pprModuleMap mod_map)
 
   -- Force pstate to avoid leaking the dflags0 passed to mkPackageState
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index 2ad9dc7bd4..47e89560b2 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -417,11 +417,13 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
         ; unless (dopt Opt_D_dump_simpl dflags) $
             Err.dumpIfSet_dyn dflags Opt_D_dump_rules
               (showSDoc dflags (ppr CoreTidy <+> text "rules"))
+              Err.FormatText
               (pprRulesForUser dflags tidy_rules)
 
           -- Print one-line size info
         ; let cs = coreBindsStats tidy_binds
         ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"
+            Err.FormatText
             (text "Tidy size (terms,types,coercions)"
              <+> ppr (moduleName mod) <> colon
              <+> int (cs_tm cs)
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 7d830d0337..556c943dc2 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -359,6 +359,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
           let platform = targetPlatform dflags
           dumpIfSet_dyn dflags
                   Opt_D_dump_asm_conflicts "Register conflict graph"
+                  FormatText
                   $ Color.dotGraph
                           (targetRegDotColor platform)
                           (Color.trivColorable platform
@@ -377,7 +378,9 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
                 $ makeImportsDoc dflags (concat (ngs_imports ngs))
         return us'
   where
-    dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
+    dump_stats = dumpAction dflags (mkDumpStyle dflags alwaysQualify)
+                   (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats"
+                   FormatText
 
 cmmNativeGenStream :: (Outputable statics, Outputable instr
                       ,Outputable jumpDest, Instruction instr)
@@ -420,7 +423,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
               -- See Note [What is this unwinding business?] in Debug.
               let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
               unless (null ldbgs) $
-                dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
+                dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText
                   (vcat $ map ppr ldbgs)
 
               -- Accumulate debug information for emission in finishNativeGen.
@@ -505,7 +508,7 @@ emitNativeCode dflags h sdoc = do
 
         -- dump native code
         dumpIfSet_dyn dflags
-                Opt_D_dump_asm "Asm code"
+                Opt_D_dump_asm "Asm code" FormatASM
                 sdoc
 
 -- | Complete native code generation phase for a single top-level chunk of Cmm.
@@ -550,7 +553,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
                 cmmToCmm dflags this_mod fixed_cmm
 
         dumpIfSet_dyn dflags
-                Opt_D_dump_opt_cmm "Optimised Cmm"
+                Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM
                 (pprCmmGroup [opt_cmm])
 
         let cmmCfg = {-# SCC "getCFG" #-}
@@ -564,7 +567,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
                                         fileIds dbgMap opt_cmm cmmCfg
 
         dumpIfSet_dyn dflags
-                Opt_D_dump_asm_native "Native code"
+                Opt_D_dump_asm_native "Native code" FormatASM
                 (vcat $ map (pprNatCmmDecl ncgImpl) native)
 
         maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name
@@ -582,6 +585,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_liveness "Liveness annotations added"
+                FormatCMM
                 (vcat $ map ppr withLiveness)
 
         -- allocate registers
@@ -621,10 +625,12 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
                 -- dump out what happened during register allocation
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
+                        FormatCMM
                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"
+                        FormatText
                         (vcat   $ map (\(stage, stats)
                                         -> text "# --------------------------"
                                         $$ text "#  cmm " <> int count <> text " Stage " <> int stage
@@ -663,6 +669,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
+                        FormatCMM
                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
 
                 let mPprStats =
@@ -697,6 +704,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
 
         when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags
                 Opt_D_dump_cfg_weights "CFG Update information"
+                FormatText
                 ( text "stack:" <+> ppr stack_updt_blks $$
                   text "linearAlloc:" <+> ppr cfgRegAllocUpdates )
 
@@ -753,6 +761,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+                FormatCMM
                 (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
 
         -- generate unwinding information from cmm
@@ -779,6 +788,7 @@ maybeDumpCfg dflags (Just cfg) msg proc_name
         | otherwise
         = dumpIfSet_dyn
                 dflags Opt_D_dump_cfg_weights msg
+                FormatText
                 (proc_name <> char ':' $$ pprEdgeWeights cfg)
 
 -- | Make sure all blocks we want the layout algorithm to place have been placed.
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index 6319a8ce10..4094402697 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -40,7 +40,7 @@ import THNames          ( liftName )
 
 import DynFlags
 import FastString
-import ErrUtils         ( dumpIfSet_dyn_printer )
+import ErrUtils         ( dumpIfSet_dyn_printer, DumpFormat (..) )
 import TcEnv            ( tcMetaTy )
 import Hooks
 import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
@@ -746,7 +746,7 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
        ; when is_decl $  -- Raw material for -dth-dec-file
          do { dflags <- getDynFlags
             ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file
-                                             (spliceCodeDoc loc) } }
+                                             "" FormatHaskell (spliceCodeDoc loc) } }
   where
     -- `-ddump-splices`
     spliceDebugDoc :: SrcSpan -> SDoc
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index 620f24c680..04898921de 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -61,14 +61,14 @@ import qualified IOEnv  ( liftIO )
 import Var
 import Outputable
 import FastString
-import qualified ErrUtils as Err
-import ErrUtils( Severity(..) )
+import ErrUtils( Severity(..), DumpFormat (..), dumpOptionsFromFlag )
 import UniqSupply
 import MonadUtils
 import NameCache
 import NameEnv
 import SrcLoc
 import Data.Bifunctor ( bimap )
+import ErrUtils (dumpAction)
 import Data.List
 import Data.Ord
 import Data.Dynamic
@@ -825,9 +825,10 @@ debugTraceMsg :: SDoc -> CoreM ()
 debugTraceMsg = msg SevDump NoReason
 
 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
-dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
-dumpIfSet_dyn flag str doc
+dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM ()
+dumpIfSet_dyn flag str fmt doc
   = do { dflags <- getDynFlags
        ; unqual <- getPrintUnqualified
-       ; when (dopt flag dflags) $ liftIO $
-         Err.dumpSDoc dflags unqual flag str doc }
+       ; when (dopt flag dflags) $ liftIO $ do
+         let sty = mkDumpStyle dflags unqual
+         dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc }
diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs
index 015d096a0a..c0110fa1d9 100644
--- a/compiler/simplCore/FloatOut.hs
+++ b/compiler/simplCore/FloatOut.hs
@@ -19,7 +19,7 @@ import CoreArity        ( etaExpand )
 import CoreMonad        ( FloatOutSwitches(..) )
 
 import DynFlags
-import ErrUtils         ( dumpIfSet_dyn )
+import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )
 import Id               ( Id, idArity, idType, isBottomingId,
                           isJoinId, isJoinId_maybe )
 import SetLevels
@@ -174,11 +174,13 @@ floatOutwards float_sws dflags us pgm
             } ;
 
         dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
+                  FormatCore
                   (vcat (map ppr annotated_w_levels));
 
         let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
 
         dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
+                FormatText
                 (hcat [ int tlets,  text " Lets floated to top level; ",
                         int ntlets, text " Lets floated elsewhere; from ",
                         int lams,   text " Lambda groups"]);
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 149a079a0a..19465082dc 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -36,7 +36,7 @@ import FloatIn          ( floatInwards )
 import FloatOut         ( floatOutwards )
 import FamInstEnv
 import Id
-import ErrUtils         ( withTiming, withTimingD )
+import ErrUtils         ( withTiming, withTimingD, DumpFormat (..) )
 import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )
 import VarSet
 import VarEnv
@@ -90,6 +90,7 @@ core2core hsc_env guts@(ModGuts { mg_module  = mod
 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
              "Grand total simplifier statistics"
+             FormatText
              (pprSimplCount stats)
 
        ; return guts2 }
@@ -576,6 +577,7 @@ simplifyExpr dflags expr
                   "Simplifier statistics" (pprSimplCount counts)
 
         ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+                        FormatCore
                         (pprCoreExpr expr')
 
         ; return expr'
@@ -688,6 +690,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
                                      binds
                } ;
            Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+                     FormatCore
                      (pprCoreBindings tagged_binds);
 
                 -- Get any new rules, and extend the rule base
diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs
index 32c277cc55..271f75e49b 100644
--- a/compiler/simplCore/SimplMonad.hs
+++ b/compiler/simplCore/SimplMonad.hs
@@ -141,6 +141,7 @@ traceSmpl :: String -> SDoc -> SimplM ()
 traceSmpl herald doc
   = do { dflags <- getDynFlags
        ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"
+           FormatText
            (hang (text herald) 2 doc) }
 
 {-
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 01e417ffaa..f5d8f1aeb0 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -260,7 +260,8 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs
       | not (dopt Opt_D_verbose_core2core dflags)
       = thing_inside
       | otherwise
-      = pprTrace ("SimplBind " ++ what) (ppr old_bndr) thing_inside
+      = traceAction dflags ("SimplBind " ++ what)
+         (ppr old_bndr) thing_inside
 
 --------------------------
 simplLazyBind :: SimplEnv
@@ -1793,14 +1794,20 @@ completeCall env var cont
     interesting_cont = interestingCallContext env call_cont
     active_unf       = activeUnfolding (getMode env) var
 
+    log_inlining doc
+      = liftIO $ dumpAction dflags
+           (mkUserStyle dflags alwaysQualify AllTheWay)
+           (dumpOptionsFromFlag Opt_D_dump_inlinings)
+           "" FormatText doc
+
     dump_inline unfolding cont
       | not (dopt Opt_D_dump_inlinings dflags) = return ()
       | not (dopt Opt_D_verbose_core2core dflags)
       = when (isExternalName (idName var)) $
-            liftIO $ printOutputForUser dflags alwaysQualify $
+            log_inlining $
                 sep [text "Inlining done:", nest 4 (ppr var)]
       | otherwise
-      = liftIO $ printOutputForUser dflags alwaysQualify $
+      = liftIO $ log_inlining $
            sep [text "Inlining done: " <> ppr var,
                 nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
                               text "Cont:  " <+> ppr cont])]
@@ -2065,17 +2072,21 @@ tryRules env rules fn args call_cont
 
     nodump
       | dopt Opt_D_dump_rule_rewrites dflags
-      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty
+      = liftIO $ do
+         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites)
 
       | dopt Opt_D_dump_rule_firings dflags
-      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty
+      = liftIO $ do
+         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings)
 
       | otherwise
       = return ()
 
     log_rule dflags flag hdr details
-      = liftIO . dumpSDoc dflags alwaysQualify flag "" $
-                   sep [text hdr, nest 4 details]
+      = liftIO $ do
+         let sty = mkDumpStyle dflags alwaysQualify
+         dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $
+           sep [text hdr, nest 4 details]
 
 trySeqRules :: SimplEnv
             -> OutExpr -> InExpr   -- Scrutinee and RHS
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
index 89b7d4205e..2b6eeded42 100644
--- a/compiler/simplStg/SimplStg.hs
+++ b/compiler/simplStg/SimplStg.hs
@@ -96,12 +96,12 @@ stg2stg dflags this_mod binds
             return binds'
 
     dump_when flag header binds
-      = dumpIfSet_dyn dflags flag header (pprStgTopBindings binds)
+      = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings binds)
 
     end_pass what binds2
       = liftIO $ do -- report verbosely, if required
           dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
-            (vcat (map ppr binds2))
+            FormatSTG (vcat (map ppr binds2))
           stg_linter False what binds2
           return binds2
 
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index afde951e60..b1601f2fed 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -35,7 +35,7 @@ import Util
 import Maybes           ( isJust )
 import TysWiredIn
 import TysPrim          ( realWorldStatePrimTy )
-import ErrUtils         ( dumpIfSet_dyn )
+import ErrUtils         ( dumpIfSet_dyn, DumpFormat (..) )
 import Name             ( getName, stableNameCmp )
 import Data.Function    ( on )
 import UniqSet
@@ -53,8 +53,8 @@ dmdAnalProgram dflags fam_envs binds
   = do {
         let { binds_plus_dmds = do_prog binds } ;
         dumpIfSet_dyn dflags Opt_D_dump_str_signatures
-                      "Strictness signatures" $
-            dumpStrSig binds_plus_dmds ;
+            "Strictness signatures" FormatSTG
+            (dumpStrSig binds_plus_dmds) ;
         -- See Note [Stamp out space leaks in demand analysis]
         seqBinds binds_plus_dmds `seq` return binds_plus_dmds
     }
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index d43afe32bc..9761120016 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -235,6 +235,7 @@ tcDeriving deriv_infos deriv_decls
 
         ; unless (isEmptyBag inst_info) $
              liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+                        FormatHaskell
                         (ddump_deriving inst_info rn_binds famInsts))
 
         ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index ff71a6f430..822c557153 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -1918,6 +1918,7 @@ mkDefMethBind clas inst_tys sel_id dm_name
                              [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
 
         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
+                   FormatHaskell
                    (vcat [ppr clas <+> ppr inst_tys,
                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index d2235e5bd8..19b074954d 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -2711,9 +2711,9 @@ loadUnqualIfaces hsc_env ictxt
 ************************************************************************
 -}
 
+-- | Dump, with a banner, if -ddump-rn
 rnDump :: (Outputable a, Data a) => a -> TcRn ()
--- Dump, with a banner, if -ddump-rn
-rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) }
+rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn)
 
 tcDump :: TcGblEnv -> TcRn ()
 tcDump env
@@ -2721,13 +2721,14 @@ tcDump env
 
         -- Dump short output if -ddump-types or -ddump-tc
         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
-          (traceTcRnForUser Opt_D_dump_types short_dump) ;
+          (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types)
+            "" FormatText short_dump) ;
 
         -- Dump bindings if -ddump-tc
-        traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump);
+        dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump;
 
         -- Dump bindings as an hsSyn AST if -ddump-tc-ast
-        traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump)
+        dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump
    }
   where
     short_dump = pprTcGblEnv env
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index c2a1cc2721..abc9c02eec 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -42,8 +42,8 @@ module TcRnMonad(
   newTcRef, readTcRef, writeTcRef, updTcRef,
 
   -- * Debugging
-  traceTc, traceRn, traceOptTcRn, traceTcRn, traceTcRnForUser,
-  traceTcRnWithStyle,
+  traceTc, traceRn, traceOptTcRn, dumpOptTcRn,
+  dumpTcRn,
   getPrintUnqualified,
   printForUserTcRn,
   traceIf, traceHiDiffs, traceOptIf,
@@ -684,58 +684,48 @@ labelledTraceOptTcRn flag herald doc = do
 formatTraceMsg :: String -> SDoc -> SDoc
 formatTraceMsg herald doc = hang (text herald) 2 doc
 
--- | Output a doc if the given 'DumpFlag' is set.
---
--- By default this logs to stdout
--- However, if the `-ddump-to-file` flag is set,
--- then this will dump output to a file
---
--- Just a wrapper for 'dumpSDoc'
+-- | Trace if the given 'DumpFlag' is set.
 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
-traceOptTcRn flag doc
-  = do { dflags <- getDynFlags
-       ; when (dopt flag dflags)
-              (traceTcRn flag doc)
-       }
-
+traceOptTcRn flag doc = do
+  dflags <- getDynFlags
+  when (dopt flag dflags) $
+    dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc
+
+-- | Dump if the given 'DumpFlag' is set.
+dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
+dumpOptTcRn flag title fmt doc = do
+  dflags <- getDynFlags
+  when (dopt flag dflags) $
+    dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc
+
+-- | Unconditionally dump some trace output
+--
 -- Certain tests (T3017, Roles3, T12763 etc.) expect part of the
 -- output generated by `-ddump-types` to be in 'PprUser' style. However,
 -- generally we want all other debugging output to use 'PprDump'
--- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this.
-
--- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style.
-traceTcRn :: DumpFlag -> SDoc -> TcRn ()
-traceTcRn flag doc
-  = do { dflags  <- getDynFlags
-       ; printer <- getPrintUnqualified dflags
-       ; let dump_style = mkDumpStyle dflags printer
-       ; traceTcRnWithStyle dump_style dflags flag doc }
-
--- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style.
-traceTcRnForUser :: DumpFlag -> SDoc -> TcRn ()
--- Used by 'TcRnDriver.tcDump'.
-traceTcRnForUser flag doc
-  = do { dflags  <- getDynFlags
-       ; printer <- getPrintUnqualified dflags
-       ; let user_style = mkUserStyle dflags printer AllTheWay
-       ; traceTcRnWithStyle user_style dflags flag doc }
-
-traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn ()
--- ^ Unconditionally dump some trace output
+-- style. We 'PprUser' style if 'useUserStyle' is True.
 --
--- The DumpFlag is used only to set the output filename
--- for --dump-to-file, not to decide whether or not to output
--- That part is done by the caller
-traceTcRnWithStyle sty dflags flag doc
-  = do { real_doc <- prettyDoc dflags doc
-       ; liftIO $ dumpSDocWithStyle sty dflags flag "" real_doc }
-  where
-    -- Add current location if -dppr-debug
-    prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
-    prettyDoc dflags doc = if hasPprDebug dflags
-       then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
-       else return doc -- The full location is usually way too much
-
+dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn ()
+dumpTcRn useUserStyle dumpOpt title fmt doc = do
+  dflags <- getDynFlags
+  printer <- getPrintUnqualified dflags
+  real_doc <- wrapDocLoc doc
+  let sty = if useUserStyle
+              then mkUserStyle dflags printer AllTheWay
+              else mkDumpStyle dflags printer
+  liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc
+
+-- | Add current location if -dppr-debug
+-- (otherwise the full location is usually way too much)
+wrapDocLoc :: SDoc -> TcRn SDoc
+wrapDocLoc doc = do
+  dflags <- getDynFlags
+  if hasPprDebug dflags
+    then do
+      loc <- getSrcSpanM
+      return (mkLocMessage SevOutput loc doc)
+    else
+      return doc
 
 getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
 getPrintUnqualified dflags
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index eb940aa1ee..eb4f5027fb 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -146,6 +146,7 @@ import Type
 import Coercion
 import Unify
 
+import ErrUtils
 import TcEvidence
 import Class
 import TyCon
@@ -2733,7 +2734,10 @@ csTraceTcM mk_doc
        ; when (  dopt Opt_D_dump_cs_trace dflags
                   || dopt Opt_D_dump_tc_trace dflags )
               ( do { msg <- mk_doc
-                   ; TcM.traceTcRn Opt_D_dump_cs_trace msg }) }
+                   ; TcM.dumpTcRn False
+                       (dumpOptionsFromFlag Opt_D_dump_cs_trace)
+                       "" FormatText
+                       msg }) }
 
 runTcS :: TcS a                -- What to run
        -> TcM (a, EvBindMap)
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 0dda99020f..b200bd79db 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -82,7 +82,7 @@ module Outputable (
         -- * Error handling and debugging utilities
         pprPanic, pprSorry, assertPprPanic, pprPgmError,
         pprTrace, pprTraceDebug, pprTraceWith, pprTraceIt, warnPprTrace,
-        pprSTrace, pprTraceException, pprTraceM,
+        pprSTrace, pprTraceException, pprTraceM, pprTraceWithFlags,
         trace, pgmError, panic, sorry, assertPanic,
         pprDebugAndThen, callStackDoc,
     ) where
@@ -1186,12 +1186,15 @@ pprTraceDebug str doc x
    | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x
    | otherwise                                     = x
 
+-- | If debug output is on, show some 'SDoc' on the screen
 pprTrace :: String -> SDoc -> a -> a
--- ^ If debug output is on, show some 'SDoc' on the screen
-pprTrace str doc x
-   | hasNoDebugOutput unsafeGlobalDynFlags = x
-   | otherwise                             =
-      pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x
+pprTrace str doc x = pprTraceWithFlags unsafeGlobalDynFlags str doc x
+
+-- | If debug output is on, show some 'SDoc' on the screen
+pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a
+pprTraceWithFlags dflags str doc x
+  | hasNoDebugOutput dflags = x
+  | otherwise               = pprDebugAndThen dflags trace (text str) doc x
 
 pprTraceM :: Applicative f => String -> SDoc -> f ()
 pprTraceM str doc = pprTrace str doc (pure ())
diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
index 6aa8aa4578..5282c9f62a 100644
--- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
@@ -1,5 +1,5 @@
 
-==================== Typechecker ====================
+==================== Typechecker AST ====================
 
 {Bag(Located (HsBind Var)):
  [({ <no location info> }