Remove PprStyle param of logging actions

Use `withPprStyle` instead to apply a specific style to a SDoc.

17 files changed, 75 insertions, 77 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index ce14dee795..cd1227d418 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -611,7 +611,7 @@ setSessionDynFlags dflags = do
              | otherwise                      = ""
            msg = text "Starting " <> text prog
          tr <- if verbosity dflags >= 3
-                then return (logInfo dflags defaultDumpStyle msg)
+                then return (logInfo dflags $ withPprStyle defaultDumpStyle msg)
                 else return (pure ())
          let
           conf = IServConfig
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index b72bf0f1c5..b1f0e8eece 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -372,7 +372,7 @@ displayLintResults :: DynFlags -> CoreToDo
 displayLintResults dflags pass warns errs binds
   | not (isEmptyBag errs)
   = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
-           defaultDumpStyle
+           $ withPprStyle defaultDumpStyle
            (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
                  , text "*** Offending Program ***"
                  , pprCoreBindings binds
@@ -385,7 +385,7 @@ displayLintResults dflags pass warns errs binds
   -- If the Core linter encounters an error, output to stderr instead of
   -- stdout (#13342)
   = putLogMsg dflags NoReason Err.SevInfo noSrcSpan
-        defaultDumpStyle
+      $ withPprStyle defaultDumpStyle
         (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
 
   | otherwise = return ()
@@ -416,7 +416,8 @@ lintInteractiveExpr what hsc_env expr
 
     display_lint_err err
       = do { putLogMsg dflags NoReason Err.SevDump
-               noSrcSpan defaultDumpStyle
+               noSrcSpan
+               $ withPprStyle defaultDumpStyle
                (vcat [ lint_banner "errors" (text what)
                      , err
                      , text "*** Offending Program ***"
diff --git a/compiler/GHC/Core/Opt/Driver.hs b/compiler/GHC/Core/Opt/Driver.hs
index 982f13be35..082eb9d326 100644
--- a/compiler/GHC/Core/Opt/Driver.hs
+++ b/compiler/GHC/Core/Opt/Driver.hs
@@ -495,7 +495,7 @@ ruleCheckPass current_phase pat guts =
     ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn
                         ++ (mg_rules guts)
     ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
-                   defaultDumpStyle
+                   $ withPprStyle defaultDumpStyle
                    (ruleCheckProgram current_phase pat
                       rule_fn (mg_binds guts))
     ; return guts }
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 0db18b5790..0febfdb787 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -781,7 +781,7 @@ msg sev reason doc
              err_sty  = mkErrStyle dflags unqual
              user_sty = mkUserStyle unqual AllTheWay
              dump_sty = mkDumpStyle unqual
-       ; liftIO $ putLogMsg dflags reason sev loc sty doc }
+       ; liftIO $ putLogMsg dflags reason sev loc (withPprStyle sty doc) }
 
 -- | Output a String message to the screen
 putMsgS :: String -> CoreM ()
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index a733638934..0c77ffc477 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -86,8 +86,7 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
                                                    NoReason
                                                    SevDump
                                                    noSrcSpan
-                                                   defaultDumpStyle
-                                                   err
+                                                   $ withPprStyle defaultDumpStyle err
                                        ; ghcExit dflags 1
                                        }
                         Nothing  -> return ()
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 874bd2b253..b76874eeab 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -907,7 +907,7 @@ checkStability hpt sccs all_home_mods =
 -- | Each module is given a unique 'LogQueue' to redirect compilation messages
 -- to. A 'Nothing' value contains the result of compilation, and denotes the
 -- end of the message queue.
-data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])
+data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, MsgDoc)])
                          !(MVar ())
 
 -- | The graph of modules to compile and their corresponding result 'MVar' and
@@ -1126,7 +1126,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
             return (success_flag,ok_results)
 
   where
-    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
+    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,MsgDoc) -> IO ()
     writeLogQueue (LogQueue ref sem) msg = do
         atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
         _ <- tryPutMVar sem ()
@@ -1135,8 +1135,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
     -- The log_action callback that is used to synchronize messages from a
     -- worker thread.
     parLogAction :: LogQueue -> LogAction
