Dynflags: introduce DiagOpts

Use DiagOpts for diagnostic options instead of directly querying
DynFlags (#17957).

Surprising performance improvements on CI:

  T4801(normal) ghc/alloc   313236344.0   306515216.0  -2.1% GOOD
  T9961(normal) ghc/alloc   384502736.0   380584384.0  -1.0% GOOD
  ManyAlternatives(normal) ghc/alloc   797356128.0   786644928.0  -1.3%
  ManyConstructors(normal) ghc/alloc  4389732432.0  4317740880.0  -1.6%
  T783(normal) ghc/alloc   408142680.0   402812176.0  -1.3%

Metric Decrease:
    T4801
    T9961
    T783
    ManyAlternatives
    ManyConstructors

Bump haddock submodule

29 files changed, 296 insertions, 209 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 4fa2b60c82..2b5f3e06d5 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -312,6 +312,7 @@ import GHC.Driver.Session
 import GHC.Driver.Backend
 import GHC.Driver.Config.Parser (initParserOpts)
 import GHC.Driver.Config.Logger (initLogFlags)
+import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Main
 import GHC.Driver.Make
 import GHC.Driver.Hooks
@@ -444,19 +445,18 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
            case fromException exception of
                 -- an IO exception probably isn't our fault, so don't panic
                 Just (ioe :: IOException) ->
-                  fatalErrorMsg'' fm (show ioe)
+                  fm (show ioe)
                 _ -> case fromException exception of
                      Just UserInterrupt ->
                          -- Important to let this one propagate out so our
                          -- calling process knows we were interrupted by ^C
                          liftIO $ throwIO UserInterrupt
                      Just StackOverflow ->
-                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
+                         fm "stack overflow: use +RTS -K<size> to increase it"
                      _ -> case fromException exception of
                           Just (ex :: ExitCode) -> liftIO $ throwIO ex
                           _ ->
-                              fatalErrorMsg'' fm
-                                  (show (Panic (show exception)))
+                              fm (show (Panic (show exception)))
            exitWith (ExitFailure 1)
          ) $
 
@@ -466,7 +466,7 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
                 flushOut
                 case ge of
                      Signal _ -> exitWith (ExitFailure 1)
-                     _ -> do fatalErrorMsg'' fm (show ge)
+                     _ -> do fm (show ge)
                              exitWith (ExitFailure 1)
             ) $
   inner
@@ -903,7 +903,8 @@ checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
 checkNewDynFlags logger dflags = do
   -- See Note [DynFlags consistency]
   let (dflags', warnings) = makeDynFlagsConsistent dflags
-  liftIO $ handleFlagWarnings logger dflags (map (Warn WarningWithoutFlag) warnings)
+  let diag_opts = initDiagOpts dflags
+  liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings)
   return dflags'
 
 checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
@@ -911,10 +912,12 @@ checkNewInteractiveDynFlags logger dflags0 = do
   -- We currently don't support use of StaticPointers in expressions entered on
   -- the REPL. See #12356.
   if xopt LangExt.StaticPointers dflags0
-  then do liftIO $ printOrThrowDiagnostics logger dflags0 $ singleMessage
-            $ fmap GhcDriverMessage
-            $ mkPlainMsgEnvelope dflags0 interactiveSrcSpan DriverStaticPointersNotSupported
-          return $ xopt_unset dflags0 LangExt.StaticPointers
+  then do
+    let diag_opts = initDiagOpts dflags0
+    liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage
+      $ fmap GhcDriverMessage
+      $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported
+    return $ xopt_unset dflags0 LangExt.StaticPointers
   else return dflags0
 
 
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index fa780fb320..f20dbcc62b 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -28,6 +28,7 @@ import GHC.Prelude
 import GHC.Driver.Session
 import GHC.Driver.Ppr
 import GHC.Driver.Env
+import GHC.Driver.Config.Diagnostic
 
 import GHC.Tc.Utils.TcType ( isFloatingTy, isTyFamFree )
 import GHC.Unit.Module.ModGuts
@@ -2779,7 +2780,8 @@ addMsg is_error env msgs msg
                           , isGoodSrcSpan span ] of
                []    -> noSrcSpan
                (s:_) -> s
-   mk_msg msg = mkLocMessage (mkMCDiagnostic (le_dynflags env) WarningWithoutFlag) msg_span
+   !diag_opts = initDiagOpts (le_dynflags env)
+   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag) msg_span
                              (msg $$ context)
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 20f78f94bc..05d2e868aa 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -15,6 +15,7 @@ import GHC.Prelude
 import GHC.Driver.Session
 import GHC.Driver.Ppr
 import GHC.Driver.Config
+import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Env
 
 import GHC.Tc.Utils.TcType hiding( substTy )
@@ -816,8 +817,9 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn
   | otherwise                             = return ()
   where
     allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
+    diag_opts = initDiagOpts dflags
     doWarn reason =
-      msg (mkMCDiagnostic dflags reason)
+      msg (mkMCDiagnostic diag_opts reason)
         (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))
                 2 (vcat [ text "when specialising" <+> quotes (ppr caller)
                         | caller <- callers])
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 9c32bb3fb6..d366d7f904 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -22,6 +22,7 @@ import GHC.Prelude
 -- In a separate module because it hooks into the parser.
 import GHC.Driver.Backpack.Syntax
 import GHC.Driver.Config.Parser (initParserOpts)
+import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Monad
 import GHC.Driver.Session
 import GHC.Driver.Ppr
@@ -100,7 +101,7 @@ doBackpack [src_filename] = do
     modifySession (hscSetFlags dflags)
     -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
     liftIO $ checkProcessArgsResult unhandled_flags
-    liftIO $ handleFlagWarnings logger dflags warns
+    liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns
     -- TODO: Preprocessing not implemented
 
     buf <- liftIO $ hGetStringBuffer src_filename
diff --git a/compiler/GHC/Driver/Config/Diagnostic.hs b/compiler/GHC/Driver/Config/Diagnostic.hs
new file mode 100644
index 0000000000..00fa9695c3
--- /dev/null
+++ b/compiler/GHC/Driver/Config/Diagnostic.hs
@@ -0,0 +1,21 @@
+module GHC.Driver.Config.Diagnostic
+  ( initDiagOpts
+  )
+where
+
+import GHC.Driver.Flags
+import GHC.Driver.Session
+
+import GHC.Utils.Outputable
+import GHC.Utils.Error (DiagOpts (..))
+
+initDiagOpts :: DynFlags -> DiagOpts
+initDiagOpts dflags = DiagOpts
+  { diag_warning_flags       = warningFlags dflags
+  , diag_fatal_warning_flags = fatalWarningFlags dflags
+  , diag_warn_is_error       = gopt Opt_WarnIsError dflags
+  , diag_reverse_errors      = reverseErrors dflags
+  , diag_max_errors          = maxErrors dflags
+  , diag_ppr_ctx             = initSDocContext dflags defaultErrStyle
+  }
+
diff --git a/compiler/GHC/Driver/Config/Parser.hs b/compiler/GHC/Driver/Config/Parser.hs
index 335e1d530e..4757202ea7 100644
--- a/compiler/GHC/Driver/Config/Parser.hs
+++ b/compiler/GHC/Driver/Config/Parser.hs
@@ -7,7 +7,7 @@ import GHC.Prelude
 import GHC.Platform
 
 import GHC.Driver.Session
