Some refactoring around endPass and debug dumping

I forget all the details, but I spent some time trying to
understand the current setup, and tried to simplify it a bit

13 files changed, 157 insertions, 117 deletions

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 7ef5d42d72..374b98ece9 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -21,7 +21,7 @@ import PrelNames
 import CoreUtils
 import CoreArity
 import CoreFVs
-import CoreMonad        ( endPass, CoreToDo(..) )
+import CoreMonad        ( endPassIO, CoreToDo(..) )
 import CoreSyn
 import CoreSubst
 import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here
@@ -172,7 +172,7 @@ corePrepPgm dflags hsc_env binds data_tycons = do
                       floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
-    endPass hsc_env CorePrep binds_out []
+    endPassIO hsc_env alwaysQualify CorePrep binds_out []
     return binds_out
 
 corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index c979f9908f..e2170e7dd4 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -39,7 +39,7 @@ import Rules
 import TysPrim (eqReprPrimTyCon)
 import TysWiredIn (coercibleTyCon )
 import BasicTypes       ( Activation(.. ) )
-import CoreMonad        ( endPass, CoreToDo(..) )
+import CoreMonad        ( endPassIO, CoreToDo(..) )
 import MkCore
 import FastString
 import ErrUtils
@@ -94,6 +94,7 @@ deSugar hsc_env
                             tcg_hpc          = other_hpc_info })
 
   = do { let dflags = hsc_dflags hsc_env
+             print_unqual = mkPrintUnqualified dflags rdr_env
         ; showPass dflags "Desugar"
 
         -- Desugar the program
@@ -147,14 +148,14 @@ deSugar hsc_env
 
 #ifdef DEBUG
           -- Debug only as pre-simple-optimisation program may be really big
-        ; endPass hsc_env CoreDesugar final_pgm rules_for_imps
+        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
 #endif
         ; (ds_binds, ds_rules_for_imps, ds_vects)
             <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
                          -- The simpleOptPgm gets rid of type
                          -- bindings plus any stupid dead code
 
-        ; endPass hsc_env CoreDesugarOpt ds_binds ds_rules_for_imps
+        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
 
         ; let used_names = mkUsedNames tcg_env
         ; deps <- mkDependencies tcg_env
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index bd1532904e..26aad6f975 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -29,6 +29,7 @@ import Kind
 import GHC
 import Outputable
 import PprTyThing
+import ErrUtils
 import MonadUtils
 import DynFlags
 import Exception
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 166ceba4a2..2831eecf72 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -52,8 +52,6 @@ module DynFlags (
         tablesNextToCode, mkTablesNextToCode,
         SigOf(..), getSigOf,
 
-        printOutputForUser, printInfoForUser,
-
         Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
         wayGeneralFlags, wayUnsetGeneralFlags,
 
@@ -1557,16 +1555,6 @@ newtype FlushErr = FlushErr (IO ())
 defaultFlushErr :: FlushErr
 defaultFlushErr = FlushErr $ hFlush stderr
 
-printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
-printOutputForUser = printSevForUser SevOutput
-
-printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
-printInfoForUser = printSevForUser SevInfo
-
-printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
-printSevForUser sev dflags unqual doc
-    = log_action dflags dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc
-
 {-
 Note [Verbosity levels]
 ~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index c43064e7f1..8a4763913f 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -27,7 +27,8 @@ module ErrUtils (
         mkDumpDoc, dumpSDoc,
 
         --  * Messages during compilation
-        putMsg, putMsgWith,
+        putMsg, printInfoForUser, printOutputForUser,
+        logInfo, logOutput,
         errorMsg,
         fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
         compilationProgressMsg,
@@ -237,7 +238,7 @@ dumpIfSet dflags flag hdr doc
 dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
   | dopt flag dflags
-  = dumpSDoc dflags flag hdr doc
+  = dumpSDoc dflags alwaysQualify flag hdr doc
   | otherwise
   = return ()
 
@@ -254,12 +255,13 @@ mkDumpDoc hdr doc
 -- | 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)
-dumpSDoc :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
-dumpSDoc dflags flag hdr doc
+dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
+dumpSDoc dflags print_unqual flag hdr doc
  = do let mFile = chooseDumpFile dflags flag
+          dump_style = mkDumpStyle print_unqual
       case mFile of
             Just fileName
                  -> do
@@ -278,7 +280,7 @@ dumpSDoc dflags flag hdr doc
                                              $$ blankLine
                                              $$ doc
                                         return $ mkDumpDoc hdr d
-                        defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle
+                        defaultLogActionHPrintDoc dflags handle doc' dump_style
                         hClose handle
 
             -- write the dump to stdout
@@ -286,7 +288,7 @@ dumpSDoc dflags flag hdr doc
               let (doc', severity)
                     | null hdr  = (doc, SevOutput)
                     | otherwise = (mkDumpDoc hdr doc, SevDump)
-              log_action dflags dflags severity noSrcSpan defaultDumpStyle doc'
+              log_action dflags dflags severity noSrcSpan dump_style doc'
 
 
 -- | Choose where to put a dump file based on DynFlags
@@ -340,18 +342,9 @@ ifVerbose dflags val act
   | verbosity dflags >= val = act
   | otherwise               = return ()
 
-putMsg :: DynFlags -> MsgDoc -> IO ()
-putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
-
-putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
-putMsgWith dflags print_unqual msg
-  = log_action dflags dflags SevInfo noSrcSpan sty msg
-  where
-    sty = mkUserStyle print_unqual AllTheWay
-
 errorMsg :: DynFlags -> MsgDoc -> IO ()
-errorMsg dflags msg =
-    log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
+errorMsg dflags msg
+   = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
 
 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
@@ -365,25 +358,45 @@ fatalErrorMsg'' fm msg = fm msg
 
 compilationProgressMsg :: DynFlags -> String -> IO ()
 compilationProgressMsg dflags msg
-  = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg))
+  = ifVerbose dflags 1 $
+    logOutput dflags defaultUserStyle (text msg)
 
 showPass :: DynFlags -> String -> IO ()
 showPass dflags what
-  = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
+  = ifVerbose dflags 2 $
+    logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
 
 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
-debugTraceMsg dflags val msg
-  = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg)
+debugTraceMsg dflags val msg = ifVerbose dflags val $
+                               logInfo dflags defaultDumpStyle msg
+
+putMsg :: DynFlags -> MsgDoc -> IO ()
+putMsg dflags msg = logInfo dflags defaultUserStyle msg
+
+printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
+printInfoForUser dflags print_unqual msg
+  = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
+
+printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
+printOutputForUser dflags print_unqual msg
+  = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
+
+logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
+logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg
+
+logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
+-- Like logInfo but with SevOutput rather then SevInfo
+logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg
 
 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
 prettyPrintGhcErrors dflags
     = ghandle $ \e -> case e of
                       PprPanic str doc ->
-                          pprDebugAndThen dflags panic str doc
+                          pprDebugAndThen dflags panic (text str) doc
                       PprSorry str doc ->
-                          pprDebugAndThen dflags sorry str doc
+                          pprDebugAndThen dflags sorry (text str) doc
                       PprProgramError str doc ->
-                          pprDebugAndThen dflags pgmError str doc
+                          pprDebugAndThen dflags pgmError (text str) doc
                       _ ->
                           liftIO $ throwIO e
 \end{code}
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 02db8efec0..a975fdd5ac 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -141,7 +141,7 @@ mkBootModDetailsTc hsc_env
                   tcg_fam_insts = fam_insts
                 }
   = do  { let dflags = hsc_dflags hsc_env
-        ; showPass dflags CoreTidy
+        ; showPassIO dflags CoreTidy
 
         ; let { insts'      = map (tidyClsInstDFun globaliseAndTidyId) insts
               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
@@ -302,6 +302,7 @@ RHSs, so that they print nicely in interfaces.
 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
 tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_exports   = exports
+                              , mg_rdr_env   = rdr_env
                               , mg_tcs       = tcs
                               , mg_insts     = insts
                               , mg_fam_insts = fam_insts
@@ -319,8 +320,9 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
   = do  { let { dflags     = hsc_dflags hsc_env
               ; omit_prags = gopt Opt_OmitInterfacePragmas dflags
               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
+              ; print_unqual = mkPrintUnqualified dflags rdr_env
               }
-        ; showPass dflags CoreTidy
+        ; showPassIO dflags CoreTidy
 
         ; let { type_env = typeEnvFromEntities [] tcs fam_insts
 
@@ -378,7 +380,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
               }
 
-        ; endPass hsc_env CoreTidy all_tidy_binds tidy_rules
+        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
 
           -- If the endPass didn't print the rules, but ddump-rules is
           -- on, print now
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 5b4a517cbb..56c18ea152 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -316,8 +316,7 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof)
                         $ [ Color.raGraph stat
                                 | stat@Color.RegAllocStatsStart{} <- stats]
 
-                dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
-                        $ Color.pprStats stats graphGlobal
+                dump_stats (Color.pprStats stats graphGlobal)
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_conflicts "Register conflict graph"
@@ -332,13 +331,14 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof)
         -- dump global NCG stats for linear allocator
         (case concat $ catMaybes linearStats of
                 []      -> return ()
-                stats   -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
-                                $ Linear.pprStats (concat native) stats)
+                stats   -> dump_stats (Linear.pprStats (concat native) stats))
 
         -- write out the imports
         Pretty.printDoc Pretty.LeftMode (pprCols dflags) h
                 $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
                 $ makeImportsDoc dflags (concat imports)
