summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2021-06-22 12:29:47 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-07-01 03:30:36 -0400
commit6d712150f8f9400397368b45a152a694ba9d5af4 (patch)
tree40a873281b87cc2d677f416ef0b7e87da465ebf7
parent6f097a8161dfc97be007b83fccbdb71350d786b1 (diff)
downloadhaskell-6d712150f8f9400397368b45a152a694ba9d5af4.tar.gz
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
-rw-r--r--compiler/GHC.hs23
-rw-r--r--compiler/GHC/Core/Lint.hs4
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs4
-rw-r--r--compiler/GHC/Driver/Backpack.hs3
-rw-r--r--compiler/GHC/Driver/Config/Diagnostic.hs21
-rw-r--r--compiler/GHC/Driver/Config/Parser.hs7
-rw-r--r--compiler/GHC/Driver/Env.hs4
-rw-r--r--compiler/GHC/Driver/Errors.hs25
-rw-r--r--compiler/GHC/Driver/Main.hs48
-rw-r--r--compiler/GHC/Driver/Make.hs28
-rw-r--r--compiler/GHC/Driver/Monad.hs7
-rw-r--r--compiler/GHC/Driver/Pipeline.hs7
-rw-r--r--compiler/GHC/HsToCore/Monad.hs5
-rw-r--r--compiler/GHC/Linker/Loader.hs10
-rw-r--r--compiler/GHC/Parser/Lexer.x32
-rw-r--r--compiler/GHC/Stg/Lint.hs62
-rw-r--r--compiler/GHC/Tc/Errors.hs67
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs5
-rw-r--r--compiler/GHC/Tc/Module.hs4
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs9
-rw-r--r--compiler/GHC/Utils/Error.hs107
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--ghc/GHCi/UI.hs3
-rw-r--r--ghc/Main.hs3
-rw-r--r--testsuite/tests/count-deps/CountDepsAst.stdout3
-rw-r--r--testsuite/tests/count-deps/CountDepsParser.stdout3
-rw-r--r--testsuite/tests/ghc-api/T18522-dbg-ppr.hs6
-rw-r--r--testsuite/tests/regalloc/regalloc_unit_tests.hs4
m---------utils/haddock0
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