-import GHC.Utils.Error
+import GHC.Driver.Config.Diagnostic
 
 import GHC.Parser.Lexer
 
@@ -15,9 +15,8 @@ import GHC.Parser.Lexer
 initParserOpts :: DynFlags -> ParserOpts
 initParserOpts =
   mkParserOpts
-    <$> warningFlags
-    <*> extensionFlags
-    <*> mkPlainMsgEnvelope
+    <$> extensionFlags
+    <*> initDiagOpts
     <*> (supportedLanguagesAndExtensions . platformArchOS . targetPlatform)
     <*> safeImportsOn
     <*> gopt Opt_Haddock
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index cbddfa0ef3..c00537a3dd 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -36,6 +36,7 @@ import GHC.Driver.Session
 import GHC.Driver.Errors ( printOrThrowDiagnostics )
 import GHC.Driver.Errors.Types ( GhcMessage )
 import GHC.Driver.Config.Logger (initLogFlags)
+import GHC.Driver.Config.Diagnostic (initDiagOpts)
 import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
 
 import GHC.Runtime.Context
@@ -81,7 +82,8 @@ runHsc :: HscEnv -> Hsc a -> IO a
 runHsc hsc_env (Hsc hsc) = do
     (a, w) <- hsc hsc_env emptyMessages
     let dflags = hsc_dflags hsc_env
-    printOrThrowDiagnostics (hsc_logger hsc_env) dflags w
+    let !diag_opts = initDiagOpts dflags
+    printOrThrowDiagnostics (hsc_logger hsc_env) diag_opts w
     return a
 
 runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index 98cb0eef93..baaa551588 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -5,7 +5,6 @@ module GHC.Driver.Errors (
   , mkDriverPsHeaderMessage
   ) where
 
-import GHC.Driver.Session
 import GHC.Driver.Errors.Types
 import GHC.Data.Bag
 import GHC.Prelude
@@ -13,20 +12,20 @@ import GHC.Types.SrcLoc
 import GHC.Types.SourceError
 import GHC.Types.Error
 import GHC.Utils.Error
-import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext,  text, withPprStyle, mkErrStyle )
+import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext,  text, withPprStyle, mkErrStyle, sdocStyle )
 import GHC.Utils.Logger
 import qualified GHC.Driver.CmdLine as CmdLine
 
-printMessages :: Diagnostic a => Logger -> DynFlags -> Messages a -> IO ()
-printMessages logger dflags msgs
+printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
+printMessages logger opts msgs
   = sequence_ [ let style = mkErrStyle unqual
-                    ctx   = initSDocContext dflags style
+                    ctx   = (diag_ppr_ctx opts) { sdocStyle = style }
                 in logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $
                    withPprStyle style (messageWithHints ctx dia)
               | MsgEnvelope { errMsgSpan      = s,
                               errMsgDiagnostic = dia,
                               errMsgSeverity = sev,
-                              errMsgContext   = unqual } <- sortMsgBag (Just dflags)
+                              errMsgContext   = unqual } <- sortMsgBag (Just opts)
                                                                        (getMessages msgs) ]
   where
     messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc
@@ -38,26 +37,26 @@ printMessages logger dflags msgs
                hs  -> main_msg $$ hang (text "Suggested fixes:") 2
                                        (formatBulleted ctx . mkDecorated . map ppr $ hs)
 
-handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO ()
-handleFlagWarnings logger dflags warns = do
+handleFlagWarnings :: Logger -> DiagOpts -> [CmdLine.Warn] -> IO ()
+handleFlagWarnings logger opts warns = do
   let -- It would be nicer if warns :: [Located SDoc], but that
       -- has circular import problems.
-      bag = listToBag [ mkPlainMsgEnvelope dflags loc $
+      bag = listToBag [ mkPlainMsgEnvelope opts loc $
                         GhcDriverMessage $
                         DriverUnknownMessage $
                         mkPlainDiagnostic reason noHints $ text warn
                       | CmdLine.Warn reason (L loc warn) <- warns ]
 
-  printOrThrowDiagnostics logger dflags (mkMessages bag)
+  printOrThrowDiagnostics logger opts (mkMessages bag)
 
 -- | Given a bag of diagnostics, turn them into an exception if
 -- any has 'SevError', or print them out otherwise.
-printOrThrowDiagnostics :: Logger -> DynFlags -> Messages GhcMessage -> IO ()
-printOrThrowDiagnostics logger dflags msgs
+printOrThrowDiagnostics :: Logger -> DiagOpts -> Messages GhcMessage -> IO ()
+printOrThrowDiagnostics logger opts msgs
   | errorsOrFatalWarningsFound msgs
   = throwErrors msgs
   | otherwise
-  = printMessages logger dflags msgs
+  = printMessages logger opts msgs
 
 -- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it
 -- for dealing with parse errors when the driver is doing dependency analysis.
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index f68927ccb5..c3c7cd9e31 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -103,6 +103,7 @@ import GHC.Driver.Errors.Types
 import GHC.Driver.CodeOutput
 import GHC.Driver.Config.Logger (initLogFlags)
 import GHC.Driver.Config.Parser (initParserOpts)
+import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Hooks
 
 import GHC.Runtime.Context
@@ -281,10 +282,10 @@ getHscEnv = Hsc $ \e w -> return (e, w)
 
 handleWarnings :: Hsc ()
 handleWarnings = do
-    dflags <- getDynFlags
+    diag_opts <- initDiagOpts <$> getDynFlags
     logger <- getLogger
     w <- getDiagnostics
-    liftIO $ printOrThrowDiagnostics logger dflags w
+    liftIO $ printOrThrowDiagnostics logger diag_opts w
     clearDiagnostics
 
 -- | log warning in the monad, and if there are errors then
@@ -298,11 +299,11 @@ logWarningsReportErrors (warnings,errors) = do
 -- contain at least one error (e.g. coming from PFailed)
 handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a
 handleWarningsThrowErrors (warnings, errors) = do
-    dflags <- getDynFlags
+    diag_opts <- initDiagOpts <$> getDynFlags
     logDiagnostics (GhcPsMessage <$> warnings)
     logger <- getLogger
     let (wWarns, wErrs) = partitionMessages warnings
-    liftIO $ printMessages logger dflags wWarns
+    liftIO $ printMessages logger diag_opts wWarns
     throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs
 
 -- | Deal with errors and warnings returned by a compilation step
@@ -562,14 +563,15 @@ tcRnModule' :: ModSummary -> Bool -> HsParsedModule
             -> Hsc TcGblEnv
 tcRnModule' sum save_rn_syntax mod = do
     hsc_env <- getHscEnv
-    dflags   <- getDynFlags
+    dflags  <- getDynFlags
 
     let reason = WarningWithFlag Opt_WarnMissingSafeHaskellMode
+    let diag_opts = initDiagOpts dflags
     -- -Wmissing-safe-haskell-mode
     when (not (safeHaskellModeEnabled dflags)
           && wopt Opt_WarnMissingSafeHaskellMode dflags) $
         logDiagnostics $ singleMessage $
-        mkPlainMsgEnvelope dflags (getLoc (hpm_module mod)) $
+        mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $
         GhcDriverMessage $ DriverUnknownMessage $
         mkPlainDiagnostic reason noHints warnMissingSafeHaskellMode
 
@@ -599,14 +601,14 @@ tcRnModule' sum save_rn_syntax mod = do
               True
                 | safeHaskell dflags == Sf_Safe -> return ()
                 | otherwise -> (logDiagnostics $ singleMessage $
-                       mkPlainMsgEnvelope dflags (warnSafeOnLoc dflags) $
+                       mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $
                        GhcDriverMessage $ DriverUnknownMessage $
                        mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) noHints $
                        errSafe tcg_res')
               False | safeHaskell dflags == Sf_Trustworthy &&
                       wopt Opt_WarnTrustworthySafe dflags ->
                       (logDiagnostics $ singleMessage $
-                       mkPlainMsgEnvelope dflags (trustworthyOnLoc dflags) $
+                       mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $
                        GhcDriverMessage $ DriverUnknownMessage $
                        mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) noHints $
                        errTwthySafe tcg_res')
@@ -864,6 +866,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h
   logger <- getLogger
   let bcknd  = backend dflags
       hsc_src = ms_hsc_src summary
+      diag_opts = initDiagOpts dflags
 
   -- Desugar, if appropriate
   --
@@ -878,7 +881,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h
 
   -- Report the warnings from both typechecking and desugar together
   w <- getDiagnostics
-  liftIO $ printOrThrowDiagnostics logger dflags (unionMessages tc_warnings w)
+  liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w)
   clearDiagnostics
 
   -- Simplify, if appropriate, and (whether we simplified or not) generate an