+  where
+    dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
 
 cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
               => DynFlags
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 8d2d3bf9a2..3405f52ed3 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -28,6 +28,7 @@ module CoreMonad (
     -- ** Reading from the monad
     getHscEnv, getRuleBase, getModule,
     getDynFlags, getOrigNameCache, getPackageFamInstEnv,
+    getPrintUnqualified,
 
     -- ** Writing to the monad
     addSimplCount,
@@ -43,7 +44,7 @@ module CoreMonad (
     getAnnotations, getFirstAnnotations,
 
     -- ** Debug output
-    showPass, endPass, dumpPassResult, lintPassResult,
+    showPass, showPassIO, endPass, endPassIO, dumpPassResult, lintPassResult,
     lintInteractiveExpr, dumpIfSet,
 
     -- ** Screen output
@@ -132,15 +133,28 @@ be, and it makes a conveneint place.  place for them.  They print out
 stuff before and after core passes, and do Core Lint when necessary.
 
 \begin{code}
-showPass :: DynFlags -> CoreToDo -> IO ()
-showPass dflags pass = Err.showPass dflags (showPpr dflags pass)
-
-endPass :: HscEnv -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
-endPass hsc_env pass binds rules
-  = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules
+showPass :: CoreToDo -> CoreM ()
+showPass pass = do { dflags <- getDynFlags
+                   ; liftIO $ showPassIO dflags pass }
+
+showPassIO :: DynFlags -> CoreToDo -> IO ()
+showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass)
+
+endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
+endPass pass binds rules
+  = do { hsc_env <- getHscEnv
+       ; print_unqual <- getPrintUnqualified
+       ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
+
+endPassIO :: HscEnv -> PrintUnqualified
+          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
+-- Used by the IO-is CorePrep too
+endPassIO hsc_env print_unqual pass binds rules
+  = do { dumpPassResult dflags print_unqual mb_flag
+                        (ppr pass) (pprPassDetails pass) binds rules
        ; lintPassResult hsc_env pass binds }
   where
-    dflags = hsc_dflags hsc_env
+    dflags  = hsc_dflags hsc_env
     mb_flag = case coreDumpFlag pass of
                 Just flag | dopt flag dflags                    -> Just flag
                           | dopt Opt_D_verbose_core2core dflags -> Just flag
@@ -151,15 +165,16 @@ dumpIfSet dflags dump_me pass extra_info doc
   = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
 
 dumpPassResult :: DynFlags
-               -> Maybe DumpFlag                -- Just df => show details in a file whose
+               -> PrintUnqualified
+               -> Maybe DumpFlag        -- Just df => show details in a file whose
                                         --            name is specified by df
                -> SDoc                  -- Header
                -> SDoc                  -- Extra info to appear after header
                -> CoreProgram -> [CoreRule]
                -> IO ()
-dumpPassResult dflags mb_flag hdr extra_info binds rules
+dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
   | Just flag <- mb_flag
-  = Err.dumpSDoc dflags flag (showSDoc dflags hdr) dump_doc
+  = Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
 
   | otherwise
   = Err.debugTraceMsg dflags 2 size_doc
@@ -781,6 +796,7 @@ data CoreReader = CoreReader {
         cr_hsc_env :: HscEnv,
         cr_rule_base :: RuleBase,
         cr_module :: Module,
+        cr_print_unqual :: PrintUnqualified,
 #ifdef GHCI
         cr_globals :: (MVar PersistentLinkerState, Bool)
 #else
@@ -854,9 +870,10 @@ runCoreM :: HscEnv
          -> RuleBase
          -> UniqSupply
          -> Module
+         -> PrintUnqualified
          -> CoreM a
          -> IO (a, SimplCount)
-runCoreM hsc_env rule_base us mod m = do
+runCoreM hsc_env rule_base us mod print_unqual m = do
         glbls <- saveLinkerGlobals
         liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
   where
@@ -864,7 +881,8 @@ runCoreM hsc_env rule_base us mod m = do
             cr_hsc_env = hsc_env,
             cr_rule_base = rule_base,
             cr_module = mod,
-            cr_globals = glbls
+            cr_globals = glbls,
+            cr_print_unqual = print_unqual
         }
     state = CoreState {
             cs_uniq_supply = us
@@ -934,6 +952,9 @@ getHscEnv = read cr_hsc_env
 getRuleBase :: CoreM RuleBase
 getRuleBase = read cr_rule_base
 
+getPrintUnqualified :: CoreM PrintUnqualified
+getPrintUnqualified = read cr_print_unqual
+
 addSimplCount :: SimplCount -> CoreM ()
 addSimplCount count = write (CoreWriter { cw_simpl_count = count })
 
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 2a70dcfdbb..8908cb3ced 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -76,9 +76,9 @@ core2core hsc_env guts
 
        ; let builtin_passes = getCoreToDo dflags
        ;
-       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $
-                        do { all_passes <- addPluginPasses dflags builtin_passes
-                           ; runCorePasses all_passes guts }
+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $
+                           do { all_passes <- addPluginPasses dflags builtin_passes
+                              ; runCorePasses all_passes guts }
 
 {--
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline
@@ -99,6 +99,7 @@ core2core hsc_env guts
     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
     -- would mean our cached value would go out of date.
+    print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
 \end{code}
 
 
@@ -384,11 +385,9 @@ runCorePasses passes guts
     do_pass guts CoreDoNothing = return guts
     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
     do_pass guts pass
-       = do { hsc_env <- getHscEnv
-            ; let dflags = hsc_dflags hsc_env
-            ; liftIO $ showPass dflags pass
+       = do { showPass pass
             ; guts' <- doCorePass pass guts
-            ; liftIO $ endPass hsc_env pass (mg_binds guts') (mg_rules guts')
+            ; endPass pass (mg_binds guts') (mg_rules guts')
             ; return guts' }
 
 doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
@@ -596,6 +595,7 @@ simplifyPgmIO :: CoreToDo
 simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
               hsc_env us hpt_rule_base
               guts@(ModGuts { mg_module = this_mod
+                            , mg_rdr_env = rdr_env
                             , mg_binds = binds, mg_rules = rules
                             , mg_fam_inst_env = fam_inst_env })
   = do { (termination_msg, it_count, counts_out, guts')
@@ -610,10 +610,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
         ; return (counts_out, guts')
     }
   where
-    dflags      = hsc_dflags hsc_env
-    dump_phase  = dumpSimplPhase dflags mode
-    simpl_env   = mkSimplEnv mode
-    active_rule = activeRule simpl_env
+    dflags       = hsc_dflags hsc_env
+    print_unqual = mkPrintUnqualified dflags rdr_env
+    dump_phase   = dumpSimplPhase dflags mode
+    simpl_env    = mkSimplEnv mode
+    active_rule  = activeRule simpl_env
 
     do_iteration :: UniqSupply
                  -> Int          -- Counts iterations
@@ -709,7 +710,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
            let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
 
                 -- Dump the result of this iteration
-           dump_end_iteration dflags iteration_no counts1 binds2 rules1 ;
+           dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;
            lintPassResult hsc_env pass binds2 ;
 
                 -- Loop
@@ -727,10 +728,10 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
 simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
 
 -------------------
-dump_end_iteration :: DynFlags -> Int
-             -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
-dump_end_iteration dflags iteration_no counts binds rules
-  = dumpPassResult dflags mb_flag hdr pp_counts binds rules
+dump_end_iteration :: DynFlags -> PrintUnqualified -> Int
+                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
+dump_end_iteration dflags print_unqual iteration_no counts binds rules
+  = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules
   where
     mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases
             | otherwise                               = Nothing
diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs
index 6a908836e2..e5561b2fc0 100644
--- a/compiler/simplCore/SimplMonad.lhs
+++ b/compiler/simplCore/SimplMonad.lhs
@@ -29,6 +29,7 @@ import CoreMonad
 import Outputable
 import FastString
 import MonadUtils
+import ErrUtils
 import Control.Monad       ( when, liftM, ap )
 \end{code}
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index f044be5ab8..cc55529906 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1615,8 +1615,9 @@ tryRules env rules fn args call_cont
       | otherwise
       = return ()
 
-    log_rule dflags flag hdr details = liftIO . dumpSDoc dflags flag "" $
-      sep [text hdr, nest 4 details]
+    log_rule dflags flag hdr details
+      = liftIO . dumpSDoc dflags alwaysQualify flag "" $
+                   sep [text hdr, nest 4 details]
 \end{code}
 
 Note [Optimising tagToEnum#]
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 9444058048..1ef3ab4cfe 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -390,8 +390,8 @@ tcDeriving tycl_decls inst_decls deriv_decls
 
         ; dflags <- getDynFlags
         ; unless (isEmptyBag inst_info) $
-            liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
-                   (ddump_deriving inst_info rn_binds newTyCons famInsts))
+             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+                        (ddump_deriving inst_info rn_binds newTyCons famInsts))
 
         ; let all_tycons = map ATyCon (bagToList newTyCons)
         ; gbl_env <- tcExtendGlobalEnv all_tycons $
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 953797e499..a4ba48c609 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -41,7 +41,7 @@ module Outputable (
         -- * Converting 'SDoc' into strings and outputing it
         printForC, printForAsm, printForUser, printForUserPartWay,
         pprCode, mkCodeStyle,
-        showSDoc, showSDocOneLine,
+        showSDoc, showSDocSimple, showSDocOneLine,
         showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
         showSDocUnqual, showPpr,
         renderWithStyle,
@@ -64,7 +64,7 @@ module Outputable (
         pprDeeper, pprDeeperList, pprSetDepth,
         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
         ifPprDebug, qualName, qualModule, qualPackage,
-        mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
+        mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
         mkUserStyle, cmdlineParserStyle, Depth(..),
 
         -- * Error handling and debugging utilities
@@ -125,15 +125,16 @@ data PprStyle
                 -- Assumes printing tidied code: non-system names are
                 -- printed without uniques.
 
-  | PprCode CodeStyle
-                -- Print code; either C or assembler
-
-  | PprDump     -- For -ddump-foo; less verbose than PprDebug.
+  | PprDump PrintUnqualified
+                -- For -ddump-foo; less verbose than PprDebug, but more than PprUser
                 -- Does not assume tidied code: non-external names
                 -- are printed with uniques.
 
   | PprDebug    -- Full debugging output
 
+  | PprCode CodeStyle
+                -- Print code; either C or assembler
+
 data CodeStyle = CStyle         -- The format of labels differs for C and assembler
                | AsmStyle
 
@@ -221,7 +222,11 @@ defaultUserStyle = mkUserStyle neverQualify AllTheWay
  -- Print without qualifiers to reduce verbosity, unless -dppr-debug
 
 defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
-                 |  otherwise          = PprDump
+                 |  otherwise          = PprDump neverQualify
+
+mkDumpStyle :: PrintUnqualified -> PprStyle
+mkDumpStyle print_unqual | opt_PprStyle_Debug = PprDebug
+                         | otherwise          = PprDump print_unqual
 
 defaultErrStyle :: DynFlags -> PprStyle
 -- Default style for error messages, when we don't know PrintUnqualified
@@ -324,15 +329,18 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
 \begin{code}
 qualName :: PprStyle -> QueryQualifyName
 qualName (PprUser q _)  mod occ = queryQualifyName q mod occ
+qualName (PprDump q)    mod occ = queryQualifyName q mod occ
 qualName _other         mod _   = NameQual (moduleName mod)
 
 qualModule :: PprStyle -> QueryQualifyModule
 qualModule (PprUser q _)  m = queryQualifyModule q m
-qualModule _other                   _m = True
+qualModule (PprDump q)    m = queryQualifyModule q m
+qualModule _other        _m = True
 
 qualPackage :: PprStyle -> QueryQualifyPackage
 qualPackage (PprUser q _)  m = queryQualifyPackage q m
-qualPackage _other                   _m = True
+qualPackage (PprDump q)    m = queryQualifyPackage q m
+qualPackage _other        _m = True
 
 queryQual :: PprStyle -> PrintUnqualified
 queryQual s = QueryQualify (qualName s)
@@ -348,8 +356,8 @@ asmStyle (PprCode AsmStyle)  = True
 asmStyle _other              = False
 
 dumpStyle :: PprStyle -> Bool
-dumpStyle PprDump = True
-dumpStyle _other  = False
+dumpStyle (PprDump {}) = True
+dumpStyle _other       = False
 
 debugStyle :: PprStyle -> Bool
 debugStyle PprDebug = True
@@ -402,6 +410,27 @@ mkCodeStyle = PprCode
 showSDoc :: DynFlags -> SDoc -> String
 showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
 
+showSDocSimple :: SDoc -> String
+showSDocSimple sdoc = showSDoc unsafeGlobalDynFlags sdoc
+
+showPpr :: Outputable a => DynFlags -> a -> String
+showPpr dflags thing = showSDoc dflags (ppr thing)
+
+showSDocUnqual :: DynFlags -> SDoc -> String
+-- Only used by Haddock
+showSDocUnqual dflags sdoc = showSDoc dflags sdoc
+
+showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
+-- Allows caller to specify the PrintUnqualified to use
+showSDocForUser dflags unqual doc
+ = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)
+
+showSDocDump :: DynFlags -> SDoc -> String
+showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle
+
+showSDocDebug :: DynFlags -> SDoc -> String
+showSDocDebug dflags d = renderWithStyle dflags d PprDebug
+
 renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
 renderWithStyle dflags sdoc sty
   = Pretty.showDoc PageMode (pprCols dflags) $
@@ -415,28 +444,10 @@ showSDocOneLine dflags d
  = Pretty.showDoc OneLineMode (pprCols dflags) $
    runSDoc d (initSDocContext dflags defaultUserStyle)
 
-showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
-showSDocForUser dflags unqual doc
- = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)
-
-showSDocUnqual :: DynFlags -> SDoc -> String
--- Only used by Haddock
-showSDocUnqual dflags doc
- = renderWithStyle dflags doc (mkUserStyle neverQualify AllTheWay)
-
-showSDocDump :: DynFlags -> SDoc -> String
-showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle
-
-showSDocDebug :: DynFlags -> SDoc -> String
-showSDocDebug dflags d = renderWithStyle dflags d PprDebug
-
 showSDocDumpOneLine :: DynFlags -> SDoc -> String
 showSDocDumpOneLine dflags d
  = Pretty.showDoc OneLineMode irrelevantNCols $
-   runSDoc d (initSDocContext dflags PprDump)
-
-showPpr :: Outputable a => DynFlags -> a -> String
-showPpr dflags thing = showSDoc dflags (ppr thing)
+   runSDoc d (initSDocContext dflags defaultDumpStyle)
 
 irrelevantNCols :: Int
 -- Used for OneLineMode and LeftMode when number of cols isn't used
@@ -1000,7 +1011,7 @@ pprTrace :: String -> SDoc -> a -> a
 -- ^ If debug output is on, show some 'SDoc' on the screen
 pprTrace str doc x
    | opt_NoDebugOutput = x
-   | otherwise         = pprDebugAndThen unsafeGlobalDynFlags trace str doc x
+   | otherwise         = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x
 
 pprPanicFastInt :: String -> SDoc -> FastInt
 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
@@ -1013,9 +1024,9 @@ warnPprTrace _     _     _     _    x | not debugIsOn     = x
 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 warnPprTrace False _file _line _msg x = x
 warnPprTrace True   file  line  msg x
-  = pprDebugAndThen unsafeGlobalDynFlags trace str msg x
+  = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x
   where
-    str = showSDoc unsafeGlobalDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line])
+    heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]
 
 assertPprPanic :: String -> Int -> SDoc -> a
 -- ^ Panic with an assertation failure, recording the given file and line number.
@@ -1027,10 +1038,10 @@ assertPprPanic file line msg
                      , text "line", int line ]
               , msg ]
 
-pprDebugAndThen :: DynFlags -> (String -> a) -> String -> SDoc -> a
+pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a
 pprDebugAndThen dflags cont heading pretty_msg
  = cont (showSDocDump dflags doc)
  where
-     doc = sep [text heading, nest 4 pretty_msg]
+     doc = sep [heading, nest 2 pretty_msg]
 \end{code}