-    parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do
-        writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))
+    parLogAction log_queue _dflags !reason !severity !srcSpan !msg = do
+        writeLogQueue log_queue (Just (reason,severity,srcSpan,msg))
 
     -- Print each message from the log_queue using the log_action from the
     -- session's DynFlags.
@@ -1149,8 +1149,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
 
             print_loop [] = read_msgs
             print_loop (x:xs) = case x of
-                Just (reason,severity,srcSpan,style,msg) -> do
-                    putLogMsg dflags reason severity srcSpan style msg
+                Just (reason,severity,srcSpan,msg) -> do
+                    putLogMsg dflags reason severity srcSpan msg
                     print_loop xs
                 -- Exit the loop once we encounter the end marker.
                 Nothing -> return ()
@@ -2653,8 +2653,8 @@ withDeferredDiagnostics f = do
     errors <- liftIO $ newIORef []
     fatals <- liftIO $ newIORef []
 
-    let deferDiagnostics _dflags !reason !severity !srcSpan !style !msg = do
-          let action = putLogMsg dflags reason severity srcSpan style msg
+    let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do
+          let action = putLogMsg dflags reason severity srcSpan msg
           case severity of
             SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ())
             SevError -> atomicModifyIORef' errors $ \i -> (action: i, ())
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 563af47e1f..5d9583fdb9 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -1913,7 +1913,7 @@ linkDynLibCheck dflags o_files dep_packages
  = do
     when (haveRtsOptsFlags dflags) $ do
       putLogMsg dflags NoReason SevInfo noSrcSpan
-          defaultUserStyle
+          $ withPprStyle defaultUserStyle
           (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
            text "    Call hs_init_ghc() from your main() function to set these options.")
 
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 474c61b563..09a59eb14b 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -1508,7 +1508,6 @@ type LogAction = DynFlags
               -> WarnReason
               -> Severity
               -> SrcSpan
-              -> PprStyle
               -> MsgDoc
               -> IO ()
 
@@ -1519,10 +1518,10 @@ defaultFatalMessager = hPutStrLn stderr
 -- See Note [JSON Error Messages]
 --
 jsonLogAction :: LogAction
-jsonLogAction dflags reason severity srcSpan _style msg
+jsonLogAction dflags reason severity srcSpan msg
   = do