@@ -1154,25 +1157,26 @@ hscCheckSafeImports tcg_env = do
 
   where
     checkRULES dflags tcg_env' =
-      case safeLanguageOn dflags of
+      let diag_opts = initDiagOpts dflags
+      in case safeLanguageOn dflags of
           True -> do
               -- XSafe: we nuke user written RULES
-              logDiagnostics $ fmap GhcDriverMessage $ warns dflags (tcg_rules tcg_env')
+              logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env')
               return tcg_env' { tcg_rules = [] }
           False
                 -- SafeInferred: user defined RULES, so not safe
               | safeInferOn dflags && not (null $ tcg_rules tcg_env')
-              -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
+              -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env')
 
                 -- Trustworthy OR SafeInferred: with no RULES
               | otherwise
               -> return tcg_env'
 
-    warns dflags rules = mkMessages $ listToBag $ map (warnRules dflags) rules
+    warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules
 
-    warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
-    warnRules df (L loc (HsRule { rd_name = n })) =
-        mkPlainMsgEnvelope df (locA loc) $
+    warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
+    warnRules diag_opts (L loc (HsRule { rd_name = n })) =
+        mkPlainMsgEnvelope diag_opts (locA loc) $
         DriverUnknownMessage $
         mkPlainDiagnostic WarningWithoutFlag noHints $
             text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
@@ -1318,6 +1322,7 @@ hscCheckSafe' m l = do
         hsc_env <- getHscEnv
         dflags <- getDynFlags
         iface <- lookup' m
+        let diag_opts = initDiagOpts dflags
         case iface of
             -- can't load iface to check trust!
             Nothing -> throwOneError $
@@ -1340,7 +1345,7 @@ hscCheckSafe' m l = do
                     warns = if wopt Opt_WarnInferredSafeImports dflags
                                 && safeLanguageOn dflags
                                 && trust == Sf_SafeInferred
-                                then inferredImportWarn dflags
+                                then inferredImportWarn diag_opts
                                 else emptyMessages
                     -- General errors we throw but Safe errors we log
                     errs = case (safeM, safeP) of
@@ -1354,8 +1359,8 @@ hscCheckSafe' m l = do
 
                 where
                     state = hsc_units hsc_env
-                    inferredImportWarn dflags = singleMessage
-                        $ mkMsgEnvelope dflags l (pkgQual state)
+                    inferredImportWarn diag_opts = singleMessage
+                        $ mkMsgEnvelope diag_opts l (pkgQual state)
                         $ GhcDriverMessage $ DriverUnknownMessage
                         $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports) noHints
                         $ sep
@@ -1450,9 +1455,10 @@ markUnsafeInfer tcg_env whyUnsafe = do
     dflags <- getDynFlags
 
     let reason = WarningWithFlag Opt_WarnUnsafe
-    when (wopt Opt_WarnUnsafe dflags)
+    let diag_opts = initDiagOpts dflags
+    when (diag_wopt Opt_WarnUnsafe diag_opts)
          (logDiagnostics $ singleMessage $
-             mkPlainMsgEnvelope dflags (warnUnsafeOnLoc dflags) $
+             mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $
              GhcDriverMessage $ DriverUnknownMessage $
              mkPlainDiagnostic reason noHints $
              whyUnsafe' dflags)
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 185a2189d7..7796fe61af 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -53,6 +53,7 @@ import GHC.Runtime.Context
 
 import GHC.Driver.Config.Logger (initLogFlags)
 import GHC.Driver.Config.Parser (initParserOpts)
+import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Phases
 import GHC.Driver.Pipeline
 import GHC.Driver.Session
@@ -273,6 +274,7 @@ warnMissingHomeModules hsc_env mod_graph =
   where
     dflags = hsc_dflags hsc_env
     targets = map targetId (hsc_targets hsc_env)
+    diag_opts = initDiagOpts dflags
 
     is_known_module mod = any (is_my_target mod) targets
 
@@ -304,7 +306,7 @@ warnMissingHomeModules hsc_env mod_graph =
     missing = map (moduleName . ms_mod) $
       filter (not . is_known_module) (mgModSummaries mod_graph)
 
-    warn = singleMessage $ mkPlainMsgEnvelope (hsc_dflags hsc_env) noSrcSpan
+    warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan
                          $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)
 
 -- | Describes which modules of the module graph need to be loaded.
@@ -356,6 +358,7 @@ warnUnusedPackages = do
     let dflags = hsc_dflags hsc_env
         state  = hsc_units  hsc_env
         pit = eps_PIT eps
+        diag_opts = initDiagOpts dflags
 
     let loadedPackages
           = map (unsafeLookupUnit state)
@@ -370,7 +373,7 @@ warnUnusedPackages = do
           = filter (\arg -> not $ any (matching state arg) loadedPackages)
                    requestedArgs
 
-    let warn = singleMessage $ mkPlainMsgEnvelope dflags noSrcSpan (DriverUnusedPackages unusedArgs)
+    let warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)
 
     when (not (null unusedArgs)) $
       logDiagnostics (GhcDriverMessage <$> warn)
@@ -1276,7 +1279,8 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags
         hsc_env <- readMVar hsc_env_var
         old_hpt <- readIORef old_hpt_var
 
-        let logg err = printMessages lcl_logger lcl_dflags (srcErrorMessages err)
+        let lcl_diag_opts = initDiagOpts lcl_dflags
+        let logg err = printMessages lcl_logger lcl_diag_opts (srcErrorMessages err)
 
         -- Limit the number of parallel compiles.
         let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)
@@ -1973,17 +1977,17 @@ mkNodeMap summaries = ModNodeMap $ Map.fromList
 -- were necessary, then the edge would be part of a cycle.
 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
 warnUnnecessarySourceImports sccs = do
