diff options
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 |