-    defaultLogActionHPutStrDoc dflags stdout (doc $$ text "")
-                               (mkCodeStyle CStyle)
+    defaultLogActionHPutStrDoc dflags stdout
+      (withPprStyle (mkCodeStyle CStyle) (doc $$ text ""))
     where
       doc = renderJSON $
               JSObject [ ( "span", json srcSpan )
@@ -1533,13 +1532,13 @@ jsonLogAction dflags reason severity srcSpan _style msg
 
 
 defaultLogAction :: LogAction
-defaultLogAction dflags reason severity srcSpan style msg
+defaultLogAction dflags reason severity srcSpan msg
     = case severity of
-      SevOutput      -> printOut msg style
-      SevDump        -> printOut (msg $$ blankLine) style
-      SevInteractive -> putStrSDoc msg style
-      SevInfo        -> printErrs msg style
-      SevFatal       -> printErrs msg style
+      SevOutput      -> printOut msg
+      SevDump        -> printOut (msg $$ blankLine)
+      SevInteractive -> putStrSDoc msg
+      SevInfo        -> printErrs msg
+      SevFatal       -> printErrs msg
       SevWarning     -> printWarns
       SevError       -> printWarns
     where
@@ -1555,8 +1554,9 @@ defaultLogAction dflags reason severity srcSpan style msg
             if gopt Opt_DiagnosticsShowCaret dflags
             then getCaretDiagnostic severity srcSpan
             else pure empty
-        printErrs (message $+$ caretDiagnostic)
-            (setStyleColoured True style)
+        printErrs $ getPprStyle $ \style ->
+          withPprStyle (setStyleColoured True style)
+            (message $+$ caretDiagnostic)
         -- careful (#2302): printErrs prints in UTF-8,
         -- whereas converting to string first and using
         -- hPutStr would just emit the low 8 bits of
@@ -1584,16 +1584,16 @@ defaultLogAction dflags reason severity srcSpan style msg
           | otherwise = ""
 
 -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
-defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
-defaultLogActionHPrintDoc dflags h d sty
- = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty
+defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> IO ()
+defaultLogActionHPrintDoc dflags h d
+ = defaultLogActionHPutStrDoc dflags h (d $$ text "")
 
-defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
-defaultLogActionHPutStrDoc dflags h d sty
+defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> IO ()
+defaultLogActionHPutStrDoc dflags h d
   -- Don't add a newline at the end, so that successive
   -- calls to this log-action can output all on the same line
   = printSDoc ctx Pretty.PageMode h d
-    where ctx = initSDocContext dflags sty
+    where ctx = initSDocContext dflags defaultDumpStyle
 
 newtype FlushOut = FlushOut (IO ())
 
@@ -2171,8 +2171,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
   return (dflags5, leftover, warns' ++ warns)
 
 -- | Write an error or warning to the 'LogOutput'.
-putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle
-          -> MsgDoc -> IO ()
+putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()
 putLogMsg dflags = log_action dflags dflags
 
 updateWays :: DynFlags -> DynFlags
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index 49e3b00e50..a14cb17e04 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -101,8 +101,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
                                     NoReason
                                     SevOutput
                                     noSrcSpan
-                                    defaultDumpStyle
-                                    sd
+                                    $ withPprStyle defaultDumpStyle sd
                       QuietBinIFaceReading -> \_ -> return ()
 
         wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index b66bab1853..80c4505c8e 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -1117,7 +1117,7 @@ showIface hsc_env filename = do
                                    neverQualifyModules
                                    neverQualifyPackages
    putLogMsg dflags NoReason SevDump noSrcSpan
-      (mkDumpStyle print_unqual) (pprModIface iface)
+      $ withPprStyle (mkDumpStyle print_unqual) (pprModIface iface)
 
 -- Show a ModIface but don't display details; suitable for ModIfaces stored in
 -- the EPT.
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
index 511293ba5c..7ea450067e 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ b/compiler/GHC/Runtime/Debugger.hs
@@ -177,7 +177,7 @@ showTerm term = do
                       -- XXX: this tries to disable logging of errors
                       -- does this still do what it is intended to do
                       -- with the changed error handling and logging?
-           let noop_log _ _ _ _ _ _ = return ()
+           let noop_log _ _ _ _ _ = return ()
                expr = "Prelude.return (Prelude.show " ++
                          showPpr dflags bname ++
                       ") :: Prelude.IO Prelude.String"
diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs
index a5ba2e6ef0..2ac1fc12d2 100644
--- a/compiler/GHC/Runtime/Linker.hs
+++ b/compiler/GHC/Runtime/Linker.hs
@@ -237,7 +237,7 @@ showLinkerState :: DynLinker -> DynFlags -> IO ()
 showLinkerState dl dflags
   = do pls <- readPLS dl
        putLogMsg dflags NoReason SevDump noSrcSpan
-          defaultDumpStyle
+          $ withPprStyle defaultDumpStyle
                  (vcat [text "----- Linker state -----",
                         text "Pkgs:" <+> ppr (pkgs_loaded pls),
                         text "Objs:" <+> ppr (objs_loaded pls),
@@ -420,7 +420,7 @@ classifyLdInput dflags f
   | isDynLibFilename platform f = return (Just (DLLPath f))
   | otherwise          = do
         putLogMsg dflags NoReason SevInfo noSrcSpan
-            defaultUserStyle
+            $ withPprStyle defaultUserStyle
             (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
         return Nothing
     where platform = targetPlatform dflags
@@ -1414,7 +1414,7 @@ load_dyn hsc_env crash_early dll = do
           when (wopt Opt_WarnMissedExtraSharedLib dflags)
             $ putLogMsg dflags
                 (Reason Opt_WarnMissedExtraSharedLib) SevWarning
-                  noSrcSpan defaultUserStyle (note err)
+                  noSrcSpan $ withPprStyle defaultUserStyle (note err)
   where
     note err = vcat $ map text
       [ err
@@ -1715,8 +1715,7 @@ maybePutStr dflags s
               NoReason
               SevInteractive
               noSrcSpan
-              defaultUserStyle
-              (text s)
+              $ withPprStyle defaultUserStyle (text s)
 
 maybePutStrLn :: DynFlags -> String -> IO ()
 maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 80ca8768f3..34fc1a141e 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -75,7 +75,7 @@ lintStgTopBindings dflags this_mod unarised whodunnit binds
         return ()
       Just msg -> do
         putLogMsg dflags NoReason Err.SevDump noSrcSpan
-          defaultDumpStyle
+          $ withPprStyle defaultDumpStyle
           (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
                         text whodunnit <+> text "***",
                   msg,
diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs
index 3d12158b5c..46081df98c 100644
--- a/compiler/GHC/SysTools/ExtraObj.hs
+++ b/compiler/GHC/SysTools/ExtraObj.hs
@@ -77,7 +77,7 @@ mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
 mkExtraObjToLinkIntoBinary dflags = do
   when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
      putLogMsg dflags NoReason SevInfo noSrcSpan
-         defaultUserStyle
+         $ withPprStyle defaultUserStyle
          (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
           text "    Call hs_init_ghc() from your main() function to set these options.")
 
diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs
index 5482a4ef25..a7649ed534 100644
--- a/compiler/GHC/SysTools/Process.hs
+++ b/compiler/GHC/SysTools/Process.hs
@@ -282,11 +282,11 @@ builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do
       case msg of
         BuildMsg msg -> do
           putLogMsg dflags NoReason SevInfo noSrcSpan
-              defaultUserStyle msg
+              $ withPprStyle defaultUserStyle msg
           log_loop chan t
         BuildError loc msg -> do
           putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
-              defaultUserStyle msg
+              $ withPprStyle defaultUserStyle msg
           log_loop chan t
         EOF ->
           log_loop chan  (t-1)
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 6e21326f62..12716509f5 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -1902,7 +1902,7 @@ failIfM msg
         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
         ; dflags <- getDynFlags
         ; liftIO (putLogMsg dflags NoReason SevFatal
-                   noSrcSpan (defaultErrStyle dflags) full_msg)
+                   noSrcSpan $ withPprStyle (defaultErrStyle dflags) full_msg)
         ; failM }
 
 --------------------
@@ -1938,8 +1938,7 @@ forkM_maybe doc thing_inside
                                              NoReason
                                              SevFatal
                                              noSrcSpan
-                                             (defaultErrStyle dflags)
-                                             msg
+                                             $ withPprStyle (defaultErrStyle dflags) msg
 
                     ; traceIf (text "} ending fork (badly)" <+> doc)
                     ; return Nothing }
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index ed12d0104e..96f1e11f3a 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -379,7 +379,7 @@ printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
 printBagOfErrors dflags bag_of_errors
   = sequence_ [ let style = mkErrStyle dflags unqual
                     ctx   = initSDocContext dflags style
-                in putLogMsg dflags reason sev s style (formatErrDoc ctx doc)
+                in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc)
               | ErrMsg { errMsgSpan      = s,
                          errMsgDoc       = doc,
                          errMsgSeverity  = sev,
@@ -441,8 +441,8 @@ dumpIfSet dflags flag hdr doc
                             NoReason
                             SevDump
                             noSrcSpan
-                            defaultDumpStyle
-                            (mkDumpDoc hdr doc)
+                            (withPprStyle defaultDumpStyle
+                              (mkDumpDoc hdr doc))
 
 -- | a wrapper around 'dumpAction'.
 -- First check whether the dump flag is set
@@ -523,14 +523,14 @@ dumpSDocWithStyle sty dflags dumpOpt hdr doc =
                                 $$ blankLine
                                 $$ doc
                         return $ mkDumpDoc hdr d
-        defaultLogActionHPrintDoc dflags handle doc' sty
+        defaultLogActionHPrintDoc dflags handle (withPprStyle sty doc')
 
     -- write the dump to stdout
     writeDump Nothing = do
         let (doc', severity)
               | null hdr  = (doc, SevOutput)
               | otherwise = (mkDumpDoc hdr doc, SevDump)
-        putLogMsg dflags NoReason severity noSrcSpan sty doc'
+        putLogMsg dflags NoReason severity noSrcSpan (withPprStyle sty doc')
 
 
 -- | Choose where to put a dump file based on DynFlags
@@ -610,15 +610,15 @@ ifVerbose dflags val act
 
 errorMsg :: DynFlags -> MsgDoc -> IO ()
 errorMsg dflags msg
-   = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
+   = putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle (defaultErrStyle dflags) msg
 
 warningMsg :: DynFlags -> MsgDoc -> IO ()
 warningMsg dflags msg
-   = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
+   = putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle (defaultErrStyle dflags) msg
 
 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
 fatalErrorMsg dflags msg =
-    putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
+    putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle (defaultErrStyle dflags) msg
 
 fatalErrorMsg'' :: FatalMessager -> String -> IO ()
 fatalErrorMsg'' fm msg = fm msg
@@ -627,12 +627,12 @@ compilationProgressMsg :: DynFlags -> String -> IO ()
 compilationProgressMsg dflags msg = do
     traceEventIO $ "GHC progress: " ++ msg
     ifVerbose dflags 1 $
-        logOutput dflags defaultUserStyle (text msg)
+        logOutput dflags $ withPprStyle defaultUserStyle (text msg)
 
 showPass :: DynFlags -> String -> IO ()
 showPass dflags what
   = ifVerbose dflags 2 $
-    logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
+    logInfo dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)
 
 data PrintTimings = PrintTimings | DontPrintTimings
   deriving (Eq, Show)
@@ -727,7 +727,7 @@ withTiming' :: MonadIO m
 withTiming' dflags what force_result prtimings action
   = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
           then do whenPrintTimings $
-                    logInfo dflags defaultUserStyle $
+                    logInfo dflags $ withPprStyle defaultUserStyle $
                       text "***" <+> what <> colon
                   let ctx = initDefaultSDocContext dflags
                   eventBegins ctx what
@@ -743,7 +743,7 @@ withTiming' dflags what force_result prtimings action
                       time = realToFrac (end - start) * 1e-9
 
                   when (verbosity dflags >= 2 && prtimings == PrintTimings)
-                      $ liftIO $ logInfo dflags defaultUserStyle
+                      $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle
                           (text "!!!" <+> what <> colon <+> text "finished in"
                            <+> doublePrec 2 time
                            <+> text "milliseconds"
@@ -774,27 +774,29 @@ withTiming' dflags what force_result prtimings action
           eventEndsDoc   ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w
 
 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
-debugTraceMsg dflags val msg = ifVerbose dflags val $
-                               logInfo dflags defaultDumpStyle msg
+debugTraceMsg dflags val msg =
+   ifVerbose dflags val $
+      logInfo dflags (withPprStyle defaultDumpStyle msg)
+
 putMsg :: DynFlags -> MsgDoc -> IO ()
-putMsg dflags msg = logInfo dflags defaultUserStyle msg
+putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg)
 
 printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
 printInfoForUser dflags print_unqual msg
-  = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
+  = logInfo dflags (withUserStyle print_unqual AllTheWay msg)
 
 printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
 printOutputForUser dflags print_unqual msg
-  = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
+  = logOutput dflags (withUserStyle print_unqual AllTheWay msg)
 
-logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-logInfo dflags sty msg
-  = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg
+logInfo :: DynFlags -> MsgDoc -> IO ()
+logInfo dflags msg
+  = putLogMsg dflags NoReason SevInfo noSrcSpan msg
 
-logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
--- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
-logOutput dflags sty msg
-  = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg
+-- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
+logOutput :: DynFlags -> MsgDoc -> IO ()
+logOutput dflags msg
+  = putLogMsg dflags NoReason SevOutput noSrcSpan msg
 
 prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
 prettyPrintGhcErrors dflags