-  dflags <- getDynFlags
-  when (wopt Opt_WarnUnusedImports dflags)
-    (logDiagnostics (mkMessages $ listToBag (concatMap (check dflags . flattenSCC) sccs)))
-  where check dflags ms =
+  diag_opts <- initDiagOpts <$> getDynFlags
+  when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do
+    let check ms =
            let mods_in_this_cycle = map ms_mod_name ms in
-           [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
-                             unLoc i `notElem`  mods_in_this_cycle ]
+           [ warn i | m <- ms, i <- ms_home_srcimps m,
+                      unLoc i `notElem`  mods_in_this_cycle ]
 
-        warn :: DynFlags -> Located ModuleName -> MsgEnvelope GhcMessage
-        warn dflags (L loc mod) =
-          GhcDriverMessage <$> mkPlainMsgEnvelope dflags loc (DriverUnnecessarySourceImports mod)
+        warn :: Located ModuleName -> MsgEnvelope GhcMessage
+        warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts
+                                                  loc (DriverUnnecessarySourceImports mod)
+    logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))
 
 
 -----------------------------------------------------------------------------
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 244ac04a0f..41a06d4485 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -38,6 +38,7 @@ import GHC.Driver.Session
 import GHC.Driver.Env
 import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages )
 import GHC.Driver.Errors.Types
+import GHC.Driver.Config.Diagnostic
 
 import GHC.Utils.Monad
 import GHC.Utils.Exception
@@ -145,7 +146,8 @@ logDiagnostics :: GhcMonad m => Messages GhcMessage -> m ()
 logDiagnostics warns = do
   dflags <- getSessionDynFlags
   logger <- getLogger
-  liftIO $ printOrThrowDiagnostics logger dflags warns
+  let !diag_opts = initDiagOpts dflags
+  liftIO $ printOrThrowDiagnostics logger diag_opts warns
 
 -- -----------------------------------------------------------------------------
 -- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,
@@ -244,7 +246,8 @@ printException :: GhcMonad m => SourceError -> m ()
 printException err = do
   dflags <- getSessionDynFlags
   logger <- getLogger
-  liftIO $ printMessages logger dflags (srcErrorMessages err)
+  let !diag_opts = initDiagOpts dflags
+  liftIO $ printMessages logger diag_opts (srcErrorMessages err)
 
 -- | A function called to log warnings and errors.
 type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index a23cb76cbc..3825019d8b 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -50,6 +50,7 @@ import GHC.Driver.Errors
 import GHC.Driver.Errors.Types
 import GHC.Driver.Pipeline.Monad
 import GHC.Driver.Config.Parser (initParserOpts)
+import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Phases
 import GHC.Driver.Session
 import GHC.Driver.Backend
@@ -1146,7 +1147,7 @@ runPhase (RealPhase (Cpp sf)) input_fn
            -- we have to be careful to emit warnings only once.
            unless (gopt Opt_Pp dflags1) $ do
                logger <- getLogger
-               liftIO $ handleFlagWarnings logger dflags1 warns
+               liftIO $ handleFlagWarnings logger (initDiagOpts dflags1) warns
 
            -- no need to preprocess CPP, just pass input file along
            -- to the next phase of the pipeline.
@@ -1170,7 +1171,7 @@ runPhase (RealPhase (Cpp sf)) input_fn
             liftIO $ checkProcessArgsResult unhandled_flags
             unless (gopt Opt_Pp dflags2) $ do
                 logger <- getLogger
-                liftIO $ handleFlagWarnings logger dflags2 warns
+                liftIO $ handleFlagWarnings logger (initDiagOpts dflags2) warns
             -- the HsPp pass below will emit warnings
 
             return (RealPhase (HsPp sf), output_fn)
@@ -1203,7 +1204,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do
             <- liftIO $ parseDynamicFilePragma dflags src_opts
         setDynFlags dflags1
         liftIO $ checkProcessArgsResult unhandled_flags
-        liftIO $ handleFlagWarnings logger dflags1 warns
+        liftIO $ handleFlagWarnings logger (initDiagOpts dflags1) warns
 
         return (RealPhase (Hsc sf), output_fn)
 
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 721ef1074e..d1689ce81a 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -60,6 +60,7 @@ import GHC.Prelude
 import GHC.Driver.Env
 import GHC.Driver.Session
 import GHC.Driver.Ppr
+import GHC.Driver.Config.Diagnostic
 
 import GHC.Hs
 
@@ -481,8 +482,8 @@ diagnosticDs :: DsMessage -> DsM ()
 diagnosticDs dsMessage
   = do { env <- getGblEnv
        ; loc <- getSrcSpanDs
-       ; dflags <- getDynFlags
-       ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) dsMessage
+       ; !diag_opts <- initDiagOpts <$> getDynFlags
+       ; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage
        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
 
 -- | Issue an error, but return the expression for (), so that we can continue
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index 749c8ea725..1b1fca8b17 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -45,6 +45,7 @@ import GHC.Driver.Env
 import GHC.Driver.Session
 import GHC.Driver.Ppr
 import GHC.Driver.Config
+import GHC.Driver.Config.Diagnostic
 
 import GHC.Tc.Utils.Monad
 
@@ -1416,12 +1417,12 @@ load_dyn interp hsc_env crash_early dll = do
       if crash_early
         then cmdLineErrorIO err
         else
-          when (wopt Opt_WarnMissedExtraSharedLib dflags)
+          when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)
             $ logMsg logger
-                (mkMCDiagnostic dflags $ WarningWithFlag Opt_WarnMissedExtraSharedLib)
+                (mkMCDiagnostic diag_opts $ WarningWithFlag Opt_WarnMissedExtraSharedLib)
                   noSrcSpan $ withPprStyle defaultUserStyle (note err)
   where
-    dflags = hsc_dflags hsc_env
+    diag_opts = initDiagOpts (hsc_dflags hsc_env)
     logger = hsc_logger hsc_env
     note err = vcat $ map text
       [ err
@@ -1509,6 +1510,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib
    where
      dflags = hsc_dflags hsc_env
      logger = hsc_logger hsc_env
+     diag_opts = initDiagOpts dflags
      dirs   = lib_dirs ++ gcc_dirs
      gcc    = False
      user   = True
@@ -1578,7 +1580,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib
       , not loading_dynamic_hs_libs
       , interpreterProfiled interp
       = do
-          let diag = mkMCDiagnostic dflags WarningWithoutFlag
+          let diag = mkMCDiagnostic diag_opts WarningWithoutFlag
           logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $
             text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$
               text " \tTrying dynamic library instead. If this fails try to rebuild" <+>
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 7c9b951eba..812c4558db 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -2320,16 +2320,16 @@ warnopt f options = f `EnumSet.member` pWarningFlags options
 --
 -- See 'mkParserOpts' to construct this.
 data ParserOpts = ParserOpts
-  { pWarningFlags   :: EnumSet WarningFlag -- ^ enabled warning flags
-  , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions
-  , pMakePsMessage  :: SrcSpan -> PsMessage -> MsgEnvelope PsMessage
-    -- ^ The function to be used to construct diagnostic messages.
-    -- The idea is to partially-apply 'mkParserMessage' upstream, to
-    -- avoid the dependency on the 'DynFlags' in the Lexer.
+  { pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions
+  , pDiagOpts       :: !DiagOpts
+    -- ^ Options to construct diagnostic messages.
   , pSupportedExts  :: [String]
     -- ^ supported extensions (only used for suggestions in error messages)
   }
 
+pWarningFlags :: ParserOpts -> EnumSet WarningFlag
+pWarningFlags opts = diag_warning_flags (pDiagOpts opts)
+
 -- | Haddock comment as produced by the lexer. These are accumulated in
 -- 'PState' and then processed in "GHC.Parser.PostProcess.Haddock".
 data HdkComment
@@ -2772,9 +2772,8 @@ data ExtBits
 
 {-# INLINE mkParserOpts #-}
 mkParserOpts
-  :: EnumSet WarningFlag        -- ^ warnings flags enabled
-  -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled
-  -> (SrcSpan -> PsMessage -> MsgEnvelope PsMessage) -- ^ How to construct diagnostics
+  :: EnumSet LangExt.Extension  -- ^ permitted language extensions enabled
+  -> DiagOpts                   -- ^ diagnostic options
   -> [String]                   -- ^ Supported Languages and Extensions
   -> Bool                       -- ^ are safe imports on?
   -> Bool                       -- ^ keeping Haddock comment tokens
@@ -2787,12 +2786,11 @@ mkParserOpts
 
   -> ParserOpts
 -- ^ Given exactly the information needed, set up the 'ParserOpts'
-mkParserOpts warningFlags extensionFlags mkMessage supported
+mkParserOpts extensionFlags diag_opts supported
   safeImports isHaddock rawTokStream usePosPrags =
     ParserOpts {
-      pWarningFlags  = warningFlags
+      pDiagOpts      = diag_opts
     , pExtsBitmap    = safeHaskellBit .|. langExtBits .|. optBits
-    , pMakePsMessage = mkMessage
     , pSupportedExts = supported
     }
   where
@@ -2994,8 +2992,8 @@ getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos
 
 addPsMessage :: SrcSpan -> PsMessage -> P ()
 addPsMessage srcspan msg = do
-  opts <- options <$> getPState
-  addWarning ((pMakePsMessage opts) srcspan msg)
+  diag_opts <- (pDiagOpts . options) <$> getPState
+  addWarning (mkPlainMsgEnvelope diag_opts srcspan msg)
 
 addTabWarning :: RealSrcSpan -> P ()
 addTabWarning srcspan
@@ -3017,17 +3015,17 @@ getErrorMessages p = errors p
 getMessages :: PState -> (Messages PsMessage, Messages PsMessage)
 getMessages p =
   let ws = warnings p
+      diag_opts = pDiagOpts (options p)
       -- we add the tabulation warning on the fly because
       -- we count the number of occurrences of tab characters
       ws' = case tab_first p of
         Strict.Nothing -> ws
         Strict.Just tf ->
-          let msg = mkMsg (RealSrcSpan tf Strict.Nothing) $
+          let msg = mkPlainMsgEnvelope diag_opts
+                          (RealSrcSpan tf Strict.Nothing)
                           (PsWarnTab (tab_count p))
           in msg `addMessage` ws
   in (ws', errors p)
-  where
-    mkMsg = pMakePsMessage . options $ p
 
 getContext :: P [LayoutContext]
 getContext = P $ \s@PState{context=ctx} -> POk s ctx
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 5b15f92167..404008ac0e 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -42,24 +42,31 @@ import GHC.Prelude
 import GHC.Stg.Syntax
 
 import GHC.Driver.Session
+import GHC.Driver.Config.Diagnostic
+
 import GHC.Core.Lint        ( interactiveInScope )
-import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
+import GHC.Core.DataCon
+import GHC.Core             ( AltCon(..) )
+import GHC.Core.Type
+
 import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )
 import GHC.Types.CostCentre ( isCurrentCCS )
 import GHC.Types.Id
 import GHC.Types.Var.Set
-import GHC.Core.DataCon
-import GHC.Core             ( AltCon(..) )
 import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )
-import GHC.Utils.Error      ( mkLocMessage )
-import GHC.Core.Type
 import GHC.Types.RepType
 import GHC.Types.SrcLoc
+
 import GHC.Utils.Logger
 import GHC.Utils.Outputable
+import GHC.Utils.Error      ( mkLocMessage, DiagOpts )
+import qualified GHC.Utils.Error as Err
+
 import GHC.Unit.Module            ( Module )
 import GHC.Runtime.Context        ( InteractiveContext )
-import qualified GHC.Utils.Error as Err
+
+import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
+
 import Control.Applicative ((<|>))
 import Control.Monad
 
@@ -75,7 +82,7 @@ lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
 
 lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds
   = {-# SCC "StgLint" #-}
-    case initL dflags this_mod unarised opts top_level_binds (lint_binds binds) of
+    case initL diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of
       Nothing  ->
         return ()
       Just msg -> do
@@ -89,6 +96,7 @@ lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds
                   text "*** End of Offense ***"])
         Err.ghcExit logger 1
   where
+    diag_opts = initDiagOpts dflags
     opts = initStgPprOpts dflags
     -- Bring all top-level binds into scope because CoreToStg does not generate
     -- bindings in dependency order (so we may see a use before its definition).
@@ -247,7 +255,7 @@ The Lint monad
 newtype LintM a = LintM
     { unLintM :: Module
               -> LintFlags
-              -> DynFlags
+              -> DiagOpts          -- Diagnostic options
               -> StgPprOpts        -- Pretty-printing options
               -> [LintLocInfo]     -- Locations
               -> IdSet             -- Local vars in scope
@@ -282,9 +290,9 @@ pp_binders bs
     pp_binder b
       = hsep [ppr b, dcolon, ppr (idType b)]
 
-initL :: DynFlags -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
-initL dflags this_mod unarised opts locals (LintM m) = do
-  let (_, errs) = m this_mod (LintFlags unarised) dflags opts [] locals emptyBag
+initL :: DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
+initL diag_opts this_mod unarised opts locals (LintM m) = do
+  let (_, errs) = m this_mod (LintFlags unarised) diag_opts opts [] locals emptyBag
   if isEmptyBag errs then
       Nothing
   else
@@ -300,14 +308,14 @@ instance Monad LintM where
     (>>)  = (*>)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \mod lf dflags opts loc scope errs
-  -> case unLintM m mod lf dflags opts loc scope errs of
-      (r, errs') -> unLintM (k r) mod lf dflags opts loc scope errs'
+thenL m k = LintM $ \mod lf diag_opts opts loc scope errs
+  -> case unLintM m mod lf diag_opts opts loc scope errs of
+      (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs'
 
 thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \mod lf dflags opts loc scope errs
-  -> case unLintM m mod lf dflags opts loc scope errs of
-      (_, errs') -> unLintM k mod lf dflags opts loc scope errs'
+thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs
+  -> case unLintM m mod lf diag_opts opts loc scope errs of
+      (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs'
 
 checkL :: Bool -> SDoc -> LintM ()
 checkL True  _   = return ()
@@ -354,24 +362,24 @@ checkPostUnariseId id =
 addErrL :: SDoc -> LintM ()
 addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc)
 
-addErr :: DynFlags -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
-addErr dflags errs_so_far msg locs
+addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
+addErr diag_opts errs_so_far msg locs
   = errs_so_far `snocBag` mk_msg locs
   where
     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
-                     in  mkLocMessage (Err.mkMCDiagnostic dflags WarningWithoutFlag)
+                     in  mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag)
                                       l (hdr $$ msg)
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \mod lf dflags opts loc scope errs
-   -> unLintM m mod lf dflags opts (extra_loc:loc) scope errs
+addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs
+   -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs
 
 addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \mod lf dflags opts loc scope errs
+addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs
  -> let
         new_set = mkVarSet ids
-    in unLintM m mod lf dflags opts loc (scope `unionVarSet` new_set) errs
+    in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs
 
 getLintFlags :: LintM LintFlags
 getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)
@@ -380,10 +388,10 @@ getStgPprOpts :: LintM StgPprOpts
 getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
 
 checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \mod _lf dflags _opts loc scope errs
+checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs
  -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
-        ((), addErr dflags errs (hsep [ppr id, dcolon, ppr (idType id),
-                                text "is out of scope"]) loc)
+        ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),
+                                    text "is out of scope"]) loc)
     else
         ((), errs)
 
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 2f6702bfc8..c26dce5161 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -14,68 +14,73 @@ module GHC.Tc.Errors(
 
 import GHC.Prelude
 
+import GHC.Driver.Env (hsc_units)
+import GHC.Driver.Session
+import GHC.Driver.Ppr
+import GHC.Driver.Config.Diagnostic
+
 import GHC.Tc.Types
 import GHC.Tc.Utils.Monad
+import GHC.Tc.Errors.Types
 import GHC.Tc.Types.Constraint
-import GHC.Core.Predicate
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Utils.Env( tcInitTidyEnv )
 import GHC.Tc.Utils.TcType
 import GHC.Tc.Utils.Unify ( checkTyVarEq )
 import GHC.Tc.Types.Origin
-import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Ppr  ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )
-import GHC.Core.Unify     ( tcMatchTys, flattenTys )
-import GHC.Unit.Module
-import GHC.Tc.Errors.Types
-import GHC.Tc.Instance.Family
-import GHC.Tc.Utils.Instantiate
-import GHC.Core.InstEnv
-import GHC.Core.TyCon
-import GHC.Core.Class
-import GHC.Core.DataCon
 import GHC.Tc.Types.Evidence
 import GHC.Tc.Types.EvTerm
-import GHC.Hs.Binds ( PatSynBind(..) )
+import GHC.Tc.Instance.Family
+import GHC.Tc.Utils.Instantiate
+import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits )
+
 import GHC.Types.Name
 import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual
                              , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc )
-import GHC.Builtin.Names ( typeableClassName )
 import GHC.Types.Id
 import GHC.Types.Var
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Types.Name.Env
 import GHC.Types.Name.Set
-import GHC.Data.Bag
-import GHC.Utils.Error  (diagReasonSeverity,  pprLocMsgEnvelope )
+import GHC.Types.SrcLoc
 import GHC.Types.Basic
 import GHC.Types.Error
+
+import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
+import GHC.Unit.Module
+import GHC.Hs.Binds ( PatSynBind(..) )
+import GHC.Builtin.Names ( typeableClassName )
+import qualified GHC.LanguageExtensions as LangExt
+
+import GHC.Core.Predicate
+import GHC.Core.Type
+import GHC.Core.Coercion
+import GHC.Core.TyCo.Rep
+import GHC.Core.TyCo.Ppr  ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )
+import GHC.Core.Unify     ( tcMatchTys, flattenTys )
+import GHC.Core.InstEnv
+import GHC.Core.TyCon
+import GHC.Core.Class
+import GHC.Core.DataCon
 import GHC.Core.ConLike ( ConLike(..))
+
+import GHC.Utils.Error  (diagReasonSeverity,  pprLocMsgEnvelope )
 import GHC.Utils.Misc
-import GHC.Data.FastString
 import GHC.Utils.Outputable as O
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
-import GHC.Types.SrcLoc
-import GHC.Driver.Env (hsc_units)
-import GHC.Driver.Session
-import GHC.Driver.Ppr
+import GHC.Utils.FV ( fvVarList, unionFV )
+
+import GHC.Data.Bag
+import GHC.Data.FastString
 import GHC.Data.List.SetOps ( equivClasses )
 import GHC.Data.Maybe
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Utils.FV ( fvVarList, unionFV )
 import qualified GHC.Data.Strict as Strict
 
 import Control.Monad    ( unless, when, foldM, forM_ )
 import Data.Foldable    ( toList )
 import Data.List        ( partition, mapAccumL, sortBy, unfoldr )
-
-import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits )
-
 -- import Data.Semigroup   ( Semigroup )
 import qualified Data.Semigroup as Semigroup
 
@@ -721,8 +726,8 @@ reportHoles :: [Ct]  -- other (tidied) constraints
             -> ReportErrCtxt -> [Hole] -> TcM ()
 reportHoles tidy_cts ctxt holes
   = do
-      df <- getDynFlags
-      let severity = diagReasonSeverity df (cec_type_holes ctxt)
+      diag_opts <- initDiagOpts <$> getDynFlags
+      let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt)
           holes'   = filter (keepThisHole severity) holes
       -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError`
       -- because otherwise types will be zonked and tidied many times over.
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index b4d15ee4ab..4a5c71a85c 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -38,6 +38,7 @@ import GHC.Driver.Main
 import GHC.Driver.Session
 import GHC.Driver.Env
 import GHC.Driver.Hooks
+import GHC.Driver.Config.Diagnostic
 
 import GHC.Hs
 
@@ -995,8 +996,8 @@ runMeta' show_code ppr_hs run_and_convert expr
         -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all
         -- cases.
         ; logger <- getLogger
-        ; dflags <- getDynFlags
-        ; liftIO $ printMessages logger dflags ds_msgs
+        ; diag_opts <- initDiagOpts <$> getDynFlags
+        ; liftIO $ printMessages logger diag_opts ds_msgs
 
         ; ds_expr <- case mb_ds_expr of
             Nothing      -> failM   -- Case (a) from Note [Errors in desugaring a splice]
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 08005f1a74..696e8dc8a3 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -53,6 +53,7 @@ import GHC.Prelude
 import GHC.Driver.Env
 import GHC.Driver.Plugins
 import GHC.Driver.Session
+import GHC.Driver.Config.Diagnostic
 
 import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )
 import GHC.Tc.Errors.Types
@@ -3163,6 +3164,7 @@ mark_plugin_unsafe :: DynFlags -> TcM ()
 mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $
   recordUnsafeInfer pluginUnsafe
   where
+    !diag_opts = initDiagOpts dflags
     pluginUnsafe =
       singleMessage $
-      mkPlainMsgEnvelope dflags noSrcSpan TcRnUnsafeDueToPlugin
+      mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 0572ab00db..ea6b2f2ba5 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -175,6 +175,7 @@ import GHC.Core.FamInstEnv
 
 import GHC.Driver.Env
 import GHC.Driver.Session
+import GHC.Driver.Config.Diagnostic
 
 import GHC.Runtime.Context
 
@@ -1051,8 +1052,8 @@ mkTcRnMessage :: SrcSpan
               -> TcRn (MsgEnvelope TcRnMessage)
 mkTcRnMessage loc msg
   = do { printer <- getPrintUnqualified ;
-         dflags <- getDynFlags ;
-         return $ mkMsgEnvelope dflags loc printer msg }
+         diag_opts <- initDiagOpts <$> getDynFlags ;
+         return $ mkMsgEnvelope diag_opts loc printer msg }
 
 reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()
 reportDiagnostics = mapM_ reportDiagnostic
@@ -1538,11 +1539,11 @@ addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
 addDetailedDiagnostic mkMsg = do
   loc <- getSrcSpanM
   printer <- getPrintUnqualified
-  dflags  <- getDynFlags
+  !diag_opts  <- initDiagOpts <$> getDynFlags
   env0 <- tcInitTidyEnv
   ctxt <- getErrCtxt
   err_info <- mkErrInfo env0 ctxt
-  reportDiagnostic (mkMsgEnvelope dflags loc printer (mkMsg (ErrInfo err_info empty)))
+  reportDiagnostic (mkMsgEnvelope diag_opts loc printer (mkMsg (ErrInfo err_info empty)))
 
 addTcRnDiagnostic :: TcRnMessage -> TcM ()
 addTcRnDiagnostic msg = do
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 93ab233788..49dc9d6fdd 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -30,6 +30,7 @@ module GHC.Utils.Error (
         formatBulleted,
 
         -- ** Construction
+        DiagOpts (..), diag_wopt, diag_fatal_wopt,
         emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn,
         mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
         mkErrorMsgEnvelope,
@@ -42,14 +43,13 @@ module GHC.Utils.Error (
         noHints,
 
         -- * Utilities
-        doIfSet, doIfSet_dyn,
         getCaretDiagnostic,
 
         -- * Issuing messages during compilation
         putMsg, printInfoForUser, printOutputForUser,
         logInfo, logOutput,
         errorMsg,
-        fatalErrorMsg, fatalErrorMsg'',
+        fatalErrorMsg,
         compilationProgressMsg,
         showPass,
         withTiming, withTimingSilent,
@@ -63,9 +63,12 @@ module GHC.Utils.Error (
 
 import GHC.Prelude
 
-import GHC.Driver.Session
+import GHC.Driver.Flags
 
 import GHC.Data.Bag
+import qualified GHC.Data.EnumSet as EnumSet
+import GHC.Data.EnumSet (EnumSet)
+
 import GHC.Utils.Exception
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
@@ -76,7 +79,6 @@ import GHC.Types.SrcLoc as SrcLoc
 
 import System.Exit      ( ExitCode(..), exitWith )
 import Data.List        ( sortBy )
-import Data.Maybe       ( fromMaybe )
 import Data.Function
 import Debug.Trace
 import Control.Monad
@@ -85,24 +87,43 @@ import Control.Monad.Catch as MC (handle)
 import GHC.Conc         ( getAllocationCounter )
 import System.CPUTime
 
--- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of
--- the 'DynFlags'. This function /has/ to be called when a diagnostic is constructed,
--- i.e. with a 'DynFlags' \"snapshot\" taken as close as possible to where a
--- particular diagnostic message is built, otherwise the computed 'Severity' might
--- not be correct, due to the mutable nature of the 'DynFlags' in GHC.
-diagReasonSeverity :: DynFlags -> DiagnosticReason -> Severity
-diagReasonSeverity dflags (WarningWithFlag wflag) | not (wopt wflag dflags)     = SevIgnore
-                                                  | wopt_fatal wflag dflags     = SevError
-                                                  | otherwise                   = SevWarning
-diagReasonSeverity dflags WarningWithoutFlag      | gopt Opt_WarnIsError dflags = SevError
-                                                  | otherwise                   = SevWarning
-diagReasonSeverity _      ErrorWithoutFlag                                      = SevError
+data DiagOpts = DiagOpts
+  { diag_warning_flags       :: !(EnumSet WarningFlag) -- ^ Enabled warnings
+  , diag_fatal_warning_flags :: !(EnumSet WarningFlag) -- ^ Fatal warnings
+  , diag_warn_is_error       :: !Bool                  -- ^ Treat warnings as errors
+  , diag_reverse_errors      :: !Bool                  -- ^ Reverse error reporting order
+  , diag_max_errors          :: !(Maybe Int)           -- ^ Max reported error count
+  , diag_ppr_ctx             :: !SDocContext           -- ^ Error printing context
+  }
 
+diag_wopt :: WarningFlag -> DiagOpts -> Bool
+diag_wopt wflag opts = wflag `EnumSet.member` diag_warning_flags opts
 
+diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool
+diag_fatal_wopt wflag opts = wflag `EnumSet.member` diag_fatal_warning_flags opts
 
--- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the 'DynFlags'.
-mkMCDiagnostic :: DynFlags -> DiagnosticReason -> MessageClass
-mkMCDiagnostic dflags reason = MCDiagnostic (diagReasonSeverity dflags reason) reason
+-- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of
+-- the 'DiagOpts. This function /has/ to be called when a diagnostic is constructed,
+-- i.e. with a 'DiagOpts \"snapshot\" taken as close as possible to where a
+-- particular diagnostic message is built, otherwise the computed 'Severity' might
+-- not be correct, due to the mutable nature of the 'DynFlags' in GHC.
+diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity
+diagReasonSeverity opts reason = case reason of
+  WarningWithFlag wflag
+    | not (diag_wopt wflag opts) -> SevIgnore
+    | diag_fatal_wopt wflag opts -> SevError
+    | otherwise                  -> SevWarning
+  WarningWithoutFlag
+    | diag_warn_is_error opts -> SevError
+    | otherwise             -> SevWarning
+  ErrorWithoutFlag
+    -> SevError
+
+
+-- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the
+-- 'DiagOpts.
+mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> MessageClass
+mkMCDiagnostic opts reason = MCDiagnostic (diagReasonSeverity opts reason) reason
 
 -- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the
 -- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'.
@@ -129,16 +150,16 @@ mk_msg_envelope severity locn print_unqual err
 
 -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.
 -- If you know your 'Diagnostic' is an error, consider using 'mkErrorMsgEnvelope',
--- which does not require looking at the 'DynFlags'
+-- which does not require looking at the 'DiagOpts'
 mkMsgEnvelope
   :: Diagnostic e
-  => DynFlags
+  => DiagOpts
   -> SrcSpan
   -> PrintUnqualified
   -> e
   -> MsgEnvelope e
-mkMsgEnvelope dflags locn print_unqual err
- = mk_msg_envelope (diagReasonSeverity dflags (diagnosticReason err)) locn print_unqual err
+mkMsgEnvelope opts locn print_unqual err
+ = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn print_unqual err
 
 -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location.
 -- Precondition: the diagnostic is, in fact, an error. That is,
@@ -153,12 +174,12 @@ mkErrorMsgEnvelope locn unqual msg =
 
 -- | Variant that doesn't care about qualified/unqualified names.
 mkPlainMsgEnvelope :: Diagnostic e
-                   => DynFlags
+                   => DiagOpts
                    -> SrcSpan
                    -> e
                    -> MsgEnvelope e
-mkPlainMsgEnvelope dflags locn msg =
-  mkMsgEnvelope dflags locn alwaysQualify msg
+mkPlainMsgEnvelope opts locn msg =
+  mkMsgEnvelope opts locn alwaysQualify msg
 
 -- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we
 -- are constructing a diagnostic with a 'ErrorWithoutFlag' reason.
@@ -224,14 +245,21 @@ pprLocMsgEnvelope (MsgEnvelope { errMsgSpan      = s
     withErrStyle unqual $
       mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage e)
 
-sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
-sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
-  where cmp
-          | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest
-          | otherwise                                   = SrcLoc.leftmost_smallest
-        maybeLimit = case join (fmap maxErrors dflags) of
-          Nothing        -> id
-          Just err_limit -> take err_limit
+sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
+sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList
+  where
+    cmp
+      | Just opts <- mopts
+      , diag_reverse_errors opts
+      = SrcLoc.rightmost_smallest
+      | otherwise
+      = SrcLoc.leftmost_smallest
+    maybeLimit
+      | Just opts <- mopts
+      , Just err_limit <- diag_max_errors opts
+      = take err_limit
+      | otherwise
+      = id
 
 ghcExit :: Logger -> Int -> IO ()
 ghcExit logger val
@@ -239,14 +267,6 @@ ghcExit logger val
   | otherwise = do errorMsg logger (text "\nCompilation had errors\n\n")
                    exitWith (ExitFailure val)
 
-doIfSet :: Bool -> IO () -> IO ()
-doIfSet flag action | flag      = action
-                    | otherwise = return ()
-
-doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO()
-doIfSet_dyn dflags flag action | gopt flag dflags = action
-                               | otherwise        = return ()
-
 -- -----------------------------------------------------------------------------
 -- Outputting messages from the compiler
 
@@ -259,9 +279,6 @@ fatalErrorMsg :: Logger -> SDoc -> IO ()
 fatalErrorMsg logger msg =
     logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg
 
-fatalErrorMsg'' :: FatalMessager -> String -> IO ()
-fatalErrorMsg'' fm msg = fm msg
-
 compilationProgressMsg :: Logger -> SDoc -> IO ()
 compilationProgressMsg logger msg = do
   let logflags = logFlags logger
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index fe1beacc8b..7a70d9b359 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -390,6 +390,7 @@ Library
         GHC.Driver.CodeOutput
         GHC.Driver.Config
         GHC.Driver.Config.CmmToAsm
+        GHC.Driver.Config.Diagnostic
         GHC.Driver.Config.Logger
         GHC.Driver.Config.Parser
         GHC.Driver.Env
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index afacb845de..1f5b576b6b 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -52,6 +52,7 @@ import GHC.Driver.Ppr hiding (printForUser)
 import GHC.Utils.Error hiding (traceCmd)
 import GHC.Driver.Monad ( modifySession )
 import GHC.Driver.Config.Parser (initParserOpts)
+import GHC.Driver.Config.Diagnostic
 import qualified GHC
 import GHC ( LoadHowMuch(..), Target(..),  TargetId(..),
              Resume, SingleStep, Ghc,
@@ -3072,7 +3073,7 @@ newDynFlags interactive_only minus_opts = do
       idflags0 <- GHC.getInteractiveDynFlags
       (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts
 
-      liftIO $ handleFlagWarnings logger idflags1 warns
+      liftIO $ handleFlagWarnings logger (initDiagOpts idflags1) warns
       when (not $ null leftovers)
            (throwGhcException . CmdLineError
             $ "Some flags have not been recognized: "
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 9f0dc68ec5..0dec4f6cbc 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -30,6 +30,7 @@ import GHC.Driver.MakeFile  ( doMkDependHS )
 import GHC.Driver.Backpack  ( doBackpack )
 import GHC.Driver.Plugins
 import GHC.Driver.Config.Logger (initLogFlags)
+import GHC.Driver.Config.Diagnostic
 
 import GHC.Platform
 import GHC.Platform.Ways
@@ -223,7 +224,7 @@ main' postLoadMode dflags0 args flagWarnings = do
   handleSourceError (\e -> do
        GHC.printException e
        liftIO $ exitWith (ExitFailure 1)) $ do
-         liftIO $ handleFlagWarnings logger4 dflags4 flagWarnings'
+         liftIO $ handleFlagWarnings logger4 (initDiagOpts dflags4) flagWarnings'
 
   liftIO $ showBanner postLoadMode dflags4
 
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index 60c728083f..5daf540205 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -1,4 +1,4 @@
-Found 269 Language.Haskell.Syntax module dependencies
+Found 270 Language.Haskell.Syntax module dependencies
 GHC.Builtin.Names
 GHC.Builtin.PrimOps
 GHC.Builtin.Types
@@ -83,6 +83,7 @@ GHC.Data.StringBuffer
 GHC.Data.TrieMap
 GHC.Driver.Backend
 GHC.Driver.CmdLine
+GHC.Driver.Config.Diagnostic
 GHC.Driver.Config.Logger
 GHC.Driver.Env
 GHC.Driver.Env.Types
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index 868ec3aea9..9a36c52e2d 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -1,4 +1,4 @@
-Found 275 GHC.Parser module dependencies
+Found 276 GHC.Parser module dependencies
 GHC.Builtin.Names
 GHC.Builtin.PrimOps
 GHC.Builtin.Types
@@ -84,6 +84,7 @@ GHC.Data.TrieMap
 GHC.Driver.Backend
 GHC.Driver.Backpack.Syntax
 GHC.Driver.CmdLine
+GHC.Driver.Config.Diagnostic
 GHC.Driver.Config.Logger
 GHC.Driver.Env
 GHC.Driver.Env.Types
diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
index 7c16e7f0d0..8e89a63cc6 100644
--- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
+++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs
@@ -15,6 +15,7 @@ import GHC.Utils.Error
 import GHC.Driver.Ppr
 import GHC.Driver.Env
 import GHC.Driver.Errors
+import GHC.Driver.Config.Diagnostic
 import GHC
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -49,7 +50,8 @@ main = do
       let (warnings, errors) = partitionMessages messages
       case mres of
         Nothing -> do
-          printMessages logger dflags warnings
-          printMessages logger dflags errors
+          let diag_opts = initDiagOpts dflags
+          printMessages logger diag_opts warnings
+          printMessages logger diag_opts errors
         Just (t, _) -> do
           putStrLn $ showSDoc dflags (debugPprType t)
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index 419a723062..994ecde659 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -40,6 +40,7 @@ import GHC.Unit.Module
 import GHC.Cmm.DebugBlock
 import GHC
 import GHC.Driver.Monad
+import GHC.Driver.Config.Diagnostic
 import GHC.Types.Unique.FM
 import GHC.Types.Unique.Supply
 import GHC.Driver.Session
@@ -129,7 +130,8 @@ compileCmmForRegAllocStats logger dflags cmmFile ncgImplF us = do
     (warnings, errors, parsedCmm) <- parseCmmFile dflags fake_mod (hsc_home_unit hscEnv) cmmFile
 
     -- print parser errors or warnings
-    mapM_ (printMessages logger dflags) [warnings, errors]
+    let !diag_opts = initDiagOpts dflags
+    mapM_ (printMessages logger diag_opts) [warnings, errors]
 
     let initTopSRT = emptySRT thisMod
     cmmGroup <- fmap snd $ cmmPipeline hscEnv initTopSRT $ fst $ fromJust parsedCmm
diff --git a/utils/haddock b/utils/haddock
-Subproject 0029f289bec7427032785f13cf3bcdebddf7b91
+Subproject f7059f84687a6aac37405c428a97190662de1da