diff options
| author | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-03-26 10:17:26 +0100 |
|---|---|---|
| committer | Alfredo Di Napoli <alfredo@well-typed.com> | 2021-03-29 07:58:00 +0200 |
| commit | c30af95189c5006ac5cd10839a8ea7e8098341d5 (patch) | |
| tree | 8863e8d15ab33363147594dbab2d54cf7cb42a48 | |
| parent | 9c9e40e59214b1e358c85852218f3a67e712a748 (diff) | |
| download | haskell-c30af95189c5006ac5cd10839a8ea7e8098341d5.tar.gz | |
Add `MessageClass`, rework `Severity` and add `DiagnosticReason`.wip/adinapoli-message-class-new-design
Other than that:
* Fix T16167,json,json2,T7478,T10637 tests to reflect the introduction of
the `MessageClass` type
* Remove `makeIntoWarning`
* Remove `warningsToMessages`
* Refactor GHC.Tc.Errors
1. Refactors GHC.Tc.Errors so that we use `DiagnosticReason` for "choices"
(defer types errors, holes, etc);
2. We get rid of `reportWarning` and `reportError` in favour of a general
`reportDiagnostic`.
* Introduce `DiagnosticReason`, `Severity` is an enum: This big commit makes
`Severity` a simple enumeration, and introduces the concept of `DiagnosticReason`,
which classifies the /reason/ why we are emitting a particular diagnostic.
It also adds a monomorphic `DiagnosticMessage` type which is used for
generic messages.
* The `Severity` is computed (for now) from the reason, statically.
Later improvement will add a `diagReasonSeverity` function to compute
the `Severity` taking `DynFlags` into account.
* Rename `logWarnings` into `logDiagnostics`
* Add note and expand description of the `mkHoleError` function
80 files changed, 975 insertions, 858 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 4054ead5f2..da1f02bea5 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -308,7 +308,8 @@ import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename import GHC.Driver.Env import GHC.Driver.Errors import GHC.Driver.CmdLine -import GHC.Driver.Session hiding (WarnReason(..)) +import GHC.Driver.Session +import qualified GHC.Driver.Session as Session import GHC.Driver.Backend import GHC.Driver.Config import GHC.Driver.Main @@ -389,6 +390,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.SourceFile +import GHC.Types.Error ( DiagnosticMessage ) import GHC.Unit import GHC.Unit.Env @@ -899,7 +901,7 @@ checkNewInteractiveDynFlags logger dflags0 = do -- the REPL. See #12356. if xopt LangExt.StaticPointers dflags0 then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag - [mkPlainWarnMsg interactiveSrcSpan + [mkPlainMsgEnvelope Session.WarningWithoutFlag interactiveSrcSpan $ text "StaticPointers is not supported in GHCi interactive expressions."] return $ xopt_unset dflags0 LangExt.StaticPointers else return dflags0 @@ -1491,7 +1493,7 @@ getNameToInstancesIndex :: GhcMonad m -- if it is visible from at least one module in the list. -> Maybe [Module] -- ^ modules to load. If this is not specified, we load -- modules for everything that is in scope unqualified. - -> m (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst]))) + -> m (Messages DiagnosticMessage, Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do hsc_env <- getSession liftIO $ runTcInteractive hsc_env $ diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 078d8492ff..116e26b3d1 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -399,7 +399,7 @@ displayLintResults :: Logger -> IO () displayLintResults logger dflags display_warnings pp_what pp_pgm (warns, errs) | not (isEmptyBag errs) - = do { putLogMsg logger dflags NoReason Err.SevDump noSrcSpan + = do { putLogMsg logger dflags Err.MCDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs , text "*** Offending Program ***" @@ -412,7 +412,7 @@ displayLintResults logger dflags display_warnings pp_what pp_pgm (warns, errs) , display_warnings -- If the Core linter encounters an error, output to stderr instead of -- stdout (#13342) - = putLogMsg logger dflags NoReason Err.SevInfo noSrcSpan + = putLogMsg logger dflags Err.MCInfo noSrcSpan $ withPprStyle defaultDumpStyle (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) @@ -2774,7 +2774,7 @@ addMsg is_error env msgs msg , isGoodSrcSpan span ] of [] -> noSrcSpan (s:_) -> s - mk_msg msg = mkLocMessage SevWarning msg_span + mk_msg msg = mkLocMessage (mkMCDiagnostic WarningWithoutFlag) msg_span (msg $$ context) addLoc :: LintLocInfo -> LintM a -> LintM a diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index e7941b82d1..8b1b94b14f 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -42,7 +42,7 @@ module GHC.Core.Opt.Monad ( getAnnotations, getFirstAnnotations, -- ** Screen output - putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, + putMsg, putMsgS, errorMsg, errorMsgS, msg, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, dumpIfSet_dyn @@ -62,10 +62,10 @@ import GHC.Types.Var import GHC.Types.Unique.Supply import GHC.Types.Name.Env import GHC.Types.SrcLoc +import GHC.Types.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger ) -import GHC.Utils.Error ( Severity(..) ) import GHC.Utils.Monad import GHC.Data.FastString @@ -791,21 +791,20 @@ we aren't using annotations heavily. ************************************************************************ -} -msg :: Severity -> WarnReason -> SDoc -> CoreM () -msg sev reason doc = do +msg :: MessageClass -> SDoc -> CoreM () +msg msg_class doc = do dflags <- getDynFlags logger <- getLogger loc <- getSrcSpanM unqual <- getPrintUnqualified - let sty = case sev of - SevError -> err_sty - SevWarning -> err_sty - SevDump -> dump_sty - _ -> user_sty + let sty = case msg_class of + MCDiagnostic _ _ -> err_sty + MCDump -> dump_sty + _ -> user_sty err_sty = mkErrStyle unqual user_sty = mkUserStyle unqual AllTheWay dump_sty = mkDumpStyle unqual - liftIO $ putLogMsg logger dflags reason sev loc (withPprStyle sty doc) + liftIO $ putLogMsg logger dflags msg_class loc (withPprStyle sty doc) -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -813,7 +812,7 @@ putMsgS = putMsg . text -- | Output a message to the screen putMsg :: SDoc -> CoreM () -putMsg = msg SevInfo NoReason +putMsg = msg MCInfo -- | Output an error to the screen. Does not cause the compiler to die. errorMsgS :: String -> CoreM () @@ -821,10 +820,7 @@ errorMsgS = errorMsg . text -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () -errorMsg = msg SevError NoReason - -warnMsg :: WarnReason -> SDoc -> CoreM () -warnMsg = msg SevWarning +errorMsg = msg (mkMCDiagnostic ErrorWithoutFlag) -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsgS :: String -> CoreM () @@ -832,7 +828,7 @@ fatalErrorMsgS = fatalErrorMsg . text -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsg :: SDoc -> CoreM () -fatalErrorMsg = msg SevFatal NoReason +fatalErrorMsg = msg MCFatal -- | Output a string debugging message at verbosity level of @-v@ or higher debugTraceMsgS :: String -> CoreM () @@ -840,7 +836,7 @@ debugTraceMsgS = debugTraceMsg . text -- | Outputs a debugging message at verbosity level of @-v@ or higher debugTraceMsg :: SDoc -> CoreM () -debugTraceMsg = msg SevDump NoReason +debugTraceMsg = msg MCDump -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM () diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 2334436d69..f81f45eba2 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -560,7 +560,7 @@ ruleCheckPass current_phase pat guts = do let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn ++ (mg_rules guts) let ropts = initRuleOpts dflags - liftIO $ putLogMsg logger dflags NoReason Err.SevDump noSrcSpan + liftIO $ putLogMsg logger dflags Err.MCDump noSrcSpan $ withPprStyle defaultDumpStyle (ruleCheckProgram ropts current_phase pat rule_fn (mg_binds guts)) diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index cab33d8de7..5caae8bf77 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -53,6 +53,7 @@ import GHC.Types.Var ( isLocalVar ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id +import GHC.Types.Error import GHC.Utils.Monad ( foldlM ) import GHC.Utils.Misc @@ -802,13 +803,13 @@ tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () tryWarnMissingSpecs dflags callers fn calls_for_fn | wopt Opt_WarnMissedSpecs dflags && not (null callers) - && allCallersInlined = doWarn $ Reason Opt_WarnMissedSpecs - | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ Reason Opt_WarnAllMissedSpecs + && allCallersInlined = doWarn $ WarningWithFlag Opt_WarnMissedSpecs + | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs | otherwise = return () where allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers doWarn reason = - warnMsg reason + msg (mkMCDiagnostic 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 a174a5be95..d18fedfdfa 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -799,7 +799,8 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing Nothing -- GHC API buffer support not supported [] -- No exclusions case r of - Nothing -> throwOneError (mkPlainMsgEnvelope loc (text "module" <+> ppr modname <+> text "was not found")) + Nothing -> throwOneError (mkPlainMsgEnvelope ErrorWithoutFlag + loc (text "module" <+> ppr modname <+> text "was not found")) Just (Left err) -> throwErrors err Just (Right summary) -> return summary diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 8c990b16cb..60513c9b82 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -100,8 +100,7 @@ codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStu { case cmmLint (targetPlatform dflags) cmm of Just err -> do { putLogMsg logger dflags - NoReason - SevDump + MCDump noSrcSpan $ withPprStyle defaultDumpStyle err ; ghcExit logger dflags 1 diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index d779fc06f8..9127e7d094 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -1,9 +1,8 @@ module GHC.Driver.Errors ( - warningsToMessages - , printOrThrowWarnings + printOrThrowWarnings , printBagOfErrors - , isWarnMsgFatal , handleFlagWarnings + , partitionMessageBag ) where import GHC.Driver.Session @@ -18,27 +17,20 @@ import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle ) import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine --- | Converts a list of 'WarningMessages' into a tuple where the second element contains only --- error, i.e. warnings that are considered fatal by GHC based on the input 'DynFlags'. -warningsToMessages :: DynFlags -> WarningMessages -> (WarningMessages, ErrorMessages) -warningsToMessages dflags = - partitionBagWith $ \warn -> - case isWarnMsgFatal dflags warn of - Nothing -> Left warn - Just err_reason -> - Right warn{ errMsgSeverity = SevError - , errMsgReason = ErrReason err_reason } +-- | Partitions the messages and returns a tuple which first element are the warnings, and the +-- second the errors. +partitionMessageBag :: Diagnostic e => Bag (MsgEnvelope e) -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) +partitionMessageBag = partitionBag isWarningMessage -printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO () +printBagOfErrors :: Diagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO () printBagOfErrors logger dflags bag_of_errors = sequence_ [ let style = mkErrStyle unqual ctx = initSDocContext dflags style - in putLogMsg logger dflags reason sev s $ - withPprStyle style (formatBulleted ctx (renderDiagnostic doc)) + in putLogMsg logger dflags (MCDiagnostic sev . diagnosticReason $ dia) s $ + withPprStyle style (formatBulleted ctx (diagnosticMessage dia)) | MsgEnvelope { errMsgSpan = s, - errMsgDiagnostic = doc, - errMsgSeverity = sev, - errMsgReason = reason, + errMsgDiagnostic = dia, + errMsgSeverity = sev, errMsgContext = unqual } <- sortMsgBag (Just dflags) bag_of_errors ] @@ -48,22 +40,11 @@ handleFlagWarnings logger dflags warns = do -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems. - bag = listToBag [ mkPlainWarnMsg loc (text warn) + bag = listToBag [ mkPlainMsgEnvelope WarningWithoutFlag loc (text warn) | CmdLine.Warn _ (L loc warn) <- warns' ] printOrThrowWarnings logger dflags bag --- | Checks if given 'WarnMsg' is a fatal warning. -isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) -isWarnMsgFatal dflags MsgEnvelope{errMsgReason = Reason wflag} - = if wopt_fatal wflag dflags - then Just (Just wflag) - else Nothing -isWarnMsgFatal dflags _ - = if gopt Opt_WarnIsError dflags - then Just Nothing - else Nothing - -- Given a warn reason, check to see if it's associated -W opt is enabled shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag @@ -80,14 +61,33 @@ printOrThrowWarnings logger dflags warns = do let (make_error, warns') = mapAccumBagL (\make_err warn -> - case isWarnMsgFatal dflags warn of - Nothing -> + case warn_msg_severity dflags warn of + SevWarning -> (make_err, warn) - Just err_reason -> - (True, warn{ errMsgSeverity = SevError - , errMsgReason = ErrReason err_reason - })) + SevError -> + (True, set_severity SevError warn)) False warns if make_error then throwIO (mkSrcErr warns') else printBagOfErrors logger dflags warns + + where + + -- | Sets the 'Severity' of the input 'WarnMsg' according to the 'DynFlags'. + warn_msg_severity :: DynFlags -> WarnMsg -> Severity + warn_msg_severity dflags msg = + case diagnosticReason (errMsgDiagnostic msg) of + ErrorWithoutFlag -> SevError + WarningWithoutFlag -> + if gopt Opt_WarnIsError dflags + then SevError + else SevWarning + WarningWithFlag wflag -> + if wopt_fatal wflag dflags + then SevError + else SevWarning + + -- | Adjust the 'Severity' of the input 'WarnMsg'. + set_severity :: Severity -> WarnMsg -> MsgEnvelope DiagnosticMessage + set_severity newSeverity msg = msg { errMsgSeverity = newSeverity } + diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index b6d20ada3a..393927e1b2 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -2,7 +2,6 @@ module GHC.Driver.Flags ( DumpFlag(..) , GeneralFlag(..) , WarningFlag(..) - , WarnReason (..) , Language(..) , optimisationFlags ) @@ -11,7 +10,6 @@ where import GHC.Prelude import GHC.Utils.Outputable import GHC.Data.EnumSet as EnumSet -import GHC.Utils.Json -- | Debugging flags data DumpFlag @@ -514,27 +512,6 @@ data WarningFlag = | Opt_WarnMissingKindSignatures -- Since 9.2 deriving (Eq, Show, Enum) --- | Used when outputting warnings: if a reason is given, it is --- displayed. If a warning isn't controlled by a flag, this is made --- explicit at the point of use. -data WarnReason - = NoReason - -- | Warning was enabled with the flag - | Reason !WarningFlag - -- | Warning was made an error because of -Werror or -Werror=WarningFlag - | ErrReason !(Maybe WarningFlag) - deriving Show - -instance Outputable WarnReason where - ppr = text . show - -instance ToJson WarnReason where - json NoReason = JSNull - json (Reason wf) = JSString (show wf) - json (ErrReason Nothing) = JSString "Opt_WarnIsError" - json (ErrReason (Just wf)) = JSString (show wf) - - data Language = Haskell98 | Haskell2010 | GHC2021 deriving (Eq, Enum, Show, Bounded) diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 92d8034127..9329e96d19 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -277,8 +277,8 @@ getWarnings = Hsc $ \_ w -> return (w, w) clearWarnings :: Hsc () clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) -logWarnings :: WarningMessages -> Hsc () -logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) +logDiagnostics :: Bag (MsgEnvelope DiagnosticMessage) -> Hsc () +logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) getHscEnv :: Hsc HscEnv getHscEnv = Hsc $ \e w -> return (e, w) @@ -297,7 +297,7 @@ logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc () logWarningsReportErrors (warnings,errors) = do let warns = fmap pprWarning warnings errs = fmap pprError errors - logWarnings warns + logDiagnostics warns when (not $ isEmptyBag errs) $ throwErrors errs -- | Log warnings and throw errors, assuming the messages @@ -306,10 +306,10 @@ handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do let warns = fmap pprWarning warnings errs = fmap pprError errors - logWarnings warns + logDiagnostics warns dflags <- getDynFlags logger <- getLogger - (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings + let (wWarns, wErrs) = partitionMessageBag warns liftIO $ printBagOfErrors logger dflags wWarns throwErrors (unionBags errs wErrs) @@ -329,21 +329,21 @@ handleWarningsThrowErrors (warnings, errors) = do -- 2. If there are no error messages, but the second result indicates failure -- there should be warnings in the first result. That is, if the action -- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc a +ioMsgMaybe :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc a ioMsgMaybe ioA = do (msgs, mb_r) <- liftIO ioA let (warns, errs) = partitionMessages msgs - logWarnings warns + logDiagnostics warns case mb_r of Nothing -> throwErrors errs Just r -> ASSERT( isEmptyBag errs ) return r -- | like ioMsgMaybe, except that we ignore error messages and return -- 'Nothing' instead. -ioMsgMaybe' :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc (Maybe a) ioMsgMaybe' ioA = do (msgs, mb_r) <- liftIO $ ioA - logWarnings (getWarningMessages msgs) + logDiagnostics (getWarningMessages msgs) return mb_r -- ----------------------------------------------------------------------------- @@ -423,7 +423,7 @@ hscParse' mod_summary handleWarningsThrowErrors (getMessages pst) POk pst rdr_module -> do let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst) - logWarnings warns + logDiagnostics warns liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" @@ -565,12 +565,12 @@ tcRnModule' sum save_rn_syntax mod = do hsc_env <- getHscEnv dflags <- getDynFlags + let reason = WarningWithFlag Opt_WarnMissingSafeHaskellMode -- -Wmissing-safe-haskell-mode when (not (safeHaskellModeEnabled dflags) && wopt Opt_WarnMissingSafeHaskellMode dflags) $ - logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $ - mkPlainWarnMsg (getLoc (hpm_module mod)) $ + logDiagnostics $ unitBag $ + mkPlainMsgEnvelope reason (getLoc (hpm_module mod)) $ warnMissingSafeHaskellMode tcg_res <- {-# SCC "Typecheck-Rename" #-} @@ -597,15 +597,15 @@ tcRnModule' sum save_rn_syntax mod = do case wopt Opt_WarnSafe dflags of True | safeHaskell dflags == Sf_Safe -> return () - | otherwise -> (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnSafe) $ - mkPlainWarnMsg (warnSafeOnLoc dflags) $ + | otherwise -> (logDiagnostics $ unitBag $ + mkPlainMsgEnvelope (WarningWithFlag Opt_WarnSafe) + (warnSafeOnLoc dflags) $ errSafe tcg_res') False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags -> - (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ - mkPlainWarnMsg (trustworthyOnLoc dflags) $ + (logDiagnostics $ unitBag $ + mkPlainMsgEnvelope (WarningWithFlag Opt_WarnTrustworthySafe) + (trustworthyOnLoc dflags) $ errTwthySafe tcg_res') False -> return () return tcg_res' @@ -1136,7 +1136,7 @@ hscCheckSafeImports tcg_env = do case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES - logWarnings $ warns (tcg_rules tcg_env') + logDiagnostics $ warns (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False -- SafeInferred: user defined RULES, so not safe @@ -1149,9 +1149,9 @@ hscCheckSafeImports tcg_env = do warns rules = listToBag $ map warnRules rules - warnRules :: LRuleDecl GhcTc -> MsgEnvelope DecoratedSDoc + warnRules :: LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage warnRules (L loc (HsRule { rd_name = n })) = - mkPlainWarnMsg (locA loc) $ + mkPlainMsgEnvelope WarningWithoutFlag (locA loc) $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -1195,7 +1195,7 @@ checkSafeImports tcg_env return (infErrs, infPkgs) -- restore old errors - logWarnings oldErrs + logDiagnostics oldErrs case (isEmptyBag safeErrs) of -- Failed safe check @@ -1227,7 +1227,7 @@ checkSafeImports tcg_env cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2 - = throwOneError $ mkPlainMsgEnvelope (imv_span v1) + = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag (imv_span v1) (text "Module" <+> ppr (imv_name v1) <+> (text $ "is imported both as a safe and unsafe import!")) | otherwise @@ -1295,7 +1295,7 @@ hscCheckSafe' m l = do iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwOneError $ mkPlainMsgEnvelope l + Nothing -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag l $ text "Can't load the interface file for" <+> ppr m <> text ", to check that it can be safely imported" @@ -1321,28 +1321,28 @@ hscCheckSafe' m l = do (True, False) -> pkgTrustErr (False, _ ) -> modTrustErr in do - logWarnings warns - logWarnings errs + logDiagnostics warns + logDiagnostics errs return (trust == Sf_Trustworthy, pkgRs) where state = hsc_units hsc_env inferredImportWarn = unitBag - $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) - $ mkWarnMsg l (pkgQual state) + $ mkShortMsgEnvelope (WarningWithFlag Opt_WarnInferredSafeImports) + l (pkgQual state) $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) <> text " from explicitly Safe module" ] - pkgTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $ + pkgTrustErr = unitBag $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The package (" <> (pprWithUnitState state $ ppr (moduleUnit m)) <> text ") the module resides in isn't trusted." ] - modTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $ + modTrustErr = unitBag $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1388,7 +1388,7 @@ checkPkgTrust pkgs = do | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise - = (:acc) $ mkMsgEnvelope noSrcSpan (pkgQual state) + = (:acc) $ mkShortMsgEnvelope ErrorWithoutFlag noSrcSpan (pkgQual state) $ pprWithUnitState state $ text "The package (" <> ppr pkg @@ -1411,9 +1411,10 @@ markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv markUnsafeInfer tcg_env whyUnsafe = do dflags <- getDynFlags + let reason = WarningWithFlag Opt_WarnUnsafe when (wopt Opt_WarnUnsafe dflags) - (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $ - mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) + (logDiagnostics $ unitBag $ + mkPlainMsgEnvelope reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other @@ -1434,7 +1435,7 @@ markUnsafeInfer tcg_env whyUnsafe = do ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer badFlag df (str,loc,on,_) - | on df = [mkLocMessage SevOutput (loc df) $ + | on df = [mkLocMessage MCOutput (loc df) $ text str <+> text "is not allowed in Safe Haskell"] | otherwise = [] badInsts insts = concatMap badInst insts @@ -1443,7 +1444,7 @@ markUnsafeInfer tcg_env whyUnsafe = do checkOverlap _ = True badInst ins | checkOverlap (overlapMode (is_flag ins)) - = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $ + = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $ ppr (overlapMode $ is_flag ins) <+> text "overlap mode isn't allowed in Safe Haskell"] | otherwise = [] @@ -2006,7 +2007,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do case is of [L _ i] -> return i _ -> liftIO $ throwOneError $ - mkPlainMsgEnvelope noSrcSpan $ + mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -2035,7 +2036,7 @@ hscParseExpr expr = do maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ mkPlainMsgEnvelope noSrcSpan + _ -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan (text "not an expression:" <+> quotes (text expr)) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 720df3e2c8..a83597deb1 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -87,6 +87,7 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Types.Basic +import GHC.Types.Error import GHC.Types.Target import GHC.Types.SourceFile import GHC.Types.SourceError @@ -317,9 +318,8 @@ warnMissingHomeModules hsc_env mod_graph = (text "Modules are not listed in command line but needed for compilation: ") 4 (sep (map ppr missing)) - warn = makeIntoWarning - (Reason Opt_WarnMissingHomeModules) - (mkPlainMsgEnvelope noSrcSpan msg) + warn = + mkPlainMsgEnvelope (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch @@ -384,9 +384,8 @@ warnUnusedPackages = do = filter (\arg -> not $ any (matching state arg) loadedPackages) requestedArgs - let warn = makeIntoWarning - (Reason Opt_WarnUnusedPackages) - (mkPlainMsgEnvelope noSrcSpan msg) + let warn = + mkPlainMsgEnvelope (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," , text "but were not needed for compilation:" @@ -1000,7 +999,7 @@ checkStability hpt sccs all_home_mods = -- | Each module is given a unique 'LogQueue' to redirect compilation messages -- to. A 'Nothing' value contains the result of compilation, and denotes the -- end of the message queue. -data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]) +data LogQueue = LogQueue !(IORef [Maybe (MessageClass, SrcSpan, SDoc)]) !(MVar ()) -- | The graph of modules to compile and their corresponding result 'MVar' and @@ -1254,7 +1253,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do return (success_flag,ok_results) where - writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,SDoc) -> IO () + writeLogQueue :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc) -> IO () writeLogQueue (LogQueue ref sem) msg = do atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) _ <- tryPutMVar sem () @@ -1263,8 +1262,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do -- The log_action callback that is used to synchronize messages from a -- worker thread. parLogAction :: LogQueue -> LogAction - parLogAction log_queue _dflags !reason !severity !srcSpan !msg = - writeLogQueue log_queue (Just (reason,severity,srcSpan,msg)) + parLogAction log_queue _dflags !msgClass !srcSpan !msg = + writeLogQueue log_queue (Just (msgClass,srcSpan,msg)) -- Print each message from the log_queue using the log_action from the -- session's DynFlags. @@ -1277,8 +1276,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do print_loop [] = read_msgs print_loop (x:xs) = case x of - Just (reason,severity,srcSpan,msg) -> do - putLogMsg logger dflags reason severity srcSpan msg + Just (msgClass,srcSpan,msg) -> do + putLogMsg logger dflags msgClass srcSpan msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () @@ -2222,8 +2221,8 @@ warnUnnecessarySourceImports sccs = do warn :: Located ModuleName -> WarnMsg warn (L loc mod) = - mkPlainMsgEnvelope loc - (text "Warning: {-# SOURCE #-} unnecessary in import of " + mkPlainMsgEnvelope WarningWithoutFlag loc + (text "{-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)) @@ -2295,7 +2294,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots if exists || isJust maybe_buf then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else return $ Left $ unitBag $ mkPlainMsgEnvelope noSrcSpan $ + else return $ Left $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $ text "can't find file:" <+> text file getRootSummary Target { targetId = TargetModule modl , targetAllowObjCode = obj_allowed @@ -2730,7 +2729,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $ - throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $ + throwE $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag pi_mod_name_loc $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) @@ -2742,7 +2741,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : homeUnitInstantiations home_unit) ]) - in throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $ + in throwE $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag pi_mod_name_loc $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) $$ if gopt Opt_BuildingCabalPackage dflags then parens (text "Try adding" <+> quotes (ppr pi_mod_name) @@ -2876,12 +2875,15 @@ withDeferredDiagnostics f = do fatals <- liftIO $ newIORef [] logger <- getLogger - let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do - let action = putLogMsg logger dflags reason severity srcSpan msg - case severity of - SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ()) - SevError -> atomicModifyIORef' errors $ \i -> (action: i, ()) - SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ()) + let deferDiagnostics _dflags !msgClass !srcSpan !msg = do + let action = putLogMsg logger dflags msgClass srcSpan msg + case msgClass of + MCDiagnostic SevWarning _reason + -> atomicModifyIORef' warnings $ \i -> (action: i, ()) + MCDiagnostic SevError _reason + -> atomicModifyIORef' errors $ \i -> (action: i, ()) + MCFatal + -> atomicModifyIORef' fatals $ \i -> (action: i, ()) _ -> action printDeferredDiagnostics = liftIO $ @@ -2896,24 +2898,24 @@ withDeferredDiagnostics f = do (\_ -> popLogHookM >> printDeferredDiagnostics) (\_ -> f) -noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc +noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DiagnosticMessage -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err + = mkPlainMsgEnvelope ErrorWithoutFlag loc $ cannotFindModule hsc_env wanted_mod err noHsFileErr :: SrcSpan -> String -> ErrorMessages noHsFileErr loc path - = unitBag $ mkPlainMsgEnvelope loc $ text "Can't find" <+> text path + = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag loc $ text "Can't find" <+> text path moduleNotFoundErr :: ModuleName -> ErrorMessages moduleNotFoundErr mod - = unitBag $ mkPlainMsgEnvelope noSrcSpan $ + = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainMsgEnvelope noSrcSpan $ + = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index d018c26ecf..9324755d3d 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -305,7 +305,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do -> return Nothing fail -> - throwOneError $ mkPlainMsgEnvelope srcloc $ + throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag srcloc $ cannotFindModule hsc_env imp fail ----------------------------- diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index 2a4c2c04d6..39ccdc7c21 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -127,11 +127,11 @@ putMsgM doc = do liftIO $ putMsg logger dflags doc -- | Put a log message -putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m () -putLogMsgM reason sev loc doc = do +putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m () +putLogMsgM msg_class loc doc = do dflags <- getDynFlags logger <- getLogger - liftIO $ putLogMsg logger dflags reason sev loc doc + liftIO $ putLogMsg logger dflags msg_class loc doc -- | Time an action withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 67fd78d7fa..fc6fe68281 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -151,7 +151,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 handler (ProgramError msg) = return $ Left $ unitBag $ - mkPlainMsgEnvelope srcspan $ text msg + mkPlainMsgEnvelope ErrorWithoutFlag srcspan $ text msg handler ex = throwGhcExceptionIO ex -- --------------------------------------------------------------------------- @@ -1859,7 +1859,7 @@ getHCFilePackages filename = linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do when (haveRtsOptsFlags dflags) $ - putLogMsg logger dflags NoReason SevInfo noSrcSpan + putLogMsg logger dflags MCInfo noSrcSpan $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index aea644aac8..ff84dbfc65 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -21,7 +21,7 @@ module GHC.Driver.Session ( -- * Dynamic flags and associated configuration types DumpFlag(..), GeneralFlag(..), - WarningFlag(..), WarnReason(..), + WarningFlag(..), DiagnosticReason(..), Language(..), PlatformConstants(..), FatalMessager, FlushOut(..), FlushErr(..), @@ -234,7 +234,7 @@ import GHC.Driver.Backend import GHC.Settings.Config import GHC.Utils.CliOption import {-# SOURCE #-} GHC.Core.Unfold -import GHC.Driver.CmdLine hiding (WarnReason(..)) +import GHC.Driver.CmdLine import qualified GHC.Driver.CmdLine as Cmd import GHC.Settings.Constants import GHC.Utils.Panic @@ -243,6 +243,7 @@ import GHC.Utils.Misc import GHC.Utils.GlobalVars import GHC.Data.Maybe import GHC.Utils.Monad +import GHC.Types.Error (DiagnosticReason(..)) import GHC.Types.SrcLoc import GHC.Types.SafeHaskell import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index c95595a458..c9dacae70d 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -82,6 +82,7 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.HpcInfo +import GHC.Types.Error import GHC.Unit import GHC.Unit.Module.ModGuts @@ -101,7 +102,7 @@ import GHC.Driver.Plugins ( LoadedPlugin(..) ) -} -- | Main entry point to the desugarer. -deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DecoratedSDoc, Maybe ModGuts) +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DiagnosticMessage, Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env @@ -285,7 +286,7 @@ So we pull out the type/coercion variables (which are in dependency order), and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DecoratedSDoc, Maybe CoreExpr) +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DiagnosticMessage, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env @@ -419,7 +420,7 @@ dsRule (L loc (HsRule { rd_name = name -- and take the body apart into a (f args) form ; dflags <- getDynFlags ; case decomposeRuleLhs dflags bndrs'' lhs'' of { - Left msg -> do { warnDs NoReason msg; return Nothing } ; + Left msg -> do { diagnosticDs WarningWithoutFlag msg; return Nothing } ; Right (final_bndrs, fn_id, args) -> do { let is_local = isLocalId fn_id @@ -455,25 +456,25 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) -- If imported with no unfolding, no worries , idInlineActivation lhs_id `competesWith` rule_act - = warnDs (Reason Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because" <+> quotes (ppr lhs_id) - <+> text "might inline first") - , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" - <+> quotes (ppr lhs_id) - , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) + = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing) + (vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because" <+> quotes (ppr lhs_id) + <+> text "might inline first") + , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" + <+> quotes (ppr lhs_id) + , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) | check_rules_too , bad_rule : _ <- get_bad_rules lhs_id - = warnDs (Reason Opt_WarnInlineRuleShadowing) - (vcat [ hang (text "Rule" <+> pprRuleName rule_name - <+> text "may never fire") - 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) - <+> text "for"<+> quotes (ppr lhs_id) - <+> text "might fire first") - , text "Probable fix: add phase [n] or [~n] to the competing rule" - , whenPprDebug (ppr bad_rule) ]) + = diagnosticDs (WarningWithFlag Opt_WarnInlineRuleShadowing) + (vcat [ hang (text "Rule" <+> pprRuleName rule_name + <+> text "may never fire") + 2 (text "because rule" <+> pprRuleName (ruleName bad_rule) + <+> text "for"<+> quotes (ppr lhs_id) + <+> text "might fire first") + , text "Probable fix: add phase [n] or [~n] to the competing rule" + , whenPprDebug (ppr bad_rule) ]) | otherwise = return () diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 64114b513f..928db49ddc 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -665,16 +665,16 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | isJust (isClassOpId_maybe poly_id) = putSrcSpanDs loc $ - do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector" - <+> quotes (ppr poly_id)) + do { diagnosticDs WarningWithoutFlag (text "Ignoring useless SPECIALISE pragma for class method selector" + <+> quotes (ppr poly_id)) ; return Nothing } -- There is no point in trying to specialise a class op -- Moreover, classops don't (currently) have an inl_sat arity set -- (it would be Just 0) and that in turn makes makeCorePair bleat | no_act_spec && isNeverActive rule_act = putSrcSpanDs loc $ - do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" - <+> quotes (ppr poly_id)) + do { diagnosticDs WarningWithoutFlag (text "Ignoring useless SPECIALISE pragma for NOINLINE function:" + <+> quotes (ppr poly_id)) ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that -- See Note [Activation pragmas for SPECIALISE] @@ -699,7 +699,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ dflags <- getDynFlags ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { - Left msg -> do { warnDs NoReason msg; return Nothing } ; + Left msg -> do { diagnosticDs WarningWithoutFlag msg; return Nothing } ; Right (rule_bndrs, _fn, rule_lhs_args) -> do { this_mod <- getModule @@ -720,7 +720,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) -- Commented out: see Note [SPECIALISE on INLINE functions] -- ; when (isInlinePragma id_inl) --- (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" +-- (diagnosticDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" -- <+> quotes (ppr poly_name)) ; return (Just (unitOL (spec_id, spec_rhs), rule)) @@ -769,7 +769,7 @@ dsMkUserRule this_mod is_local name act fn bndrs args rhs = do let rule = mkRule this_mod False is_local name act fn bndrs args rhs dflags <- getDynFlags when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $ - warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule) + diagnosticDs (WarningWithFlag Opt_WarnOrphans) (ruleOrphWarn rule) return rule ruleOrphWarn :: CoreRule -> SDoc diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index cdbf54889e..37d72fa213 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -1077,8 +1077,8 @@ warnDiscardedDoBindings rhs rhs_ty -- Warn about discarding non-() things in 'monadic' binding ; if warn_unused && not (isUnitTy norm_elt_ty) - then warnDs (Reason Opt_WarnUnusedDoBind) - (badMonadBind rhs elt_ty) + then diagnosticDs (WarningWithFlag Opt_WarnUnusedDoBind) + (badMonadBind rhs elt_ty) else -- Warn about discarding m a things in 'monadic' binding of the same type, @@ -1087,8 +1087,8 @@ warnDiscardedDoBindings rhs rhs_ty case tcSplitAppTy_maybe norm_elt_ty of Just (elt_m_ty, _) | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty - -> warnDs (Reason Opt_WarnWrongDoBind) - (badMonadBind rhs elt_ty) + -> diagnosticDs (WarningWithFlag Opt_WarnWrongDoBind) + (badMonadBind rhs elt_ty) _ -> return () } } | otherwise -- RHS does have type of form (m ty), which is weird diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index c6eb0b5fb8..d3b2776d93 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -248,7 +248,7 @@ match (v:vs) ty eqns -- Eqns *can* be empty case p of PgView e _ -> e:acc _ -> acc) [] group) eqns maybeWarn [] = return () - maybeWarn l = warnDs NoReason (vcat l) + maybeWarn l = diagnosticDs WarningWithoutFlag (vcat l) in maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) (filter (not . null) gs)) diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index fd4be02b1c..16c0d6c2c6 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -264,10 +264,10 @@ warnAboutIdentities dflags conv_fn type_of_conv , idName conv_fn `elem` conversionNames , Just (_, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv , arg_ty `eqType` res_ty -- So we are converting ty -> ty - = warnDs (Reason Opt_WarnIdentities) - (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv - , nest 2 $ text "can probably be omitted" - ]) + = diagnosticDs (WarningWithFlag Opt_WarnIdentities) + (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv + , nest 2 $ text "can probably be omitted" + ]) warnAboutIdentities _ _ _ = return () conversionNames :: [Name] @@ -348,19 +348,19 @@ warnAboutOverflowedLiterals dflags lit checkPositive :: Integer -> Name -> DsM () checkPositive i tc = when (i < 0) $ - warnDs (Reason Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is negative but" <+> ppr tc - <+> ptext (sLit "only supports positive numbers") - ]) + diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) + (vcat [ text "Literal" <+> integer i + <+> text "is negative but" <+> ppr tc + <+> ptext (sLit "only supports positive numbers") + ]) check i tc minB maxB = when (i < minB || i > maxB) $ - warnDs (Reason Opt_WarnOverflowedLiterals) - (vcat [ text "Literal" <+> integer i - <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") - <+> integer minB <> text ".." <> integer maxB - , sug ]) + diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) + (vcat [ text "Literal" <+> integer i + <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range") + <+> integer minB <> text ".." <> integer maxB + , sug ]) where sug | minB == -i -- Note [Suggest NegativeLiterals] , i > 0 @@ -441,7 +441,8 @@ warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr | otherwise = return () where - raiseWarning = warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty") + raiseWarning = + diagnosticDs (WarningWithFlag Opt_WarnEmptyEnumerations) (text "Enumeration is empty") getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal. diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index a73e40cba2..f5be46006a 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -40,7 +40,7 @@ module GHC.HsToCore.Monad ( dsGetCompleteMatches, -- Warnings and errors - DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, + DsWarning, diagnosticDs, warnIfSetDs, errDs, errDsCoreExpr, failWithDs, failDs, discardWarningsDs, askNoErrsDs, @@ -214,7 +214,7 @@ initDsTc thing_inside } -- | Run a 'DsM' action inside the 'IO' monad. -initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a) +initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) initDs hsc_env tcg_env thing_inside = do { msg_var <- newIORef emptyMessages ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env @@ -223,7 +223,7 @@ initDs hsc_env tcg_env thing_inside -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m - => HscEnv -> IORef (Messages DecoratedSDoc) -> TcGblEnv + => HscEnv -> IORef (Messages DiagnosticMessage) -> TcGblEnv -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { cc_st_var <- liftIO $ newIORef newCostCentreState @@ -240,7 +240,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env msg_var cc_st_var complete_matches } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DecoratedSDoc, Maybe a) +runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl (tryM thing_inside) @@ -253,7 +253,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside } -- | Run a 'DsM' action in the context of an existing 'ModGuts' -initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, Maybe a) +initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds , mg_tcs = tycons, mg_fam_insts = fam_insts , mg_patsyns = patsyns, mg_rdr_env = rdr_env @@ -313,7 +313,7 @@ initTcDsForSolver thing_inside Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef (Messages DecoratedSDoc) -> IORef CostCentreState -> CompleteMatches + -> IORef (Messages DiagnosticMessage) -> IORef CostCentreState -> CompleteMatches -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches @@ -454,27 +454,26 @@ putSrcSpanDs (RealSrcSpan real_span _) thing_inside putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a putSrcSpanDsA loc = putSrcSpanDs (locA loc) --- | Emit a warning for the current source location +-- | Emit a diagnostic for the current source location -- NB: Warns whether or not -Wxyz is set -warnDs :: WarnReason -> SDoc -> DsM () -warnDs reason warn +diagnosticDs :: DiagnosticReason -> SDoc -> DsM () +diagnosticDs reason warn = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = makeIntoWarning reason $ - mkWarnMsg loc (ds_unqual env) warn + ; let msg = mkShortMsgEnvelope reason loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } --- | Emit a warning only if the correct WarnReason is set in the DynFlags +-- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags warnIfSetDs :: WarningFlag -> SDoc -> DsM () warnIfSetDs flag warn = whenWOptM flag $ - warnDs (Reason flag) warn + diagnosticDs (WarningWithFlag flag) warn errDs :: SDoc -> DsM () errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkMsgEnvelope loc (ds_unqual env) err + ; let msg = mkShortMsgEnvelope ErrorWithoutFlag loc (ds_unqual env) err ; 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/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs index 3292372e6e..a66a54df36 100644 --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -347,26 +347,26 @@ reportWarnings dflags ctx@(DsMatchContext kind loc) vars approx = precision == Approximate when (approx && (exists_u || exists_i)) $ - putSrcSpanDs loc (warnDs NoReason approx_msg) + putSrcSpanDs loc (diagnosticDs WarningWithoutFlag approx_msg) when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) -> - putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns) - (pprEqn q "has redundant bang")) + putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnRedundantBangPatterns) + (pprEqn q "has redundant bang")) when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) -> - putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) - (pprEqn q "is redundant")) + putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnOverlappingPatterns) + (pprEqn q "is redundant")) when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) -> - putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) - (pprEqn q "has inaccessible right hand side")) + putSrcSpanDs l (diagnosticDs (WarningWithFlag Opt_WarnOverlappingPatterns) + (pprEqn q "has inaccessible right hand side")) - when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $ + when exists_u $ putSrcSpanDs loc $ diagnosticDs flag_u_reason $ pprEqns vars unc_examples where flag_i = overlapping dflags kind flag_u = exhaustive dflags kind flag_b = redundantBang dflags - flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind) + flag_u_reason = maybe WarningWithoutFlag WarningWithFlag (exhaustiveWarningFlag kind) maxPatterns = maxUncoveredPatterns dflags diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs index 60417e48a9..aa3e097c0d 100644 --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -9,6 +9,7 @@ module GHC.HsToCore.Types ( import Data.IORef import GHC.Types.CostCentre.State +import GHC.Types.Error import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Var @@ -18,7 +19,6 @@ import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches) import GHC.HsToCore.Pmc.Types (Nablas) import GHC.Core (CoreExpr) import GHC.Core.FamInstEnv -import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Unit.Module import GHC.Driver.Hooks (DsForeignsHook) @@ -47,7 +47,7 @@ data DsGblEnv -- constructors are in scope during -- pattern-match satisfiability checking , ds_unqual :: PrintUnqualified - , ds_msgs :: IORef (Messages DecoratedSDoc) -- Warning messages + , ds_msgs :: IORef (Messages DiagnosticMessage) -- Diagnostic messages , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things , ds_complete_matches :: CompleteMatches diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 534af94d28..10033ad2ce 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -1087,7 +1087,7 @@ For some background on this choice see trac #15269. showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO () showIface logger dflags unit_state name_cache filename = do let profile = targetProfile dflags - printer = putLogMsg logger dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle + printer = putLogMsg logger dflags MCOutput noSrcSpan . withPprStyle defaultDumpStyle -- skip the hi way check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. @@ -1100,7 +1100,7 @@ showIface logger dflags unit_state name_cache filename = do print_unqual = QueryQualify qualifyImportedNames neverQualifyModules neverQualifyPackages - putLogMsg logger dflags NoReason SevDump noSrcSpan + putLogMsg logger dflags MCDump noSrcSpan $ withPprStyle (mkDumpStyle print_unqual) $ pprModIface unit_state iface diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 03c70845ea..beb7aadbbb 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -76,7 +76,7 @@ failWithRn doc = do errs_var <- fmap sh_if_errs getGblEnv errs <- readTcRef errs_var -- TODO: maybe associate this with a source location? - writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope noSrcSpan doc) + writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan doc) failM -- | What we have is a generalized ModIface, which corresponds to diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 15e31a37cc..86fff45160 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -429,7 +429,7 @@ classifyLdInput logger dflags f | isObjectFilename platform f = return (Just (Objects [f])) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do - putLogMsg logger dflags NoReason SevInfo noSrcSpan + putLogMsg logger dflags MCInfo noSrcSpan $ withPprStyle defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing @@ -583,7 +583,7 @@ loadExpr interp hsc_env span root_ul_bco = do -- by default, so we can safely ignore them here. dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a -dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) +dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage MCFatal span msg))) checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath) @@ -1433,7 +1433,7 @@ load_dyn interp hsc_env crash_early dll = do else when (wopt Opt_WarnMissedExtraSharedLib dflags) $ putLogMsg logger dflags - (Reason Opt_WarnMissedExtraSharedLib) SevWarning + (mkMCDiagnostic $ WarningWithFlag Opt_WarnMissedExtraSharedLib) noSrcSpan $ withPprStyle defaultUserStyle (note err) where dflags = hsc_dflags hsc_env @@ -1731,8 +1731,7 @@ maybePutSDoc :: Logger -> DynFlags -> SDoc -> IO () maybePutSDoc logger dflags s = when (verbosity dflags > 1) $ putLogMsg logger dflags - NoReason - SevInteractive + MCInteractive noSrcSpan $ withPprStyle defaultUserStyle s diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 2bfefb41ed..c0c09d6173 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -13,10 +13,10 @@ import GHC.Driver.Flags import GHC.Parser.Errors import GHC.Parser.Types import GHC.Types.Basic +import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Types.Name.Reader (starInfo, rdrNameOcc, opIsAt, mkUnqual) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) -import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Data.FastString @@ -25,25 +25,23 @@ import GHC.Hs.Type (pprLHsContext) import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple) -mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc +mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage mkParserErr span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = mkDecorated [doc] + , errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) ErrorWithoutFlag , errMsgSeverity = SevError - , errMsgReason = NoReason } -mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc +mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage mkParserWarn flag span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = mkDecorated [doc] + , errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) (WarningWithFlag flag) , errMsgSeverity = SevWarning - , errMsgReason = Reason flag } -pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc +pprWarning :: PsWarning -> MsgEnvelope DiagnosticMessage pprWarning = \case PsWarnTab loc tc -> mkParserWarn Opt_WarnTabs loc $ @@ -129,7 +127,7 @@ pprWarning = \case OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" -pprError :: PsError -> MsgEnvelope DecoratedSDoc +pprError :: PsError -> MsgEnvelope DiagnosticMessage pprError err = mkParserErr (errLoc err) $ vcat (pp_err (errDesc err) : map pp_hint (errHints err)) diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index 7b561f2119..a80620eed4 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -314,7 +314,7 @@ checkProcessArgsResult flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags where mkMsg (L loc flag) - = mkPlainMsgEnvelope loc $ + = mkPlainMsgEnvelope ErrorWithoutFlag loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) @@ -349,7 +349,7 @@ unsupportedExtnError dflags loc unsup = suggestions = fuzzyMatch unsup supported -optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DecoratedSDoc +optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DiagnosticMessage optionsErrorMsgs unhandled_flags flags_lines _filename = mkMessages $ listToBag (map mkMsg unhandled_flags_lines) where unhandled_flags_lines :: [Located String] @@ -358,7 +358,7 @@ optionsErrorMsgs unhandled_flags flags_lines _filename , L l f' <- flags_lines , f == f' ] mkMsg (L flagSpan flag) = - mkPlainMsgEnvelope flagSpan $ + mkPlainMsgEnvelope ErrorWithoutFlag flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag optionsParseError :: String -> SrcSpan -> a -- #15053 @@ -371,4 +371,4 @@ optionsParseError str loc = throwErr :: SrcSpan -> SDoc -> a -- #15053 throwErr loc doc = - throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope loc doc + throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag loc doc diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 23f201f120..a37f88bc83 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -489,7 +489,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat -- See Note [Pattern bindings that bind no variables] ; whenWOptM Opt_WarnUnusedPatternBinds $ when (null bndrs && not ok_nobind_pat) $ - addWarn (Reason Opt_WarnUnusedPatternBinds) $ + addDiagnostic (WarningWithFlag Opt_WarnUnusedPatternBinds) $ unusedPatBindWarn bind' ; fvs' `seq` -- See Note [Free-variable space leak] @@ -1249,7 +1249,7 @@ rnGRHS' ctxt rnBody (GRHS _ guards rhs) rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') - (addWarn NoReason (nonStdGuardErr guards')) + (addDiagnostic WarningWithoutFlag (nonStdGuardErr guards')) ; return (GRHS noAnn guards' rhs', fvs) } where diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 893e4ed60b..da2794f805 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -1048,8 +1048,8 @@ lookup_demoted rdr_name Nothing -> unboundNameX WL_Any rdr_name star_info Just demoted_name -> do { whenWOptM Opt_WarnUntickedPromotedConstructors $ - addWarn - (Reason Opt_WarnUntickedPromotedConstructors) + addDiagnostic + (WarningWithFlag Opt_WarnUntickedPromotedConstructors) (untickedPromConstrWarn demoted_name) ; return demoted_name } } else do { -- We need to check if a data constructor of this name is @@ -1523,8 +1523,8 @@ warnIfDeprecated gre@(GRE { gre_imp = iss }) -- See Note [Handling of deprecations] do { iface <- loadInterfaceForName doc name ; case lookupImpDeprec iface gre of - Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations) - (mk_msg imp_spec txt) + Just txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) + (mk_msg imp_spec txt) Nothing -> return () } } | otherwise = return () diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index a7f28b69cc..07cc79fd17 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -1650,7 +1650,7 @@ warnUnusedForAll :: OutputableBndrFlag flag 'Renamed warnUnusedForAll doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ - addWarnAt (Reason Opt_WarnUnusedForalls) (locA loc) $ + addDiagnosticAt (WarningWithFlag Opt_WarnUnusedForalls) (locA loc) $ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , inHsDocContext doc ] diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 00482b7c93..b5c91c8cc3 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -538,7 +538,7 @@ checkCanonicalInstances cls poly_ty mbinds = do -- got "lhs = rhs" but expected something different addWarnNonCanonicalMethod1 refURL flag lhs rhs = - addWarn (Reason flag) $ vcat + addDiagnostic (WarningWithFlag flag) $ vcat [ text "Noncanonical" <+> quotes (text (lhs ++ " = " ++ rhs)) <+> text "definition detected" @@ -552,7 +552,7 @@ checkCanonicalInstances cls poly_ty mbinds = do -- expected "lhs = rhs" but got something else addWarnNonCanonicalMethod2 refURL flag lhs rhs = - addWarn (Reason flag) $ vcat + addDiagnostic (WarningWithFlag flag) $ vcat [ text "Noncanonical" <+> quotes (text lhs) <+> text "definition detected" @@ -1947,8 +1947,8 @@ warnNoDerivStrat mds loc = do { dyn_flags <- getDynFlags ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $ case mds of - Nothing -> addWarnAt - (Reason Opt_WarnMissingDerivingStrategies) + Nothing -> addDiagnosticAt + (WarningWithFlag Opt_WarnMissingDerivingStrategies) loc (if xopt LangExt.DerivingStrategies dyn_flags then no_strat_warning diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 835e39a246..2781f9df91 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -334,8 +334,8 @@ rnImportDecl this_mod _ | implicit -> return () -- Do not bleat for implicit imports | qual_only -> return () | otherwise -> whenWOptM Opt_WarnMissingImportList $ - addWarn (Reason Opt_WarnMissingImportList) - (missingImportListWarn imp_mod_name) + addDiagnostic (WarningWithFlag Opt_WarnMissingImportList) + (missingImportListWarn imp_mod_name) iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) @@ -396,8 +396,8 @@ rnImportDecl this_mod -- Complain if we import a deprecated module whenWOptM Opt_WarnWarningsDeprecations ( case (mi_warns iface) of - WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations) - (moduleWarn imp_mod_name txt) + WarnAll txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) + (moduleWarn imp_mod_name txt) _ -> return () ) @@ -522,7 +522,7 @@ warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () warnUnqualifiedImport decl iface = whenWOptM Opt_WarnCompatUnqualifiedImports $ when bad_import - $ addWarnAt (Reason Opt_WarnCompatUnqualifiedImports) loc warning + $ addDiagnosticAt (WarningWithFlag Opt_WarnCompatUnqualifiedImports) loc warning where mod = mi_module iface loc = getLoc $ ideclName decl @@ -1165,11 +1165,11 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) where -- Warn when importing T(..) if T was exported abstractly emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ - addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n) + addDiagnostic (WarningWithFlag Opt_WarnDodgyImports) (dodgyImportWarn n) emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ - addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr) + addDiagnostic (WarningWithFlag Opt_WarnMissingImportList) (missingImportListItem ieRdr) emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ - addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie)) + addDiagnostic (WarningWithFlag Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie)) run_lookup :: IELookupM a -> TcRn (Maybe a) run_lookup m = case m of @@ -1514,7 +1514,7 @@ warnMissingSignatures gbl_env add_warn name msg = when (name `elemNameSet` sig_ns && export_check name) - (addWarnAt (Reason flag) (getSrcSpan name) msg) + (addDiagnosticAt (WarningWithFlag flag) (getSrcSpan name) msg) export_check name = warn_missing_sigs || not warn_only_exported || name `elemNameSet` exports @@ -1536,7 +1536,7 @@ warnMissingKindSignatures gbl_env add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) () add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $ - addWarnAt (Reason Opt_WarnMissingKindSignatures) (getSrcSpan name) $ + addDiagnosticAt (WarningWithFlag Opt_WarnMissingKindSignatures) (getSrcSpan name) $ hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg) where msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:" @@ -1703,7 +1703,7 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) -- Nothing used; drop entire declaration | null used - = addWarnAt (Reason flag) (locA loc) msg1 + = addDiagnosticAt (WarningWithFlag flag) (locA loc) msg1 -- Everything imported is used; nop | null unused @@ -1714,11 +1714,11 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) | Just (_, L _ imports) <- ideclHiding decl , length unused == 1 , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports - = addWarnAt (Reason flag) (locA loc) msg2 + = addDiagnosticAt (WarningWithFlag flag) (locA loc) msg2 -- Some imports are unused | otherwise - = addWarnAt (Reason flag) (locA loc) msg2 + = addDiagnosticAt (WarningWithFlag flag) (locA loc) msg2 where msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index d22cabf69e..b41170014c 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -913,9 +913,9 @@ check_cross_stage_lifting top_lvl name ps_var -- Warning for implicit lift (#17804) ; whenWOptM Opt_WarnImplicitLift $ - addWarnTc (Reason Opt_WarnImplicitLift) - (text "The variable" <+> quotes (ppr name) <+> - text "is implicitly lifted in the TH quotation") + addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift) + (text "The variable" <+> quotes (ppr name) <+> + text "is implicitly lifted in the TH quotation") -- Update the pending splices ; ps <- readMutVar ps_var diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 3db88858e0..e5d27fa234 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -169,9 +169,9 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns -- we don't find any GREs that are in scope qualified-only complain [] = return () - complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing) - loc - (shadowedNameWarn occ pp_locs) + complain pp_locs = addDiagnosticAt (WarningWithFlag Opt_WarnNameShadowing) + loc + (shadowedNameWarn occ pp_locs) is_shadowed_gre :: GlobalRdrElt -> RnM Bool -- Returns False for record selectors that are shadowed, when @@ -386,8 +386,8 @@ checkUnusedRecordWildcard loc fvs (Just dotdot_names) = warnRedundantRecordWildcard :: RnM () warnRedundantRecordWildcard = whenWOptM Opt_WarnRedundantRecordWildcards - (addWarn (Reason Opt_WarnRedundantRecordWildcards) - redundantWildcardWarning) + (addDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards) + redundantWildcardWarning) -- | Produce a warning when no variables bound by a `..` pattern are used. @@ -475,7 +475,7 @@ reportable child addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () addUnusedWarning flag occ span msg - = addWarnAt (Reason flag) span $ + = addDiagnosticAt (WarningWithFlag flag) span $ sep [msg <> colon, nest 2 $ pprNonVarNameSpace (occNameSpace occ) <+> quotes (ppr occ)] diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 387d52b6de..be6241acb8 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -184,7 +184,7 @@ showTerm term = do setSession new_env -- this disables logging of errors - let noop_log _ _ _ _ _ = return () + let noop_log _ _ _ _ = return () pushLogHookM (const noop_log) return (hsc_env, bname) diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 8464cb8786..412d221794 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -51,7 +51,7 @@ import GHC.Types.Var.Set import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) -import GHC.Utils.Error ( Severity(..), mkLocMessage ) +import GHC.Utils.Error ( mkLocMessage ) import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc @@ -79,7 +79,7 @@ lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds Nothing -> return () Just msg -> do - putLogMsg logger dflags NoReason Err.SevDump noSrcSpan + putLogMsg logger dflags Err.MCDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunnit <+> text "***", @@ -358,7 +358,8 @@ addErr errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage SevWarning l (hdr $$ msg) + in mkLocMessage (Err.mkMCDiagnostic WarningWithoutFlag) + l (hdr $$ msg) mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs index d98710febd..c9cd24cf89 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -310,7 +310,7 @@ builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do logInfo logger dflags $ withPprStyle defaultUserStyle msg log_loop chan t BuildError loc msg -> do - putLogMsg logger dflags NoReason SevError (mkSrcSpan loc loc) + putLogMsg logger dflags (mkMCDiagnostic ErrorWithoutFlag) (mkSrcSpan loc loc) $ withPprStyle defaultUserStyle msg log_loop chan t EOF -> diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index f3d6ede42d..198bfa2477 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -739,7 +739,7 @@ tcStandaloneDerivInstType ctxt warnUselessTypeable :: TcM () warnUselessTypeable = do { warn <- woptM Opt_WarnDerivingTypeable - ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable) + ; when warn $ addDiagnosticTc (WarningWithFlag Opt_WarnDerivingTypeable) $ text "Deriving" <+> quotes (ppr typeableClassName) <+> text "has no effect: all types now auto-derive Typeable" } @@ -1611,7 +1611,7 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys -- See Note [Deriving strategies] when (newtype_deriving && deriveAnyClass) $ lift $ whenWOptM Opt_WarnDerivingDefaults $ - addWarnTc (Reason Opt_WarnDerivingDefaults) $ sep + addDiagnosticTc (WarningWithFlag Opt_WarnDerivingDefaults) $ sep [ text "Both DeriveAnyClass and" <+> text "GeneralizedNewtypeDeriving are enabled" , text "Defaulting to the DeriveAnyClass strategy" @@ -2001,8 +2001,8 @@ doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism Nothing -> pure () Just span -> setSrcSpan span $ do checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion) - warnTc (Reason Opt_WarnPartialTypeSignatures) - wpartial_sigs partial_sig_msg + diagnosticTc (WarningWithFlag Opt_WarnPartialTypeSignatures) + wpartial_sigs partial_sig_msg -- Check for Generic instances that are derived with an exotic -- deriving strategy like DAC diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index f1325446f0..23cad15976 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -132,27 +132,33 @@ reportUnsolved wanted = do { binds_var <- newTcEvBinds ; defer_errors <- goptM Opt_DeferTypeErrors ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283 - ; let type_errors | not defer_errors = TypeError - | warn_errors = TypeWarn (Reason Opt_WarnDeferredTypeErrors) - | otherwise = TypeDefer + ; let type_errors | not defer_errors = Just ErrorWithoutFlag + | warn_errors = Just (WarningWithFlag Opt_WarnDeferredTypeErrors) + | otherwise = Nothing ; defer_holes <- goptM Opt_DeferTypedHoles ; warn_holes <- woptM Opt_WarnTypedHoles - ; let expr_holes | not defer_holes = HoleError - | warn_holes = HoleWarn - | otherwise = HoleDefer + ; let expr_holes | not defer_holes = Just ErrorWithoutFlag + | warn_holes = Just (WarningWithFlag Opt_WarnTypedHoles) + | otherwise = Nothing ; partial_sigs <- xoptM LangExt.PartialTypeSignatures ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = HoleError - | warn_partial_sigs = HoleWarn - | otherwise = HoleDefer + ; let type_holes | not partial_sigs + = Just ErrorWithoutFlag + | warn_partial_sigs + = Just (WarningWithFlag Opt_WarnPartialTypeSignatures) + | otherwise + = Nothing ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables - ; let out_of_scope_holes | not defer_out_of_scope = HoleError - | warn_out_of_scope = HoleWarn - | otherwise = HoleDefer + ; let out_of_scope_holes | not defer_out_of_scope + = Just ErrorWithoutFlag + | warn_out_of_scope + = Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables) + | otherwise + = Nothing ; report_unsolved type_errors expr_holes type_holes out_of_scope_holes @@ -174,11 +180,12 @@ reportAllUnsolved wanted ; partial_sigs <- xoptM LangExt.PartialTypeSignatures ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = HoleError - | warn_partial_sigs = HoleWarn - | otherwise = HoleDefer + ; let type_holes | not partial_sigs = Just ErrorWithoutFlag + | warn_partial_sigs = Just (WarningWithFlag Opt_WarnPartialTypeSignatures) + | otherwise = Nothing - ; report_unsolved TypeError HoleError type_holes HoleError + ; report_unsolved (Just ErrorWithoutFlag) + (Just ErrorWithoutFlag) type_holes (Just ErrorWithoutFlag) ev_binds wanted } -- | Report all unsolved goals as warnings (but without deferring any errors to @@ -187,14 +194,17 @@ reportAllUnsolved wanted warnAllUnsolved :: WantedConstraints -> TcM () warnAllUnsolved wanted = do { ev_binds <- newTcEvBinds - ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn + ; report_unsolved (Just WarningWithoutFlag) + (Just WarningWithoutFlag) + (Just WarningWithoutFlag) + (Just WarningWithoutFlag) ev_binds wanted } -- | Report unsolved goals as errors or warnings. -report_unsolved :: TypeErrorChoice -- Deferred type errors - -> HoleChoice -- Expression holes - -> HoleChoice -- Type holes - -> HoleChoice -- Out of scope holes +report_unsolved :: Maybe DiagnosticReason -- Deferred type errors + -> Maybe DiagnosticReason -- Expression holes + -> Maybe DiagnosticReason -- Type holes + -> Maybe DiagnosticReason -- Out of scope holes -> EvBindsVar -- cec_binds -> WantedConstraints -> TcM () report_unsolved type_errors expr_holes @@ -267,10 +277,11 @@ instance Outputable Report where -- Debugging only , text "valid:" <+> vcat val ] {- Note [Error report] +~~~~~~~~~~~~~~~~~~~~~~ The idea is that error msgs are divided into three parts: the main msg, the -context block (\"In the second argument of ...\"), and the relevant bindings -block, which are displayed in that order, with a mark to divide them. The -idea is that the main msg ('report_important') varies depending on the error +context block ("In the second argument of ..."), and the relevant bindings +block, which are displayed in that order, with a mark to divide them. The +the main msg ('report_important') varies depending on the error in question, but context and relevant bindings are always the same, which should simplify visual parsing. @@ -298,30 +309,6 @@ mk_relevant_bindings doc = mempty { report_relevant_bindings = [doc] } valid_hole_fits :: SDoc -> Report valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] } -data TypeErrorChoice -- What to do for type errors found by the type checker - = TypeError -- A type error aborts compilation with an error message - | TypeWarn WarnReason - -- A type error is deferred to runtime, plus a compile-time warning - -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors) - -- but it isn't for the Safe Haskell Overlapping Instances warnings - -- see warnAllUnsolved - | TypeDefer -- A type error is deferred to runtime; no error or warning at compile time - -data HoleChoice - = HoleError -- A hole is a compile-time error - | HoleWarn -- Defer to runtime, emit a compile-time warning - | HoleDefer -- Defer to runtime, no warning - -instance Outputable HoleChoice where - ppr HoleError = text "HoleError" - ppr HoleWarn = text "HoleWarn" - ppr HoleDefer = text "HoleDefer" - -instance Outputable TypeErrorChoice where - ppr TypeError = text "TypeError" - ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason - ppr TypeDefer = text "TypeDefer" - data ReportErrCtxt = CEC { cec_encl :: [Implication] -- Enclosing implications -- (innermost first) @@ -332,15 +319,15 @@ data ReportErrCtxt -- into warnings, and emit evidence bindings -- into 'cec_binds' for unsolved constraints - , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime + , cec_defer_type_errors :: Maybe DiagnosticReason -- Nothing: Defer type errors until runtime -- cec_expr_holes is a union of: -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' -- cec_out_of_scope_holes - a set of variables which are -- out of scope: 'x', 'y', 'bar' - , cec_expr_holes :: HoleChoice -- Holes in expressions - , cec_type_holes :: HoleChoice -- Holes in types - , cec_out_of_scope_holes :: HoleChoice -- Out of scope holes + , cec_expr_holes :: Maybe DiagnosticReason -- Holes in expressions. Nothing: defer/suppress errors. + , cec_type_holes :: Maybe DiagnosticReason -- Holes in types. Nothing: defer/suppress errors. + , cec_out_of_scope_holes :: Maybe DiagnosticReason -- Out of scope holes. Nothing: defer/suppress errors. , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints , cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms @@ -373,19 +360,19 @@ instance Outputable ReportErrCtxt where -- | Returns True <=> the ReportErrCtxt indicates that something is deferred deferringAnyBindings :: ReportErrCtxt -> Bool -- Don't check cec_type_holes, as these don't cause bindings to be deferred -deferringAnyBindings (CEC { cec_defer_type_errors = TypeError - , cec_expr_holes = HoleError - , cec_out_of_scope_holes = HoleError }) = False -deferringAnyBindings _ = True +deferringAnyBindings (CEC { cec_defer_type_errors = Just ErrorWithoutFlag + , cec_expr_holes = Just ErrorWithoutFlag + , cec_out_of_scope_holes = Just ErrorWithoutFlag }) = False +deferringAnyBindings _ = True maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt -- Switch off defer-type-errors inside CoEvBindsVar -- See Note [Failing equalities with no evidence bindings] maybeSwitchOffDefer evb ctxt | CoEvBindsVar{} <- evb - = ctxt { cec_defer_type_errors = TypeError - , cec_expr_holes = HoleError - , cec_out_of_scope_holes = HoleError } + = ctxt { cec_defer_type_errors = Just ErrorWithoutFlag + , cec_expr_holes = Just ErrorWithoutFlag + , cec_out_of_scope_holes = Just ErrorWithoutFlag } | otherwise = ctxt @@ -492,14 +479,14 @@ warnRedundantConstraints ctxt env info ev_vars -- to the error context, which is a bit tiresome addErrCtxt (text "In" <+> ppr info) $ do { env <- getLclEnv - ; msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } + ; msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc) + ; reportDiagnostic msg } | otherwise -- But for InstSkol there already *is* a surrounding -- "In the instance declaration for Eq [a]" context -- and we don't want to say it twice. Seems a bit ad-hoc - = do { msg <- mkErrorReport ctxt env (important doc) - ; reportWarning (Reason Opt_WarnRedundantConstraints) msg } + = do { msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc) + ; reportDiagnostic msg } where doc = text "Redundant constraint" <> plural redundant_evs <> colon <+> pprEvVarTheta redundant_evs @@ -518,8 +505,8 @@ warnRedundantConstraints ctxt env info ev_vars reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols - = do { msg <- mkErrorReport ctxt env (important doc) - ; reportError msg } + = do { msg <- mkErrorReport ErrorWithoutFlag ctxt env (important doc) + ; reportDiagnostic msg } where doc = hang (text "These kind and type variables:" <+> telescope $$ text "are out of dependency order. Perhaps try this ordering:") @@ -741,9 +728,8 @@ reportHoles :: [Ct] -- other (tidied) constraints -> ReportErrCtxt -> [Hole] -> TcM () reportHoles tidy_cts ctxt = mapM_ $ \hole -> unless (ignoreThisHole ctxt hole) $ - do { err <- mkHoleError tidy_cts ctxt hole - ; maybeReportHoleError ctxt hole err - ; maybeAddDeferredHoleBinding ctxt err hole } + do { msg_mb <- mkHoleError tidy_cts ctxt hole + ; whenIsJust msg_mb reportDiagnostic } ignoreThisHole :: ReportErrCtxt -> Hole -> Bool -- See Note [Skip type holes rapidly] @@ -754,8 +740,8 @@ ignoreThisHole ctxt hole ConstraintHole -> ignore_type_hole where ignore_type_hole = case cec_type_holes ctxt of - HoleDefer -> True - _ -> False + Nothing -> True + _ -> False {- Note [Skip type holes rapidly] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -776,8 +762,8 @@ mkUserTypeErrorReporter ctxt ; maybeReportError ctxt err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc) -mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct +mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage) +mkUserTypeError ctxt ct = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ important $ pprUserTypeErrorTy $ case getUserTypeErrorMsg ct of @@ -802,10 +788,10 @@ mkGivenErrorReporter ctxt cts report = important inaccessible_msg `mappend` mk_relevant_bindings binds_msg - ; err <- mkEqErr_help dflags ctxt report ct' ty1 ty2 + ; err <- mkEqErr_help (WarningWithFlag Opt_WarnInaccessibleCode) dflags ctxt report ct' ty1 ty2 ; traceTc "mkGivenErrorReporter" (ppr ct) - ; reportWarning (Reason Opt_WarnInaccessibleCode) err } + ; reportDiagnostic err } where (ct : _ ) = cts -- Never empty (ty1, ty2) = getEqPredTys (ctPred ct) @@ -852,7 +838,7 @@ pattern match which binds some equality constraints. If we find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, @@ -861,7 +847,7 @@ mkGroupReporter mk_err ctxt cts = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) -- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -879,7 +865,7 @@ cmp_loc ct1 ct2 = get ct1 `compare` get ct2 -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter reportGroup mk_err ctxt cts = ASSERT( not (null cts)) do { err <- mk_err ctxt cts @@ -898,67 +884,40 @@ reportGroup mk_err ctxt cts = -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts } -maybeReportHoleError :: ReportErrCtxt -> Hole -> MsgEnvelope DecoratedSDoc -> TcM () -maybeReportHoleError ctxt hole err - | isOutOfScopeHole hole - -- Always report an error for out-of-scope variables - -- Unless -fdefer-out-of-scope-variables is on, - -- in which case the messages are discarded. - -- See #12170, #12406 - = -- If deferring, report a warning only if -Wout-of-scope-variables is on - case cec_out_of_scope_holes ctxt of - HoleError -> reportError err - HoleWarn -> - reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err - HoleDefer -> return () - --- Unlike maybeReportError, these "hole" errors are --- /not/ suppressed by cec_suppress. We want to see them! -maybeReportHoleError ctxt (Hole { hole_sort = hole_sort }) err - | case hole_sort of TypeHole -> True - ConstraintHole -> True - _ -> False - -- When -XPartialTypeSignatures is on, warnings (instead of errors) are - -- generated for holes in partial type signatures. - -- Unless -fwarn-partial-type-signatures is not on, - -- in which case the messages are discarded. - = -- For partial type signatures, generate warnings only, and do that - -- only if -fwarn-partial-type-signatures is on - case cec_type_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err - HoleDefer -> return () - -maybeReportHoleError ctxt hole err - -- Otherwise this is a typed hole in an expression, - -- but not for an out-of-scope variable (because that goes through a - -- different function) - = -- If deferring, report a warning only if -Wtyped-holes is on - ASSERT( not (isOutOfScopeHole hole) ) - case cec_expr_holes ctxt of - HoleError -> reportError err - HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err - HoleDefer -> return () - -maybeReportError :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> TcM () +maybeReportError :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> TcM () -- Report the error and/or make a deferred binding for it -maybeReportError ctxt err +maybeReportError ctxt msg | cec_suppress ctxt -- Some worse error has occurred; = return () -- so suppress this error/warning + | Just reason <- cec_defer_type_errors ctxt + = reportDiagnostic (reclassify reason msg) | otherwise - = case cec_defer_type_errors ctxt of - TypeDefer -> return () - TypeWarn reason -> reportWarning reason err - TypeError -> reportError err - -addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Ct -> TcM () + = return () + where + -- Reclassifies a 'DiagnosticMessage', by explicitly setting its 'Severity' and + -- 'DiagnosticReason'. This function has to be considered unsafe and local to this + -- module, and it's a temporary stop-gap in the context of #18516. In particular, + -- diagnostic messages should have both their 'DiagnosticReason' and 'Severity' computed + -- \"at birth\": the former is statically computer, the latter is computed using the + -- 'DynFlags' in scope at the time of construction. However, due to the intricacies of + -- the current error-deferring logic, we are not always able to enforce this invariant + -- and we rather have to change one or the other /a posteriori/. + reclassify :: DiagnosticReason + -> MsgEnvelope DiagnosticMessage + -> MsgEnvelope DiagnosticMessage + reclassify rea msg = + let set_reason r m = m { errMsgDiagnostic = (errMsgDiagnostic m) { diagReason = r } } + set_severity s m = m { errMsgSeverity = s } + in set_severity (defaultReasonSeverity rea) . set_reason rea $ msg + +addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt @@ -981,31 +940,13 @@ addDeferredBinding ctxt err ct = return () mkErrorTerm :: DynFlags -> Type -- of the error term - -> MsgEnvelope DecoratedSDoc -> EvTerm + -> MsgEnvelope DiagnosticMessage -> EvTerm mkErrorTerm dflags ty err = evDelayedError ty err_fs where err_msg = pprLocMsgEnvelope err err_fs = mkFastString $ showSDoc dflags $ err_msg $$ text "(deferred type error)" -maybeAddDeferredHoleBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Hole -> TcM () -maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole (HER ref ref_ty _) }) --- Only add bindings for holes in expressions --- not for holes in partial type signatures --- cf. addDeferredBinding - | deferringAnyBindings ctxt - = do { dflags <- getDynFlags - ; let err_tm = mkErrorTerm dflags ref_ty err - -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. - -- See Note [Holes] in GHC.Tc.Types.Constraint - ; writeMutVar ref err_tm } - | otherwise - = return () -maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = TypeHole }) - = return () -maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = ConstraintHole }) - = return () - tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -- Use the first reporter in the list whose predicate says True tryReporters ctxt reporters cts @@ -1074,14 +1015,19 @@ pprWithArising (ct:cts) ppr_one ct' = hang (parens (pprType (ctPred ct'))) 2 (pprCtLoc (ctLoc ct')) -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DecoratedSDoc) -mkErrorMsgFromCt ctxt ct report - = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report +mkErrorMsgFromCt :: DiagnosticReason -> ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DiagnosticMessage) +mkErrorMsgFromCt rea ctxt ct report + = mkErrorReport rea ctxt (ctLocEnv (ctLoc ct)) report -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (MsgEnvelope DecoratedSDoc) -mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) +mkErrorReport :: DiagnosticReason + -> ReportErrCtxt + -> TcLclEnv + -> Report + -> TcM (MsgEnvelope DiagnosticMessage) +mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) + ; mkDecoratedSDocAt rea + (RealSrcSpan (tcl_loc tcl_env) Nothing) (vcat important) context (vcat $ relevant_bindings ++ valid_subs) @@ -1181,19 +1127,54 @@ solve it. ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) - ; mkErrorMsgFromCt ctxt ct1 $ + ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 $ msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts +{- Note [Constructing Hole Errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Whether or not 'mkHoleError' returns an error is not influenced by cec_suppress. In other terms, +these "hole" errors are /not/ suppressed by cec_suppress. We want to see them! + +There are two cases to consider: + +1. For out-of-scope variables we always report an error, unless -fdefer-out-of-scope-variables is on, + in which case the messages are discarded. See also #12170 and #12406. If deferring, report a warning + only if -Wout-of-scope-variables is on. + +2. For the general case, when -XPartialTypeSignatures is on, warnings (instead of errors) are generated + for holes in partial type signatures, unless -Wpartial-type-signatures is not on, in which case + the messages are discarded. If deferring, report a warning only if -Wtyped-holes is on. + +The above can be summarised into the following table: + +| Hole Type | Active Flags | Outcome | +|--------------|----------------------------------------------------------|------------------| +| out-of-scope | None | Error | +| out-of-scope | -fdefer-out-of-scope-variables, -Wout-of-scope-variables | Warning | +| out-of-scope | -fdefer-out-of-scope-variables | Ignore (discard) | +| type | None | Error | +| type | -XPartialTypeSignatures, -Wpartial-type-signatures | Warning | +| type | -XPartialTypeSignatures | Ignore (discard) | +| expression | None | Error | +| expression | -Wdefer-typed-holes, -Wtyped-holes | Warning | +| expression | -Wdefer-typed-holes | Ignore (discard) | + +See also 'reportUnsolved'. + +-} + ---------------- -mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc) -mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ +-- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. +mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (Maybe (MsgEnvelope DiagnosticMessage)) +mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) | isOutOfScopeHole hole @@ -1202,10 +1183,15 @@ mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ ; imp_info <- getImports ; curr_mod <- getModule ; hpt <- getHpt - ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) - out_of_scope_msg O.empty - (unknownNameSuggestions dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) } + ; let mk_err rea = do + mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc lcl_env) Nothing) + out_of_scope_msg O.empty + (unknownNameSuggestions dflags hpt curr_mod rdr_env + (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) + + ; maybeAddDeferredBindings ctxt hole mk_err + ; whenNotDeferring (cec_out_of_scope_holes ctxt) mk_err + } where herald | isDataOcc occ = text "Data constructor not in scope:" | otherwise = text "Variable not in scope:" @@ -1217,7 +1203,6 @@ mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ lcl_env = ctLocEnv ct_loc boring_type = isTyVarTy hole_ty - -- general case: not an out-of-scope error mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_sort = sort @@ -1238,10 +1223,19 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ then validHoleFits ctxt tidy_simples hole else return (ctxt, empty) - ; mkErrorReport ctxt lcl_env $ - important hole_msg `mappend` - mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend` - valid_hole_fits sub_msg } + ; let mk_err rea = + mkErrorReport rea ctxt lcl_env $ + important hole_msg `mappend` + mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend` + valid_hole_fits sub_msg + + ; maybeAddDeferredBindings ctxt hole mk_err + + ; let holes | ExprHole _ <- sort = cec_expr_holes ctxt + | otherwise = cec_type_holes ctxt + ; whenNotDeferring holes mk_err + + } where lcl_env = ctLocEnv ct_loc @@ -1277,7 +1271,7 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ -- hole, via kind casts type_hole_hint - | HoleError <- cec_type_holes ctxt + | Just ErrorWithoutFlag <- cec_type_holes ctxt = text "To use the inferred type, enable PartialTypeSignatures" | otherwise = empty @@ -1298,6 +1292,44 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ = ppWhenOption sdocPrintExplicitCoercions $ quotes (ppr tv) <+> text "is a coercion variable" + +-- | Similar in spirit to 'whenIsJust', but the action returns a value of type @Maybe b@. +whenNotDeferring :: Monad m => Maybe a -> (a -> m b) -> m (Maybe b) +whenNotDeferring = flip traverse + +{- Note [Adding deferred bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When working with typed holes we have to deal with the case where +we want holes to be reported as warnings to users during compile time but +as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings' +with a function which is able to override the 'DiagnosticReason' of a 'DiagnosticMessage', +so that the correct 'Severity' can be computed out of that later on. + +-} + + +-- | Adds deferred bindings (as errors). +-- See Note [Adding deferred bindings]. +maybeAddDeferredBindings :: ReportErrCtxt + -> Hole + -> (DiagnosticReason -> TcM (MsgEnvelope DiagnosticMessage)) + -> TcM () +maybeAddDeferredBindings ctxt hole mk_err = do + case hole_sort hole of + ExprHole (HER ref ref_ty _) -> do + -- Only add bindings for holes in expressions + -- not for holes in partial type signatures + -- cf. addDeferredBinding + when (deferringAnyBindings ctxt) $ do + dflags <- getDynFlags + err <- mk_err ErrorWithoutFlag + let err_tm = mkErrorTerm dflags ref_ty err + -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. + -- See Note [Holes] in GHC.Tc.Types.Constraint + writeMutVar ref err_tm + _ -> pure () + pp_occ_with_type :: OccName -> Type -> SDoc pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) @@ -1333,7 +1365,7 @@ givenConstraintsMsg ctxt = 2 (vcat $ map pprConstraint constraints) ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1346,7 +1378,7 @@ mkIPErr ctxt cts | otherwise = couldNotDeduce givens (preds, orig) - ; mkErrorMsgFromCt ctxt ct1 $ + ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 $ msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts @@ -1410,11 +1442,11 @@ any more. So we don't assert that it is. -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc) +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage) mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct @@ -1427,7 +1459,7 @@ mkEqErr1 ctxt ct -- Wanted or derived; ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) ; let report = mconcat [ important coercible_msg , mk_relevant_bindings binds_msg] - ; mkEqErr_help dflags ctxt report ct ty1 ty2 } + ; mkEqErr_help ErrorWithoutFlag dflags ctxt report ct ty1 ty2 } where (ty1, ty2) = getEqPredTys (ctPred ct) @@ -1478,41 +1510,42 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 | otherwise = False -mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report +mkEqErr_help :: DiagnosticReason -> DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc) -mkEqErr_help dflags ctxt report ct ty1 ty2 + -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage) +mkEqErr_help rea dflags ctxt report ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 - = mkTyVarEqErr dflags ctxt report ct tv1 ty2 + = mkTyVarEqErr rea dflags ctxt report ct tv1 ty2 | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 - = mkTyVarEqErr dflags ctxt report ct tv2 ty1 + = mkTyVarEqErr rea dflags ctxt report ct tv2 ty1 | otherwise - = reportEqErr ctxt report ct ty1 ty2 + = reportEqErr rea ctxt report ct ty1 ty2 -reportEqErr :: ReportErrCtxt -> Report +reportEqErr :: DiagnosticReason -> ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc) -reportEqErr ctxt report ct ty1 ty2 - = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) + -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage) +reportEqErr rea ctxt report ct ty1 ty2 + = mkErrorMsgFromCt rea ctxt ct (mconcat [misMatch, report, eqInfo]) where misMatch = misMatchOrCND False ctxt ct ty1 ty2 eqInfo = mkEqInfoMsg ct ty1 ty2 mkTyVarEqErr, mkTyVarEqErr' - :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> TcM (MsgEnvelope DecoratedSDoc) + :: DiagnosticReason + -> DynFlags -> ReportErrCtxt -> Report -> Ct + -> TcTyVar -> TcType -> TcM (MsgEnvelope DiagnosticMessage) -- tv1 and ty2 are already tidied -mkTyVarEqErr dflags ctxt report ct tv1 ty2 +mkTyVarEqErr reason dflags ctxt report ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) - ; mkTyVarEqErr' dflags ctxt report ct tv1 ty2 } + ; mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 } -mkTyVarEqErr' dflags ctxt report ct tv1 ty2 +mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || ctEqRel ct == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) - = mkErrorMsgFromCt ctxt ct $ mconcat + = mkErrorMsgFromCt reason ctxt ct $ mconcat [ headline_msg , extraTyVarEqInfo ctxt tv1 ty2 , suggestAddSig ctxt ty1 ty2 @@ -1537,7 +1570,7 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 interesting_tyvars) tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - ; mkErrorMsgFromCt ctxt ct $ + ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat [headline_msg, extra2, extra3, report] } | CTE_Bad <- occ_check_expand @@ -1547,7 +1580,7 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely -- to be helpful since this is just an unimplemented feature. - ; mkErrorMsgFromCt ctxt ct $ mconcat [ headline_msg, important msg, report ] } + ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat [ headline_msg, important msg, report ] } -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably @@ -1556,7 +1589,7 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 | (implic:_) <- cec_encl ctxt , Implic { ic_skols = skols } <- implic , tv1 `elem` skols - = mkErrorMsgFromCt ctxt ct $ mconcat + = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat [ misMatchMsg ctxt ct ty1 ty2 , extraTyVarEqInfo ctxt tv1 ty2 , report @@ -1584,7 +1617,7 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 , nest 2 $ ppr skol_info , nest 2 $ text "at" <+> ppr (tcl_loc (ic_env implic)) ] ] - ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) } + ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct (mconcat [msg, tv_extra, report]) } -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we @@ -1605,11 +1638,11 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 ppr (tcl_loc (ic_env implic)) ] tv_extra = extraTyVarEqInfo ctxt tv1 ty2 add_sig = suggestAddSig ctxt ty1 ty2 - ; mkErrorMsgFromCt ctxt ct $ mconcat + ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat [msg, tclvl_extra, tv_extra, add_sig, report] } | otherwise - = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2 + = reportEqErr ErrorWithoutFlag ctxt report ct (mkTyVarTy tv1) ty2 -- This *can* happen (#6123, and test T2627b) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. @@ -1700,8 +1733,8 @@ pp_givens givens -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) -mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) +mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct report where report = important msg msg = vcat [ hang (text "Cannot use equality for substitution:") @@ -2307,7 +2340,7 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) mkDictErr ctxt cts = ASSERT( not (null cts) ) do { inst_envs <- tcGetInstEnvs @@ -2322,7 +2355,7 @@ mkDictErr ctxt cts -- have the same source-location origin, to try avoid a cascade -- of error from one location ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; mkErrorMsgFromCt ctxt ct1 (important err) } + ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 (important err) } where no_givens = null (getUserGivens ctxt) @@ -3029,7 +3062,7 @@ warnDefaulting wanteds default_ty , quotes (ppr default_ty) ]) 2 ppr_wanteds - ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg } + ; setCtLocM loc $ diagnosticTc (WarningWithFlag Opt_WarnTypeDefaults) warn_default warn_msg } {- Note [Runtime skolems] diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs index 07f2362688..9254f4b91b 100644 --- a/compiler/GHC/Tc/Gen/Annotation.hs +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -43,7 +43,7 @@ warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _) - = do { setSrcSpanA loc $ addWarnTc NoReason $ + = do { setSrcSpanA loc $ addDiagnosticTc WarningWithoutFlag $ (text "Ignoring ANN annotation" <> plural anns <> comma <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") ; return [] } diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 27572b2a65..228c3d3644 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -1015,7 +1015,7 @@ warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM () warnMissingSignatures flag msg id = do { env0 <- tcInitTidyEnv ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) - ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) } + ; addDiagnosticTcM (WarningWithFlag flag) (env1, mk_msg tidy_ty) } where mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 168127bd19..552b010994 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -397,8 +397,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod when (null gres) $ if isTyConName name then when warnDodgyExports $ - addWarn (Reason Opt_WarnDodgyExports) - (dodgyExportWarn name) + addDiagnostic (WarningWithFlag Opt_WarnDodgyExports) + (dodgyExportWarn name) else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 597b9ca9cf..662a418116 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -1411,8 +1411,8 @@ checkMissingFields con_like rbinds arg_tys else do warn <- woptM Opt_WarnMissingFields when (warn && notNull field_strs && null field_labels) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like [])) + (diagnosticTc (WarningWithFlag Opt_WarnMissingFields) True + (missingFields con_like [])) | otherwise = do -- A record unless (null missing_s_fields) $ do @@ -1427,8 +1427,8 @@ checkMissingFields con_like rbinds arg_tys -- It is not an error (though we may want) to omit a -- lazy field, because we can always use -- (error "Missing field f") instead. - warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like fs) + diagnosticTc (WarningWithFlag Opt_WarnMissingFields) True + (missingFields con_like fs) where -- we zonk the fields to get better types in error messages (#18869) diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index ce5b052a94..d823cdbafb 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -347,8 +347,8 @@ checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand dflags arg_tys res_ty | null arg_tys && isFunPtrTy res_ty && wopt Opt_WarnDodgyForeignImports dflags - = addWarn (Reason Opt_WarnDodgyForeignImports) - (text "possible missing & in foreign import of FunPtr") + = addDiagnosticTc (WarningWithFlag Opt_WarnDodgyForeignImports) + (text "possible missing & in foreign import of FunPtr") | otherwise = return () @@ -535,7 +535,7 @@ checkCConv StdCallConv = do dflags <- getDynFlags then return StdCallConv else do -- This is a warning, not an error. see #3336 when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ - addWarnTc (Reason Opt_WarnUnsupportedCallingConventions) + addDiagnosticTc (WarningWithFlag Opt_WarnUnsupportedCallingConventions) (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") return CCallConv checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 2a442b3fd9..0f1859ab55 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -1115,9 +1115,9 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) -- Warning for implicit lift (#17804) ; whenWOptM Opt_WarnImplicitLift $ - addWarnTc (Reason Opt_WarnImplicitLift) - (text "The variable" <+> quotes (ppr id) <+> - text "is implicitly lifted in the TH quotation") + addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift) + (text "The variable" <+> quotes (ppr id) <+> + text "is implicitly lifted in the TH quotation") -- Update the pending splices ; ps <- readMutVar ps_var diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 1d81b3636b..4a25ffa447 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -596,10 +596,10 @@ addInlinePrags poly_id prags_for_me warn_multiple_inlines inl2 inls | otherwise = setSrcSpanA loc $ - addWarnTc NoReason - (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (inl1:inl2:inls)))) + addDiagnosticTc WarningWithoutFlag + (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" + : map pp_inl (inl1:inl2:inls)))) pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) @@ -729,9 +729,9 @@ tcSpecPrags poly_id prag_sigs is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) warn_discarded_sigs - = addWarnTc NoReason - (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) bad_sigs))) + = addDiagnosticTc WarningWithoutFlag + (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) bad_sigs))) -------------- tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] @@ -812,7 +812,7 @@ tcImpSpec (name, prag) ; if hasSomeUnfolding (realIdUnfolding id) -- See Note [SPECIALISE pragmas for imported Ids] then tcSpecPrag id prag - else do { addWarnTc NoReason (impSpecErr name) + else do { addDiagnosticTc WarningWithoutFlag (impSpecErr name) ; return [] } } impSpecErr :: Name -> SDoc diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index c5b300b8ba..4fadae964b 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -1102,7 +1102,7 @@ instance TH.Quasi TcM where -- 'msg' is forced to ensure exceptions don't escape, -- see Note [Exceptions in TH] qReport True msg = seqList msg $ addErr (text msg) - qReport False msg = seqList msg $ addWarn NoReason (text msg) + qReport False msg = seqList msg $ addDiagnostic WarningWithoutFlag (text msg) qLocation = do { m <- getModule ; l <- getSrcSpanM @@ -1438,7 +1438,7 @@ runTH ty fhv = do -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH :: IServInstance - -> [Messages DecoratedSDoc] -- saved from nested calls to qRecover + -> [Messages DiagnosticMessage] -- saved from nested calls to qRecover -> TcM () runRemoteTH iserv recovers = do THMsg msg <- liftIO $ readIServ iserv getTHMessage diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 09edfcb8c3..26af5166ff 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -191,7 +191,7 @@ tcRnModule :: HscEnv -> ModSummary -> Bool -- True <=> save renamed syntax -> HsParsedModule - -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) + -> IO (Messages DiagnosticMessage, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module} @@ -212,7 +212,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env - err_msg = mkPlainMsgEnvelope loc $ + err_msg = mkPlainMsgEnvelope ErrorWithoutFlag loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod pair :: (Module, SrcSpan) @@ -260,7 +260,7 @@ tcRnModuleTcRnM hsc_env mod_sum ; whenWOptM Opt_WarnImplicitPrelude $ when (notNull prel_imports) $ - addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) + addDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) = @@ -1592,7 +1592,7 @@ tcPreludeClashWarn warnFlag name = do ; traceTc "tcPreludeClashWarn/prelude_functions" (hang (ppr name) 4 (sep [ppr clashingElts])) - ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (greMangledName x)) (hsep + ; let warn_msg x = addDiagnosticAt (WarningWithFlag warnFlag) (nameSrcSpan (greMangledName x)) (hsep [ text "Local definition of" , (quotes . ppr . nameOccName . greMangledName) x , text "clashes with a future Prelude name." ] @@ -1703,7 +1703,7 @@ tcMissingParentClassWarn warnFlag isName shouldName -- <should>" e.g. "Foo is an instance of Monad but not Applicative" ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst warnMsg (KnownTc name:_) = - addWarnAt (Reason warnFlag) instLoc $ + addDiagnosticAt (WarningWithFlag warnFlag) instLoc $ hsep [ (quotes . ppr . nameOccName) name , text "is an instance of" , (ppr . nameOccName . className) isClass @@ -2011,7 +2011,7 @@ get two defns for 'main' in the interface file! ********************************************************* -} -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a) +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DiagnosticMessage, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside @@ -2127,7 +2127,7 @@ We don't bother with the tcl_th_bndrs environment either. -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> GhciLStmt GhcPs - -> IO (Messages DecoratedSDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) + -> IO (Messages DiagnosticMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt = runTcInteractive hsc_env $ do { @@ -2508,7 +2508,7 @@ getGhciStepIO = do return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) -isGHCiMonad :: HscEnv -> String -> IO (Messages DecoratedSDoc, Maybe Name) +isGHCiMonad :: HscEnv -> String -> IO (Messages DiagnosticMessage, Maybe Name) isGHCiMonad hsc_env ty = runTcInteractive hsc_env $ do rdrEnv <- getGlobalRdrEnv @@ -2535,7 +2535,7 @@ data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:typ tcRnExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs - -> IO (Messages DecoratedSDoc, Maybe Type) + -> IO (Messages DiagnosticMessage, Maybe Type) tcRnExpr hsc_env mode rdr_expr = runTcInteractive hsc_env $ do { @@ -2604,7 +2604,7 @@ has a special case for application chains. -------------------------- tcRnImportDecls :: HscEnv -> [LImportDecl GhcPs] - -> IO (Messages DecoratedSDoc, Maybe GlobalRdrEnv) + -> IO (Messages DiagnosticMessage, Maybe GlobalRdrEnv) -- Find the new chunk of GlobalRdrEnv created by this list of import -- decls. In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls @@ -2620,7 +2620,7 @@ tcRnType :: HscEnv -> ZonkFlexi -> Bool -- Normalise the returned type -> LHsType GhcPs - -> IO (Messages DecoratedSDoc, Maybe (Type, Kind)) + -> IO (Messages DiagnosticMessage, Maybe (Type, Kind)) tcRnType hsc_env flexi normalise rdr_type = runTcInteractive hsc_env $ setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] @@ -2754,7 +2754,7 @@ tcRnDeclsi exists to allow class, data, and other declarations in GHCi. tcRnDeclsi :: HscEnv -> [LHsDecl GhcPs] - -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) + -> IO (Messages DiagnosticMessage, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls = runTcInteractive hsc_env $ tcRnSrcDecls False Nothing local_decls @@ -2779,13 +2779,13 @@ externaliseAndTidyId this_mod id -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages DecoratedSDoc, Maybe ModIface) +getModuleInterface :: HscEnv -> Module -> IO (Messages DiagnosticMessage, Maybe ModIface) getModuleInterface hsc_env mod = runTcInteractive hsc_env $ loadModuleInterface (text "getModuleInterface") mod tcRnLookupRdrName :: HscEnv -> LocatedN RdrName - -> IO (Messages DecoratedSDoc, Maybe [Name]) + -> IO (Messages DiagnosticMessage, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ @@ -2799,7 +2799,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } -tcRnLookupName :: HscEnv -> Name -> IO (Messages DecoratedSDoc, Maybe TyThing) +tcRnLookupName :: HscEnv -> Name -> IO (Messages DiagnosticMessage, Maybe TyThing) tcRnLookupName hsc_env name = runTcInteractive hsc_env $ tcRnLookupName' name @@ -2818,7 +2818,7 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO ( Messages DecoratedSDoc + -> IO ( Messages DiagnosticMessage , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) -- Used to implement :info in GHCi @@ -3148,5 +3148,5 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ recordUnsafeInfer pluginUnsafe where unsafeText = "Use of plugins makes the module unsafe" - pluginUnsafe = unitBag ( mkPlainWarnMsg noSrcSpan + pluginUnsafe = unitBag ( mkPlainMsgEnvelope WarningWithoutFlag noSrcSpan (Outputable.text unsafeText) ) diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 93019ac6a2..b4efeaabdd 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -1346,9 +1346,9 @@ decideMonoTyVars infer_mode name_taus psigs candidates -- Warn about the monomorphism restriction ; warn_mono <- woptM Opt_WarnMonomorphism ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $ - warnTc (Reason Opt_WarnMonomorphism) - (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) - mr_msg + diagnosticTc (WarningWithFlag Opt_WarnMonomorphism) + (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) + mr_msg ; traceTc "decideMonoTyVars" $ vcat [ text "infer_mode =" <+> ppr infer_mode diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 438339fcfd..3c1d9eacff 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -2950,7 +2950,7 @@ failTcS, panicTcS :: SDoc -> TcS a warnTcS :: WarningFlag -> SDoc -> TcS () addErrTcS :: SDoc -> TcS () failTcS = wrapTcS . TcM.failWith -warnTcS flag = wrapTcS . TcM.addWarn (Reason flag) +warnTcS flag = wrapTcS . TcM.addDiagnostic (WarningWithFlag flag) addErrTcS = wrapTcS . TcM.addErr panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index d4b25806bf..41767eded1 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -4379,7 +4379,7 @@ checkValidDataCon dflags existential_ok tc con | HsSrcBang _ want_unpack strict_mark <- bang , isSrcUnpacked want_unpack, not (is_strict strict_mark) - = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'")) + = addDiagnosticTc WarningWithoutFlag (bad_bang n (text "UNPACK pragma lacks '!'")) | HsSrcBang _ want_unpack _ <- bang , isSrcUnpacked want_unpack @@ -4395,7 +4395,7 @@ checkValidDataCon dflags existential_ok tc con -- warn in this case (it gives users the wrong idea about whether -- or not UNPACK on abstract types is supported; it is!) , isHomeUnitDefinite (hsc_home_unit hsc_env) - = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma")) + = addDiagnosticTc WarningWithoutFlag (bad_bang n (text "Ignoring unusable UNPACK pragma")) | otherwise = return () diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index 80804ecaea..491e657811 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -258,10 +258,10 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ; spec_prags <- discardConstraints $ tcSpecPrags global_dm_id prags - ; warnTc NoReason - (not (null spec_prags)) - (text "Ignoring SPECIALISE pragmas on default method" - <+> quotes (ppr sel_name)) + ; diagnosticTc WarningWithoutFlag + (not (null spec_prags)) + (text "Ignoring SPECIALISE pragmas on default method" + <+> quotes (ppr sel_name)) ; let hs_ty = hs_sig_fn sel_name `orElse` pprPanic "tc_dm" (ppr sel_name) @@ -337,7 +337,7 @@ tcClassMinimalDef _clas sigs op_info -- since you can't write a default implementation. when (tcg_src tcg_env /= HsigFile) $ whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ - (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf)) + (\bf -> addDiagnosticTc WarningWithoutFlag (warningMinimalDefIncomplete bf)) return mindef where -- By default require all methods without a default implementation @@ -556,7 +556,7 @@ warnMissingAT name -- hs-boot and signatures never need to provide complete "definitions" -- of any sort, as they aren't really defining anything, but just -- constraining items which are defined elsewhere. - ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile) - (text "No explicit" <+> text "associated type" - <+> text "or default declaration for" - <+> quotes (ppr name)) } + ; diagnosticTc (WarningWithFlag Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile) + (text "No explicit" <+> text "associated type" + <+> text "or default declaration for" + <+> quotes (ppr name)) } diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index ec05dffaae..c36ef7d794 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -2109,7 +2109,7 @@ derivBindCtxt sel_id clas tys warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef = do { warn <- woptM Opt_WarnMissingMethods - ; warnTc (Reason Opt_WarnMissingMethods) warn message + ; diagnosticTc (WarningWithFlag Opt_WarnMissingMethods) warn message } where message = vcat [text "No explicit implementation for" diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index dbed564efc..94d454055e 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -130,6 +130,7 @@ import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Types.CostCentre.State import GHC.Types.HpcInfo +import GHC.Types.Error ( DiagnosticMessage ) import GHC.Data.IOEnv import GHC.Data.Bag @@ -765,7 +766,7 @@ data TcLclEnv -- Changes as we move inside an expression -- and for tidying types tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_errs :: TcRef (Messages DecoratedSDoc) -- Place to accumulate errors + tcl_errs :: TcRef (Messages DiagnosticMessage) -- Place to accumulate errors } setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 2dc485fb84..a1f802b254 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -23,6 +23,7 @@ import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Types.Basic (TypeOrKind(..)) +import GHC.Types.Error ( DiagnosticMessage ) import GHC.Types.Fixity (defaultFixity) import GHC.Types.Fixity.Env import GHC.Types.TypeEnv @@ -371,7 +372,7 @@ checkUnit (VirtUnit indef) = do -- an @hsig@ file.) tcRnCheckUnit :: HscEnv -> Unit -> - IO (Messages DecoratedSDoc, Maybe ()) + IO (Messages DiagnosticMessage, Maybe ()) tcRnCheckUnit hsc_env uid = withTiming logger dflags (text "Check unit id" <+> ppr uid) @@ -392,7 +393,7 @@ tcRnCheckUnit hsc_env uid = -- | Top-level driver for signature merging (run after typechecking -- an @hsig@ file). tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface - -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) + -> IO (Messages DiagnosticMessage, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = withTiming logger dflags (text "Signature merging" <+> brackets (ppr this_mod)) @@ -930,7 +931,7 @@ mergeSignatures -- an @hsig@ file.) tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> - IO (Messages DecoratedSDoc, Maybe TcGblEnv) + IO (Messages DiagnosticMessage, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = withTiming logger dflags (text "Signature instantiation"<+>brackets (ppr this_mod)) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index a3d5b15c98..0bdfa00d5d 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -76,8 +76,8 @@ module GHC.Tc.Utils.Monad( tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportErrors, reportError, - reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, + mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportDiagnostic, reportDiagnostics, + recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, attemptM, tryTc, askNoErrs, discardErrs, tryTcDiscardingErrs, checkNoErrs, whenNoErrs, @@ -93,8 +93,8 @@ module GHC.Tc.Utils.Monad( failWithTc, failWithTcM, checkTc, checkTcM, failIfTc, failIfTcM, - warnIfFlag, warnIf, warnTc, warnTcM, - addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn, + warnIfFlag, warnIf, diagnosticTc, diagnosticTcM, + addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt, add_diagnostic, mkErrInfo, -- * Type constraints @@ -233,7 +233,7 @@ initTc :: HscEnv -> Module -> RealSrcSpan -> TcM r - -> IO (Messages DecoratedSDoc, Maybe r) + -> IO (Messages DiagnosticMessage, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) @@ -359,7 +359,7 @@ initTcWithGbl :: HscEnv -> TcGblEnv -> RealSrcSpan -> TcM r - -> IO (Messages DecoratedSDoc, Maybe r) + -> IO (Messages DiagnosticMessage, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this = do { lie_var <- newIORef emptyWC ; errs_var <- newIORef emptyMessages @@ -405,7 +405,7 @@ initTcWithGbl hsc_env gbl_env loc do_this ; return (msgs, final_res) } -initTcInteractive :: HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a) +initTcInteractive :: HscEnv -> TcM a -> IO (Messages DiagnosticMessage, Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside = initTc hsc_env HsSrcFile False @@ -788,7 +788,7 @@ wrapDocLoc doc = do if hasPprDebug dflags then do loc <- getSrcSpanM - return (mkLocMessage SevOutput loc doc) + return (mkLocMessage MCOutput loc doc) else return doc @@ -964,10 +964,10 @@ wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a) -- Reporting errors -getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc)) +getErrsVar :: TcRn (TcRef (Messages DiagnosticMessage)) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef (Messages DecoratedSDoc) -> TcRn a -> TcRn a +setErrsVar :: TcRef (Messages DiagnosticMessage) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) addErr :: SDoc -> TcRn () @@ -997,7 +997,7 @@ checkErr :: Bool -> SDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages DecoratedSDoc -> TcRn () +addMessages :: Messages DiagnosticMessage -> TcRn () addMessages msgs1 = do { errs_var <- getErrsVar ; msgs0 <- readTcRef errs_var ; @@ -1026,55 +1026,43 @@ discardWarnings thing_inside ************************************************************************ -} -mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc) +mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DiagnosticMessage) mkLongErrAt loc msg extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let msg' = pprWithUnitState unit_state msg in - return $ mkLongMsgEnvelope loc printer msg' extra } + return $ mkLongMsgEnvelope ErrorWithoutFlag loc printer msg' extra } -mkDecoratedSDocAt :: SrcSpan +mkDecoratedSDocAt :: DiagnosticReason + -> SrcSpan -> SDoc -- ^ The important part of the message -> SDoc -- ^ The context of the message -> SDoc -- ^ Any supplementary information. - -> TcRn (MsgEnvelope DecoratedSDoc) -mkDecoratedSDocAt loc important context extra + -> TcRn (MsgEnvelope DiagnosticMessage) +mkDecoratedSDocAt reason loc important context extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let f = pprWithUnitState unit_state errDoc = [important, context, extra] - errDoc' = mkDecorated $ map f errDoc + errDoc' = DiagnosticMessage (mkDecorated $ map f errDoc) reason in - return $ mkErr loc printer errDoc' } + return $ mkMsgEnvelope (defaultReasonSeverity reason) loc printer errDoc' } addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () -addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError +addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic -reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM () -reportErrors = mapM_ reportError +reportDiagnostics :: [MsgEnvelope DiagnosticMessage] -> TcM () +reportDiagnostics = mapM_ reportDiagnostic -reportError :: MsgEnvelope DecoratedSDoc -> TcRn () -reportError err - = do { traceTc "Adding error:" (pprLocMsgEnvelope err) ; +reportDiagnostic :: MsgEnvelope DiagnosticMessage -> TcRn () +reportDiagnostic msg + = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ; errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; - writeTcRef errs_var (err `addMessage` msgs) } - -reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcRn () -reportWarning reason err - = do { let warn = makeIntoWarning reason err - -- 'err' was built by mkLongMsgEnvelope or something like that, - -- so it's of error severity. For a warning we downgrade - -- its severity to SevWarning - - ; traceTc "Adding warning:" (pprLocMsgEnvelope warn) - ; errs_var <- getErrsVar - ; (warns, errs) <- partitionMessages <$> readTcRef errs_var - ; writeTcRef errs_var (mkMessages $ (warns `snocBag` warn) `unionBags` errs) } - + writeTcRef errs_var (msg `addMessage` msgs) } ----------------------- checkNoErrs :: TcM r -> TcM r @@ -1247,7 +1235,7 @@ capture_constraints thing_inside ; lie <- readTcRef lie_var ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages DecoratedSDoc) +capture_messages :: TcM r -> TcM (r, Messages DiagnosticMessage) -- capture_messages simply captures and returns the -- errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception! @@ -1417,7 +1405,7 @@ foldAndRecoverM f acc (x:xs) = Just acc' -> foldAndRecoverM f acc' xs } ----------------------- -tryTc :: TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc) +tryTc :: TcRn a -> TcRn (Maybe a, Messages DiagnosticMessage) -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) -- Nothing, if m fails @@ -1516,60 +1504,61 @@ warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn () warnIfFlag warn_flag is_bad msg = do { warn_on <- woptM warn_flag ; when (warn_on && is_bad) $ - addWarn (Reason warn_flag) msg } + addDiagnostic (WarningWithFlag warn_flag) msg } -- | Display a warning if a condition is met. warnIf :: Bool -> SDoc -> TcRn () warnIf is_bad msg - = when is_bad (addWarn NoReason msg) - --- | Display a warning if a condition is met. -warnTc :: WarnReason -> Bool -> SDoc -> TcM () -warnTc reason warn_if_true warn_msg - | warn_if_true = addWarnTc reason warn_msg - | otherwise = return () + = when is_bad (addDiagnostic WarningWithoutFlag msg) -- | Display a warning if a condition is met. -warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM () -warnTcM reason warn_if_true warn_msg - | warn_if_true = addWarnTcM reason warn_msg - | otherwise = return () - --- | Display a warning in the current context. -addWarnTc :: WarnReason -> SDoc -> TcM () -addWarnTc reason msg +diagnosticTc :: DiagnosticReason -> Bool -> SDoc -> TcM () +diagnosticTc reason should_report warn_msg + | should_report = addDiagnosticTc reason warn_msg + | otherwise = return () + +-- | Display a diagnostic if a condition is met. +diagnosticTcM :: DiagnosticReason -> Bool -> (TidyEnv, SDoc) -> TcM () +diagnosticTcM reason should_report warn_msg + | should_report = addDiagnosticTcM reason warn_msg + | otherwise = return () + +-- | Display a diagnostic in the current context. +addDiagnosticTc :: DiagnosticReason -> SDoc -> TcM () +addDiagnosticTc reason msg = do { env0 <- tcInitTidyEnv ; - addWarnTcM reason (env0, msg) } + addDiagnosticTcM reason (env0, msg) } --- | Display a warning in a given context. -addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM () -addWarnTcM reason (env0, msg) +-- | Display a diagnostic in a given context. +addDiagnosticTcM :: DiagnosticReason -> (TidyEnv, SDoc) -> TcM () +addDiagnosticTcM reason (env0, msg) = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo env0 ctxt ; - add_warn reason msg err_info } + add_diagnostic reason msg err_info } --- | Display a warning for the current source location. -addWarn :: WarnReason -> SDoc -> TcRn () -addWarn reason msg = add_warn reason msg Outputable.empty +-- | Display a diagnostic for the current source location. +addDiagnostic :: DiagnosticReason -> SDoc -> TcRn () +addDiagnostic reason msg = add_diagnostic reason msg Outputable.empty --- | Display a warning for a given source location. -addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcRn () -addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty +-- | Display a diagnostic for a given source location. +addDiagnosticAt :: DiagnosticReason -> SrcSpan -> SDoc -> TcRn () +addDiagnosticAt reason loc msg = add_diagnostic_at reason loc msg Outputable.empty --- | Display a warning, with an optional flag, for the current source +-- | Display a diagnostic, with an optional flag, for the current source -- location. -add_warn :: WarnReason -> SDoc -> SDoc -> TcRn () -add_warn reason msg extra_info +add_diagnostic :: DiagnosticReason -> SDoc -> SDoc -> TcRn () +add_diagnostic reason msg extra_info = do { loc <- getSrcSpanM - ; add_warn_at reason loc msg extra_info } + ; add_diagnostic_at reason loc msg extra_info } --- | Display a warning, with an optional flag, for a given location. -add_warn_at :: WarnReason -> SrcSpan -> SDoc -> SDoc -> TcRn () -add_warn_at reason loc msg extra_info +-- | Display a diagnosticTc, with an optional flag, for a given location. +add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn () +add_diagnostic_at reason loc msg extra_info = do { printer <- getPrintUnqualified ; - let { warn = mkLongWarnMsg loc printer - msg extra_info } ; - reportWarning reason warn } + let { dia = mkLongMsgEnvelope reason + loc printer + msg extra_info } ; + reportDiagnostic dia } {- @@ -2112,7 +2101,7 @@ failIfM msg = do let full_msg = (if_loc env <> colon) $$ nest 2 msg dflags <- getDynFlags logger <- getLogger - liftIO (putLogMsg logger dflags NoReason SevFatal + liftIO (putLogMsg logger dflags MCFatal noSrcSpan $ withPprStyle defaultErrStyle full_msg) failM @@ -2147,8 +2136,7 @@ forkM_maybe doc thing_inside let msg = hang (text "forkM failed:" <+> doc) 2 (text (show exn)) liftIO $ putLogMsg logger dflags - NoReason - SevFatal + MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 9a43e69c67..610c31789c 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1102,9 +1102,9 @@ check_valid_theta _ _ _ [] = return () check_valid_theta env ctxt expand theta = do { dflags <- getDynFlags - ; warnTcM (Reason Opt_WarnDuplicateConstraints) - (wopt Opt_WarnDuplicateConstraints dflags && notNull dups) - (dupPredWarn env dups) + ; diagnosticTcM (WarningWithFlag Opt_WarnDuplicateConstraints) + (wopt Opt_WarnDuplicateConstraints dflags && notNull dups) + (dupPredWarn env dups) ; traceTc "check_valid_theta" (ppr theta) ; mapM_ (check_pred_ty env dflags ctxt expand) theta } where @@ -1297,8 +1297,8 @@ checkSimplifiableClassConstraint env dflags ctxt cls tys = do { result <- matchGlobalInst dflags False cls tys ; case result of OneInst { cir_what = what } - -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints) - (simplifiable_constraint_warn what) + -> addDiagnosticTc (WarningWithFlag Opt_WarnSimplifiableClassConstraints) + (simplifiable_constraint_warn what) _ -> return () } where pred = mkClassPred cls tys @@ -2048,7 +2048,7 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) -- (b) failure of injectivity check_branch_compat prev_branches cur_branch | cur_branch `isDominatedBy` prev_branches - = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $ + = do { addDiagnosticAt WarningWithoutFlag (coAxBranchSpan cur_branch) $ inaccessibleCoAxBranch fam_tc cur_branch ; return prev_branches } | otherwise diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 84d4e892c3..7edf599c9f 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -14,25 +14,31 @@ module GHC.Types.Error , unionMessages , MsgEnvelope (..) , WarnMsg + + -- * Classifying Messages + + , MessageClass (..) + , Severity (..) + , mkMCDiagnostic + , Diagnostic (..) + , DiagnosticMessage (..) + , DiagnosticReason (..) + + -- * Rendering Messages + , SDoc , DecoratedSDoc (unDecorated) - , Severity (..) - , RenderableDiagnostic (..) , pprMessageBag , mkDecorated , mkLocMessage , mkLocMessageAnn - , getSeverityColour , getCaretDiagnostic - , makeIntoWarning - -- * Constructing individual errors + -- * Constructing individual diagnostic messages , mkMsgEnvelope , mkPlainMsgEnvelope - , mkErr , mkLongMsgEnvelope - , mkWarnMsg - , mkPlainWarnMsg - , mkLongWarnMsg + , mkShortMsgEnvelope + , defaultReasonSeverity -- * Queries , isErrorMessage , isWarningMessage @@ -65,10 +71,10 @@ We represent the 'Messages' as a single bag of warnings and errors. The reason behind that is that there is a fluid relationship between errors and warnings and we want to be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors -or -XPartialTypeSignatures). For now we rely on the 'Severity' to distinguish between a warning and an -error, although the 'Severity' can be /more/ than just 'SevWarn' and 'SevError', and as such it probably -shouldn't belong to an 'MsgEnvelope' to begin with, as it might potentially lead to the construction of -"impossible states" (e.g. a waning with 'SevInfo', for example). +or -XPartialTypeSignatures). More specifically, every diagnostic has a 'DiagnosticReason', but a warning +'DiagnosticReason' might be associated with 'SevError', in the case of -Werror. + +We rely on the 'Severity' to distinguish between a warning and an error. 'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but in future iterations these can be either parameterised over an 'e' message type (to make type signatures @@ -98,10 +104,10 @@ addMessage x (Messages xs) = Messages (x `consBag` xs) unionMessages :: Messages e -> Messages e -> Messages e unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2) -type WarningMessages = Bag (MsgEnvelope DecoratedSDoc) -type ErrorMessages = Bag (MsgEnvelope DecoratedSDoc) +type WarningMessages = Bag (MsgEnvelope DiagnosticMessage) +type ErrorMessages = Bag (MsgEnvelope DiagnosticMessage) -type WarnMsg = MsgEnvelope DecoratedSDoc +type WarnMsg = MsgEnvelope DiagnosticMessage -- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the invariant that the input '[SDoc]' -- needs to be rendered /decorated/ into its final form, where the typical case would be adding bullets @@ -119,38 +125,83 @@ Note [Rendering Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~ Turning 'Messages' into something that renders nicely for the user is one of the last steps, and it -happens typically at the application boundaries (i.e. from the 'Driver' upwards). +happens typically at the application's boundaries (i.e. from the 'Driver' upwards). -For now (see #18516) this class is very boring as it has only one instance, but the idea is that as +For now (see #18516) this class has few instance, but the idea is that as the more domain-specific types are defined, the more instances we would get. For example, given something like: -data TcRnMessage - = TcRnOutOfScope .. - | .. + data TcRnDiagnostic + = TcRnOutOfScope .. + | .. + + newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic) -We could then define how a 'TcRnMessage' is displayed to the user. Rather than scattering pieces of +We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather than scattering pieces of 'SDoc' around the codebase, we would write once for all: -instance RenderableDiagnostic TcRnMessage where - renderDiagnostic = \case - TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."] - ... + instance Diagnostic TcRnDiagnostic where + diagnosticMessage (TcRnMessage msg) = case diagMessage msg of + TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."] + ... This way, we can easily write generic rendering functions for errors that all they care about is the -knowledge that a given type 'e' has a 'RenderableDiagnostic' constraint. +knowledge that a given type 'e' has a 'Diagnostic' constraint. -} --- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'DecoratedSDoc'. --- For more information, see Note [Rendering Messages]. -class RenderableDiagnostic a where - renderDiagnostic :: a -> DecoratedSDoc +-- | A class identifying a diagnostic. +-- Dictionary.com defines a diagnostic as: +-- +-- \"a message output by a computer diagnosing an error in a computer program, computer system, +-- or component device\". +-- +-- A 'Diagnostic' carries the /actual/ description of the message (which, in GHC's case, it can be +-- an error or a warning) and the /reason/ why such message was generated in the first place. +-- See also Note [Rendering Messages]. +class Diagnostic a where + diagnosticMessage :: a -> DecoratedSDoc + diagnosticReason :: a -> DiagnosticReason + +-- | A generic 'Diagnostic' message, without any further classification or provenance: +-- By looking at a 'DiagnosticMessage' we don't know neither /where/ it was generated nor how to +-- intepret its payload (as it's just a structured document). All we can do is to print it out and +-- look at its 'DiagnosticReason'. +data DiagnosticMessage = DiagnosticMessage + { diagMessage :: !DecoratedSDoc + , diagReason :: !DiagnosticReason + } + +instance Diagnostic DiagnosticMessage where + diagnosticMessage = diagMessage + diagnosticReason = diagReason + +-- | The reason /why/ a 'Diagnostic' was emitted in the first place. Diagnostic messages +-- are born within GHC with a very precise reason, which can be completely statically-computed +-- (i.e. this is an error or a warning no matter what), or influenced by the specific state +-- of the 'DynFlags' at the moment of the creation of a new 'Diagnostic'. For example, a parsing +-- error is /always/ going to be an error, whereas a 'WarningWithoutFlag Opt_WarnUnusedImports' might turn +-- into an error due to '-Werror' or '-Werror=warn-unused-imports'. Interpreting a 'DiagnosticReason' +-- together with its associated 'Severity' gives us the full picture. +data DiagnosticReason + = WarningWithoutFlag + -- ^ Born as a warning. + | WarningWithFlag !WarningFlag + -- ^ Warning was enabled with the flag. + | ErrorWithoutFlag + -- ^ Born as an error. + deriving (Eq, Show) + +instance Outputable DiagnosticReason where + ppr = \case + WarningWithoutFlag -> text "WarningWithoutFlag" + WarningWithFlag wf -> text ("WarningWithFlag " ++ show wf) + ErrorWithoutFlag -> text "ErrorWithoutFlag" -- | An envelope for GHC's facts about a running program, parameterised over the -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics. -- -- To say things differently, GHC emits /diagnostics/ about the running program, each of which is wrapped --- into a 'MsgEnvelope' that carries specific information like where the error happened, its severity, etc. +-- into a 'MsgEnvelope' that carries specific information like where the error happened, etc. -- Finally, multiple 'MsgEnvelope's are aggregated into 'Messages' that are returned to the user. data MsgEnvelope e = MsgEnvelope { errMsgSpan :: SrcSpan @@ -158,102 +209,139 @@ data MsgEnvelope e = MsgEnvelope , errMsgContext :: PrintUnqualified , errMsgDiagnostic :: e , errMsgSeverity :: Severity - , errMsgReason :: WarnReason } deriving Functor -instance RenderableDiagnostic DecoratedSDoc where - renderDiagnostic = id - -data Severity - = SevOutput - | SevFatal - | SevInteractive +-- | The class for a diagnostic message. The main purpose is to classify a message within GHC, +-- to distinguish it from a debug/dump message vs a proper diagnostic, for which we include a 'DiagnosticReason'. +data MessageClass + = MCOutput + | MCFatal + | MCInteractive - | SevDump + | MCDump -- ^ Log message intended for compiler developers -- No file\/line\/column stuff - | SevInfo + | MCInfo -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | SevWarning + | MCDiagnostic Severity DiagnosticReason + -- ^ Diagnostics from the compiler. This constructor + -- is very powerful as it allows the construction + -- of a 'MessageClass' with a completely arbitrary + -- permutation of 'Severity' and 'DiagnosticReason'. As such, + -- users are encouraged to use the 'mkMCDiagnostic' smart constructor instead. + -- Use this constructor directly only if you need to construct and manipulate diagnostic + -- messages directly, for example inside 'GHC.Utils.Error'. In all the other circumstances, + -- /especially/ when emitting compiler diagnostics, use the smart constructor. + deriving (Eq, Show) + +-- | Make a 'MessageClass' for a given 'DiagnosticReason', without consulting the 'DynFlags'. +-- This will not respect -Werror or warning suppression and so is probably wrong +-- for any warning. +mkMCDiagnostic :: DiagnosticReason -> MessageClass +mkMCDiagnostic reason = MCDiagnostic (defaultReasonSeverity reason) reason + +-- | Used to describe warnings and errors +-- o The message has a file\/line\/column heading, +-- plus "warning:" or "error:", +-- added by mkLocMessage +-- o Output is intended for end users +data Severity + = SevWarning | SevError - -- ^ SevWarning and SevError are used for warnings and errors - -- o The message has a file\/line\/column heading, - -- plus "warning:" or "error:", - -- added by mkLocMessags - -- o Output is intended for end users deriving (Eq, Show) +instance Outputable Severity where + ppr = \case + SevWarning -> text "SevWarning" + SevError -> text "SevError" instance ToJson Severity where json s = JSString (show s) -instance Show (MsgEnvelope DecoratedSDoc) where +instance ToJson MessageClass where + json MCOutput = JSString "MCOutput" + json MCFatal = JSString "MCFatal" + json MCInteractive = JSString "MCInteractive" + json MCDump = JSString "MCDump" + json MCInfo = JSString "MCInfo" + json (MCDiagnostic sev reason) = + JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason) + +instance Show (MsgEnvelope DiagnosticMessage) where show = showMsgEnvelope -- | Shows an 'MsgEnvelope'. -showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String +showMsgEnvelope :: Diagnostic a => MsgEnvelope a -> String showMsgEnvelope err = - renderWithContext defaultSDocContext (vcat (unDecorated . renderDiagnostic $ errMsgDiagnostic err)) + renderWithContext defaultSDocContext (vcat (unDecorated . diagnosticMessage $ errMsgDiagnostic err)) pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) -- | Make an unannotated error message with location info. -mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc +mkLocMessage :: MessageClass -> SrcSpan -> SDoc -> SDoc mkLocMessage = mkLocMessageAnn Nothing -- | Make a possibly annotated error message with location info. mkLocMessageAnn :: Maybe String -- ^ optional annotation - -> Severity -- ^ severity + -> MessageClass -- ^ What kind of message? -> SrcSpan -- ^ location - -> SDoc -- ^ message + -> SDoc -- ^ message -> SDoc -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "<no location info>". -mkLocMessageAnn ann severity locn msg +mkLocMessageAnn ann msg_class locn msg = sdocOption sdocColScheme $ \col_scheme -> let locn' = sdocOption sdocErrorSpans $ \case True -> ppr locn False -> ppr (srcSpanStart locn) - sevColour = getSeverityColour severity col_scheme + msgColour = getMessageClassColour msg_class col_scheme -- Add optional information optAnn = case ann of Nothing -> text "" - Just i -> text " [" <> coloured sevColour (text i) <> text "]" + Just i -> text " [" <> coloured msgColour (text i) <> text "]" -- Add prefixes, like Foo.hs:34: warning: -- <the warning message> header = locn' <> colon <+> - coloured sevColour sevText <> optAnn + coloured msgColour msgText <> optAnn in coloured (Col.sMessage col_scheme) (hang (coloured (Col.sHeader col_scheme) header) 4 msg) where - sevText = - case severity of - SevWarning -> text "warning:" - SevError -> text "error:" - SevFatal -> text "fatal:" - _ -> empty - -getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour -getSeverityColour SevWarning = Col.sWarning -getSeverityColour SevError = Col.sError -getSeverityColour SevFatal = Col.sFatal -getSeverityColour _ = const mempty - -getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc + msgText = + case msg_class of + MCDiagnostic SevError _reason -> text "error:" + MCDiagnostic SevWarning _reason -> text "warning:" + MCFatal -> text "fatal:" + _ -> empty + +-- | Computes a severity from a reason in the absence of DynFlags. This will likely +-- be wrong in the presence of -Werror. It will be removed in the context of #18516. +defaultReasonSeverity :: DiagnosticReason -> Severity +defaultReasonSeverity = \case + WarningWithoutFlag -> SevWarning + WarningWithFlag _flag -> SevWarning + ErrorWithoutFlag -> SevError + +getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour +getMessageClassColour (MCDiagnostic SevError _reason) = Col.sError +getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning +getMessageClassColour MCFatal = Col.sFatal +getMessageClassColour _ = const mempty + +getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic severity (RealSrcSpan span _) = +getCaretDiagnostic msg_class (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = @@ -286,7 +374,7 @@ getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic Nothing = empty caretDiagnostic (Just srcLineWithNewline) = sdocOption sdocColScheme$ \col_scheme -> - let sevColour = getSeverityColour severity col_scheme + let sevColour = getMessageClassColour msg_class col_scheme marginColour = Col.sMargin col_scheme in coloured marginColour (text marginSpace) <> @@ -327,61 +415,79 @@ getCaretDiagnostic severity (RealSrcSpan span _) = | otherwise = "" caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis -makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e -makeIntoWarning reason err = err - { errMsgSeverity = SevWarning - , errMsgReason = reason } - -- -- Creating MsgEnvelope(s) -- -mk_err_msg - :: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e -mk_err_msg sev locn print_unqual err +mkMsgEnvelope + :: Diagnostic e + => Severity + -> SrcSpan + -> PrintUnqualified + -> e + -> MsgEnvelope e +mkMsgEnvelope sev locn print_unqual err = MsgEnvelope { errMsgSpan = locn , errMsgContext = print_unqual , errMsgDiagnostic = err , errMsgSeverity = sev - , errMsgReason = NoReason } - -mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e -mkErr = mk_err_msg SevError - -mkLongMsgEnvelope, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc --- ^ A long (multi-line) error message -mkMsgEnvelope, mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc --- ^ A short (one-line) error message -mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc --- ^ Variant that doesn't care about qualified/unqualified names - -mkLongMsgEnvelope locn unqual msg extra = mk_err_msg SevError locn unqual (mkDecorated [msg,extra]) -mkMsgEnvelope locn unqual msg = mk_err_msg SevError locn unqual (mkDecorated [msg]) -mkPlainMsgEnvelope locn msg = mk_err_msg SevError locn alwaysQualify (mkDecorated [msg]) -mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual (mkDecorated [msg,extra]) -mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual (mkDecorated [msg]) -mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify (mkDecorated [msg]) + } + +-- | A long (multi-line) diagnostic message. +-- The 'Severity' will be calculated out of the 'DiagnosticReason', and will likely be +-- incorrect in the presence of '-Werror'. +mkLongMsgEnvelope :: DiagnosticReason + -> SrcSpan + -> PrintUnqualified + -> SDoc + -> SDoc + -> MsgEnvelope DiagnosticMessage +mkLongMsgEnvelope rea locn unqual msg extra = + mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings + locn unqual (DiagnosticMessage (mkDecorated [msg,extra]) rea) + +-- | A short (one-line) diagnostic message. +-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'. +mkShortMsgEnvelope :: DiagnosticReason + -> SrcSpan + -> PrintUnqualified + -> SDoc + -> MsgEnvelope DiagnosticMessage +mkShortMsgEnvelope rea locn unqual msg = + mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings + locn unqual (DiagnosticMessage (mkDecorated [msg]) rea) + +-- | Variant that doesn't care about qualified/unqualified names. +-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'. +mkPlainMsgEnvelope :: DiagnosticReason + -> SrcSpan + -> SDoc + -> MsgEnvelope DiagnosticMessage +mkPlainMsgEnvelope rea locn msg = + mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings + locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea) -- -- Queries -- -isErrorMessage :: MsgEnvelope e -> Bool -isErrorMessage = (== SevError) . errMsgSeverity +isErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool +isErrorMessage MsgEnvelope { errMsgSeverity = SevError } = True +isErrorMessage _ = False -isWarningMessage :: MsgEnvelope e -> Bool +isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool isWarningMessage = not . isErrorMessage -errorsFound :: Messages e -> Bool +errorsFound :: Diagnostic e => Messages e -> Bool errorsFound (Messages msgs) = any isErrorMessage msgs -getWarningMessages :: Messages e -> Bag (MsgEnvelope e) +getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e) getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs -getErrorMessages :: Messages e -> Bag (MsgEnvelope e) +getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e) getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs -- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the -- second the errors. -partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) +partitionMessages :: Diagnostic e => Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) partitionMessages (Messages xs) = partitionBag isWarningMessage xs diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs index a8c4733420..b8a1e932e0 100644 --- a/compiler/GHC/Types/SourceError.hs +++ b/compiler/GHC/Types/SourceError.hs @@ -27,7 +27,7 @@ srcErrorMessages (SourceError msgs) = msgs throwErrors :: MonadIO io => ErrorMessages -> io a throwErrors = liftIO . throwIO . mkSrcErr -throwOneError :: MonadIO io => MsgEnvelope DecoratedSDoc -> io a +throwOneError :: MonadIO io => MsgEnvelope DiagnosticMessage -> io a throwOneError = throwErrors . unitBag -- | A source error is an error that is caused by one or more errors in the diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index e3a5ec6ed4..aba5e64357 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -17,6 +17,7 @@ module GHC.Utils.Error ( -- * Messages WarnMsg, MsgEnvelope(..), + MessageClass(..), SDoc, DecoratedSDoc(unDecorated), Messages, ErrorMessages, WarningMessages, @@ -29,10 +30,9 @@ module GHC.Utils.Error ( formatBulleted, -- ** Construction - emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, makeIntoWarning, - mkMsgEnvelope, mkPlainMsgEnvelope, mkErr, mkLongMsgEnvelope, mkWarnMsg, - mkPlainWarnMsg, - mkLongWarnMsg, + emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, + mkMsgEnvelope, mkPlainMsgEnvelope, mkLongMsgEnvelope, + mkMCDiagnostic, -- * Utilities doIfSet, doIfSet_dyn, @@ -120,16 +120,17 @@ formatBulleted ctx (unDecorated -> docs) msgs = filter (not . Outputable.isEmpty ctx) docs starred = (bullet<+>) -pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc] +pprMsgEnvelopeBagWithLoc :: Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ] -pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc +pprLocMsgEnvelope :: Diagnostic e => MsgEnvelope e -> SDoc pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s , errMsgDiagnostic = e , errMsgSeverity = sev , errMsgContext = unqual }) = sdocWithContext $ \ctx -> - withErrStyle unqual $ mkLocMessage sev s (formatBulleted ctx $ renderDiagnostic e) + 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 @@ -170,15 +171,17 @@ ifVerbose dflags val act errorMsg :: Logger -> DynFlags -> SDoc -> IO () errorMsg logger dflags msg - = putLogMsg logger dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg + = putLogMsg logger dflags (mkMCDiagnostic ErrorWithoutFlag) noSrcSpan $ + withPprStyle defaultErrStyle msg warningMsg :: Logger -> DynFlags -> SDoc -> IO () warningMsg logger dflags msg - = putLogMsg logger dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg + = putLogMsg logger dflags (mkMCDiagnostic WarningWithoutFlag) noSrcSpan $ + withPprStyle defaultErrStyle msg fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO () fatalErrorMsg logger dflags msg = - putLogMsg logger dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg + putLogMsg logger dflags MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg @@ -336,12 +339,13 @@ printOutputForUser logger dflags print_unqual msg logInfo :: Logger -> DynFlags -> SDoc -> IO () logInfo logger dflags msg - = putLogMsg logger dflags NoReason SevInfo noSrcSpan msg + = putLogMsg logger dflags MCInfo noSrcSpan msg -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' logOutput :: Logger -> DynFlags -> SDoc -> IO () logOutput logger dflags msg - = putLogMsg logger dflags NoReason SevOutput noSrcSpan msg + = putLogMsg logger dflags MCOutput noSrcSpan msg + prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs index dec3f1225e..fbbacb2b48 100644 --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -66,8 +66,7 @@ import Control.Concurrent.MVar import System.IO.Unsafe type LogAction = DynFlags - -> WarnReason - -> Severity + -> MessageClass -> SrcSpan -> SDoc -> IO () @@ -181,8 +180,8 @@ makeThreadSafe logger = do with_lock :: forall a. IO a -> IO a with_lock act = withMVar lock (const act) - log action dflags reason sev loc doc = - with_lock (action dflags reason sev loc doc) + log action dflags msg_class loc doc = + with_lock (action dflags msg_class loc doc) dmp action dflags sty opts str fmt doc = with_lock (action dflags sty opts str fmt doc) @@ -199,7 +198,7 @@ makeThreadSafe logger = do -- See Note [JSON Error Messages] -- jsonLogAction :: LogAction -jsonLogAction dflags reason severity srcSpan msg +jsonLogAction dflags msg_class srcSpan msg = defaultLogActionHPutStrDoc dflags True stdout (withPprStyle (PprCode CStyle) (doc $$ text "")) @@ -208,56 +207,54 @@ jsonLogAction dflags reason severity srcSpan msg doc = renderJSON $ JSObject [ ( "span", json srcSpan ) , ( "doc" , JSString str ) - , ( "severity", json severity ) - , ( "reason" , json reason ) + , ( "messageClass", json msg_class ) ] - defaultLogAction :: LogAction -defaultLogAction dflags reason severity srcSpan msg - | dopt Opt_D_dump_json dflags = jsonLogAction dflags reason severity srcSpan msg - | otherwise = case severity of - SevOutput -> printOut msg - SevDump -> printOut (msg $$ blankLine) - SevInteractive -> putStrSDoc msg - SevInfo -> printErrs msg - SevFatal -> printErrs msg - SevWarning -> printWarns - SevError -> printWarns +defaultLogAction dflags msg_class srcSpan msg + | dopt Opt_D_dump_json dflags = jsonLogAction dflags msg_class srcSpan msg + | otherwise = case msg_class of + MCOutput -> printOut msg + MCDump -> printOut (msg $$ blankLine) + MCInteractive -> putStrSDoc msg + MCInfo -> printErrs msg + MCFatal -> printErrs msg + MCDiagnostic sev rea -> printDiagnostics sev rea where printOut = defaultLogActionHPrintDoc dflags False stdout printErrs = defaultLogActionHPrintDoc dflags False stderr putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout -- Pretty print the warning flag, if any (#10752) - message = mkLocMessageAnn flagMsg severity srcSpan msg + message sev rea = mkLocMessageAnn (flagMsg sev rea) msg_class srcSpan msg - printWarns = do + printDiagnostics severity reason = do hPutChar stderr '\n' caretDiagnostic <- if gopt Opt_DiagnosticsShowCaret dflags - then getCaretDiagnostic severity srcSpan + then getCaretDiagnostic msg_class srcSpan else pure empty printErrs $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) - (message $+$ caretDiagnostic) + (message severity reason $+$ caretDiagnostic) -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of -- each unicode char. - flagMsg = - case reason of - NoReason -> Nothing - Reason wflag -> do - spec <- flagSpecOf wflag - return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) - ErrReason Nothing -> - return "-Werror" - ErrReason (Just wflag) -> do - spec <- flagSpecOf wflag - return $ - "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ - ", -Werror=" ++ flagSpecName spec + flagMsg :: Severity -> DiagnosticReason -> Maybe String + flagMsg SevError WarningWithoutFlag = Just "-Werror" + flagMsg SevError (WarningWithFlag wflag) = do + spec <- flagSpecOf wflag + return $ + "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ + ", -Werror=" ++ flagSpecName spec + flagMsg SevError ErrorWithoutFlag = Nothing + flagMsg SevWarning WarningWithoutFlag = Nothing + flagMsg SevWarning (WarningWithFlag wflag) = do + spec <- flagSpecOf wflag + return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) + flagMsg SevWarning ErrorWithoutFlag = + panic "SevWarning with ErrorWithoutFlag" warnFlagGrp flag | gopt Opt_ShowWarnGroups dflags = @@ -330,10 +327,10 @@ dumpSDocWithStyle dumps log_action sty dflags flag hdr doc = -- write the dump to stdout writeDump Nothing = do - let (doc', severity) - | null hdr = (doc, SevOutput) - | otherwise = (mkDumpDoc hdr doc, SevDump) - log_action dflags NoReason severity noSrcSpan (withPprStyle sty doc') + let (doc', msg_class) + | null hdr = (doc, MCOutput) + | otherwise = (mkDumpDoc hdr doc, MCDump) + log_action dflags msg_class noSrcSpan (withPprStyle sty doc') -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a @@ -404,8 +401,7 @@ chooseDumpFile dflags flag doDump :: Logger -> DynFlags -> String -> SDoc -> IO () doDump logger dflags hdr doc = putLogMsg logger dflags - NoReason - SevDump + MCDump noSrcSpan (withPprStyle defaultDumpStyle (mkDumpDoc hdr doc)) diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index a028f4e479..a97200c5c3 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -577,10 +577,10 @@ resetLastErrorLocations = do ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction ghciLogAction lastErrLocations old_log_action - dflags flag severity srcSpan msg = do - old_log_action dflags flag severity srcSpan msg - case severity of - SevError -> case srcSpan of + dflags msg_class srcSpan msg = do + old_log_action dflags msg_class srcSpan msg + case msg_class of + MCDiagnostic SevError _reason -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () @@ -3188,7 +3188,7 @@ showCmd str = do , action "bindings" $ showBindings , action "linker" $ do msg <- liftIO $ Loader.showLoaderState (hscInterp hsc_env) - putLogMsgM NoReason SevDump noSrcSpan msg + putLogMsgM MCDump noSrcSpan msg , action "breaks" $ showBkptTable , action "context" $ showContext , action "packages" $ showUnits diff --git a/ghc/Main.hs b/ghc/Main.hs index 9da5469b8a..2873cba4ad 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -23,7 +23,7 @@ import GHC.Driver.CmdLine import GHC.Driver.Env import GHC.Driver.Errors import GHC.Driver.Phases -import GHC.Driver.Session hiding (WarnReason(..)) +import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Pipeline ( oneShot, compileFile ) import GHC.Driver.MakeFile ( doMkDependHS ) diff --git a/testsuite/tests/deriving/should_compile/T14094.stderr b/testsuite/tests/deriving/should_compile/T14094.stderr index b323a775f5..3457a007f3 100644 --- a/testsuite/tests/deriving/should_compile/T14094.stderr +++ b/testsuite/tests/deriving/should_compile/T14094.stderr @@ -1,10 +1,10 @@ T14094.hs:12:1: warning: [-Wmissing-methods (in -Wdefault)] - • No explicit associated type or default declaration for ‘T’ + • No explicit associated type or default declaration for ‘D’ • In the instance declaration for ‘C Int’ T14094.hs:12:1: warning: [-Wmissing-methods (in -Wdefault)] - • No explicit associated type or default declaration for ‘D’ + • No explicit associated type or default declaration for ‘T’ • In the instance declaration for ‘C Int’ T14094.hs:12:10: warning: [-Wmissing-methods (in -Wdefault)] @@ -13,7 +13,8 @@ T14094.hs:12:10: warning: [-Wmissing-methods (in -Wdefault)] • In the instance declaration for ‘C Int’ T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)] - • No explicit associated type or default declaration for ‘T’ + • No explicit implementation for + ‘m’ • In the instance declaration for ‘C Bool’ T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)] @@ -21,6 +22,6 @@ T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)] • In the instance declaration for ‘C Bool’ T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)] - • No explicit implementation for - ‘m’ + • No explicit associated type or default declaration for ‘T’ • In the instance declaration for ‘C Bool’ + diff --git a/testsuite/tests/driver/T16167.stdout b/testsuite/tests/driver/T16167.stdout index 4cd1e64b6e..5416b95894 100644 --- a/testsuite/tests/driver/T16167.stdout +++ b/testsuite/tests/driver/T16167.stdout @@ -1 +1 @@ -{"span": {"file": "T16167.hs","startLine": 1,"startCol": 8,"endLine": 1,"endCol": 9},"doc": "parse error on input \u2018f\u2019","severity": "SevError","reason": null} +{"span": {"file": "T16167.hs","startLine": 1,"startCol": 8,"endLine": 1,"endCol": 9},"doc": "parse error on input \u2018f\u2019","messageClass": "MCDiagnostic SevError ErrorWithoutFlag"} diff --git a/testsuite/tests/driver/json.stderr b/testsuite/tests/driver/json.stderr index 61a55e09d0..cb34abd7ac 100644 --- a/testsuite/tests/driver/json.stderr +++ b/testsuite/tests/driver/json.stderr @@ -1 +1 @@ -{"span": {"file": "json.hs","startLine": 6,"startCol": 7,"endLine": 6,"endCol": 8},"doc": "\u2022 No instance for (Num (a -> a)) arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","severity": "SevError","reason": null} +{"span": {"file": "json.hs","startLine": 6,"startCol": 7,"endLine": 6,"endCol": 8},"doc": "\u2022 No instance for (Num (a -> a)) arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass": "MCDiagnostic SevError ErrorWithoutFlag"} diff --git a/testsuite/tests/driver/json2.stderr b/testsuite/tests/driver/json2.stderr index 55053266e1..17d072363d 100644 --- a/testsuite/tests/driver/json2.stderr +++ b/testsuite/tests/driver/json2.stderr @@ -1 +1 @@ -{"span": null,"doc": "TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [base-4.13.0.0, ghc-bignum-1.0, ghc-prim-0.7.0]","severity": "SevOutput","reason": null} +{"span": null,"doc": "TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [base-4.13.0.0, ghc-bignum-1.0, ghc-prim-0.7.0]","messageClass": "MCOutput"} diff --git a/testsuite/tests/driver/werror.stderr b/testsuite/tests/driver/werror.stderr index 791c74352b..7af5fb086f 100644 --- a/testsuite/tests/driver/werror.stderr +++ b/testsuite/tests/driver/werror.stderr @@ -2,23 +2,23 @@ werror.hs:6:1: error: [-Wmissing-signatures (in -Wall), -Werror=missing-signatures] Top-level binding with no type signature: main :: IO () +werror.hs:7:13: error: [-Wunused-local-binds (in -Wextra, -Wunused-binds), -Werror=unused-local-binds] + Defined but not used: ‘main’ + werror.hs:7:13: error: [-Wname-shadowing (in -Wall), -Werror=name-shadowing] This binding for ‘main’ shadows the existing binding defined at werror.hs:6:1 -werror.hs:7:13: error: [-Wunused-local-binds (in -Wextra, -Wunused-binds), -Werror=unused-local-binds] - Defined but not used: ‘main’ - werror.hs:8:1: error: [-Wtabs (in -Wdefault), -Werror=tabs] Tab character found here. Please use spaces instead. -werror.hs:10:1: error: [-Wunused-top-binds (in -Wextra, -Wunused-binds), -Werror=unused-top-binds] - Defined but not used: ‘f’ - werror.hs:10:1: error: [-Wmissing-signatures (in -Wall), -Werror=missing-signatures] Top-level binding with no type signature: f :: [a1] -> [a2] +werror.hs:10:1: error: [-Wunused-top-binds (in -Wextra, -Wunused-binds), -Werror=unused-top-binds] + Defined but not used: ‘f’ + werror.hs:10:1: error: [-Wincomplete-patterns (in -Wextra), -Werror=incomplete-patterns] Pattern match(es) are non-exhaustive In an equation for ‘f’: Patterns of type ‘[a]’ not matched: (_:_) diff --git a/testsuite/tests/ffi/should_compile/T1357.stderr b/testsuite/tests/ffi/should_compile/T1357.stderr index 0a91e883f8..9980c89e7a 100644 --- a/testsuite/tests/ffi/should_compile/T1357.stderr +++ b/testsuite/tests/ffi/should_compile/T1357.stderr @@ -1,3 +1,5 @@ T1357.hs:5:1: warning: [-Wdodgy-foreign-imports (in -Wdefault)] possible missing & in foreign import of FunPtr + When checking declaration: + foreign import ccall safe "f" f :: FunPtr (Int -> IO ()) diff --git a/testsuite/tests/ghc-api/T7478/T7478.hs b/testsuite/tests/ghc-api/T7478/T7478.hs index 87739ec110..dbea3f9547 100644 --- a/testsuite/tests/ghc-api/T7478/T7478.hs +++ b/testsuite/tests/ghc-api/T7478/T7478.hs @@ -14,9 +14,10 @@ import qualified GHC.Driver.Ppr as GHC import GHC.Driver.Monad (liftIO) import GHC.Utils.Outputable (PprStyle, queryQual) import GHC.Unit.State +import GHC.Types.Error compileInGhc :: [FilePath] -- ^ Targets - -> (String -> IO ()) -- ^ handler for each SevOutput message + -> (String -> IO ()) -- ^ handler for each MCOutput message -> Ghc () compileInGhc targets handlerOutput = do -- Set flags @@ -47,9 +48,9 @@ compileInGhc targets handlerOutput = do TargetFile file Nothing -> file _ -> error "fileFromTarget: not a known target" - collectSrcError handlerOutput flags _ SevOutput _srcspan msg + collectSrcError handlerOutput flags MCOutput _srcspan msg = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg - collectSrcError _ _ _ _ _ _ + collectSrcError _ _ _ _ _ = return () main :: IO () diff --git a/testsuite/tests/indexed-types/should_compile/Simple2.stderr b/testsuite/tests/indexed-types/should_compile/Simple2.stderr index c43280e79d..8c1235ffc7 100644 --- a/testsuite/tests/indexed-types/should_compile/Simple2.stderr +++ b/testsuite/tests/indexed-types/should_compile/Simple2.stderr @@ -18,11 +18,11 @@ Simple2.hs:29:10: warning: [-Wmissing-methods (in -Wdefault)] • In the instance declaration for ‘C3 Bool’ Simple2.hs:39:1: warning: [-Wmissing-methods (in -Wdefault)] - • No explicit associated type or default declaration for ‘S3’ + • No explicit associated type or default declaration for ‘S3n’ • In the instance declaration for ‘C3 Float’ Simple2.hs:39:1: warning: [-Wmissing-methods (in -Wdefault)] - • No explicit associated type or default declaration for ‘S3n’ + • No explicit associated type or default declaration for ‘S3’ • In the instance declaration for ‘C3 Float’ Simple2.hs:39:10: warning: [-Wmissing-methods (in -Wdefault)] diff --git a/testsuite/tests/indexed-types/should_compile/T16356_Compile2.stderr b/testsuite/tests/indexed-types/should_compile/T16356_Compile2.stderr index bda837dd87..41fe7794b8 100644 --- a/testsuite/tests/indexed-types/should_compile/T16356_Compile2.stderr +++ b/testsuite/tests/indexed-types/should_compile/T16356_Compile2.stderr @@ -1,9 +1,9 @@ T16356_Compile2.hs:10:11: warning: [-Wunused-type-patterns] - Defined but not used on the right hand side: type variable ‘j’ + Defined but not used on the right hand side: type variable ‘a’ T16356_Compile2.hs:10:11: warning: [-Wunused-type-patterns] - Defined but not used on the right hand side: type variable ‘a’ + Defined but not used on the right hand side: type variable ‘j’ T16356_Compile2.hs:13:15: warning: [-Wunused-type-patterns] Defined but not used on the right hand side: type variable ‘j’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr index 9599cddcba..a5cc4e8197 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr @@ -1,11 +1,12 @@ [1 of 2] Compiling OverloadedRecFldsFail11_A ( OverloadedRecFldsFail11_A.hs, OverloadedRecFldsFail11_A.o ) [2 of 2] Compiling Main ( overloadedrecfldsfail11.hs, overloadedrecfldsfail11.o ) -overloadedrecfldsfail11.hs:5:15: error: [-Wdeprecations (in -Wdefault), -Werror=deprecations] - In the use of ‘foo’ (imported from OverloadedRecFldsFail11_A): - "Warning on a record field" - overloadedrecfldsfail11.hs:5:15: error: [-Wambiguous-fields (in -Wdefault), -Werror=ambiguous-fields] The field ‘foo’ belonging to type S is ambiguous. This will not be supported by -XDuplicateRecordFields in future releases of GHC. You can use a qualified import or explicit case analysis to resolve the ambiguity. + +overloadedrecfldsfail11.hs:5:15: error: [-Wdeprecations (in -Wdefault), -Werror=deprecations] + In the use of ‘foo’ (imported from OverloadedRecFldsFail11_A): + "Warning on a record field" + diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr index fe8ac81ef9..be3d3d6f8d 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr @@ -9,15 +9,15 @@ overloadedrecfldsfail12.hs:10:20: error: [-Wdeprecations (in -Wdefault), -Werror In the use of ‘bar’ (imported from OverloadedRecFldsFail12_A): "Deprecated bar" -overloadedrecfldsfail12.hs:13:5: error: [-Wdeprecations (in -Wdefault), -Werror=deprecations] - In the use of ‘foo’ (imported from OverloadedRecFldsFail12_A): - "Deprecated foo" - overloadedrecfldsfail12.hs:13:5: error: [-Wambiguous-fields (in -Wdefault), -Werror=ambiguous-fields] The field ‘foo’ belonging to type T is ambiguous. This will not be supported by -XDuplicateRecordFields in future releases of GHC. You can use a qualified import or explicit case analysis to resolve the ambiguity. +overloadedrecfldsfail12.hs:13:5: error: [-Wdeprecations (in -Wdefault), -Werror=deprecations] + In the use of ‘foo’ (imported from OverloadedRecFldsFail12_A): + "Deprecated foo" + overloadedrecfldsfail12.hs:16:5: error: [-Wambiguous-fields (in -Wdefault), -Werror=ambiguous-fields] The field ‘foo’ belonging to type S is ambiguous. This will not be supported by -XDuplicateRecordFields in future releases of GHC. diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr index 7a0ad230f4..285060c0c9 100644 --- a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr @@ -34,7 +34,7 @@ SplicesUsed.hs:10:16: warning: [-Wpartial-type-signatures (in -Wdefault)] In the type signature: charA :: a -> (_) SplicesUsed.hs:13:13: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘[a]’ + • Found type wildcard ‘_’ standing for ‘a -> Bool’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] at SplicesUsed.hs:14:1-16 @@ -50,7 +50,7 @@ SplicesUsed.hs:13:13: warning: [-Wpartial-type-signatures (in -Wdefault)] In the type signature: filter' :: (_ -> _ -> _) SplicesUsed.hs:13:13: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘a -> Bool’ + • Found type wildcard ‘_’ standing for ‘[a]’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] at SplicesUsed.hs:14:1-16 @@ -58,26 +58,27 @@ SplicesUsed.hs:13:13: warning: [-Wpartial-type-signatures (in -Wdefault)] In the type signature: filter' :: (_ -> _ -> _) SplicesUsed.hs:16:2: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘a -> a -> Bool’ + • Found extra-constraints wildcard standing for ‘Eq a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: Eq a => a -> a -> Bool at SplicesUsed.hs:16:2-11 • In the type signature: foo :: _ => _ SplicesUsed.hs:16:2: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found extra-constraints wildcard standing for ‘Eq a’ + • Found type wildcard ‘_’ standing for ‘a -> a -> Bool’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: Eq a => a -> a -> Bool at SplicesUsed.hs:16:2-11 • In the type signature: foo :: _ => _ SplicesUsed.hs:18:2: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_a’ standing for ‘Bool’ + • In the type signature: bar :: _a -> _b -> (_a, _b) + +SplicesUsed.hs:18:2: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_b’ standing for ‘w’ Where: ‘w’ is a rigid type variable bound by the inferred type of bar :: Bool -> w -> (Bool, w) at SplicesUsed.hs:18:2-11 • In the type signature: bar :: _a -> _b -> (_a, _b) -SplicesUsed.hs:18:2: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_a’ standing for ‘Bool’ - • In the type signature: bar :: _a -> _b -> (_a, _b) diff --git a/testsuite/tests/partial-sigs/should_compile/T14643.stderr b/testsuite/tests/partial-sigs/should_compile/T14643.stderr index e2dd144bd3..9c56cb629f 100644 --- a/testsuite/tests/partial-sigs/should_compile/T14643.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T14643.stderr @@ -1,8 +1,9 @@ T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found extra-constraints wildcard standing for ‘()’ - • In the type signature: ag :: (Num a, _) => a -> a + • In the type signature: af :: (Num a, _) => a -> a T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found extra-constraints wildcard standing for ‘()’ - • In the type signature: af :: (Num a, _) => a -> a + • In the type signature: ag :: (Num a, _) => a -> a + diff --git a/testsuite/tests/partial-sigs/should_compile/T16728a.stderr b/testsuite/tests/partial-sigs/should_compile/T16728a.stderr index a23c189c4b..2c7e597623 100644 --- a/testsuite/tests/partial-sigs/should_compile/T16728a.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T16728a.stderr @@ -7,7 +7,7 @@ T16728a.hs:4:22: warning: [-Wpartial-type-signatures (in -Wdefault)] h :: a -> w at T16728a.hs:(5,1)-(7,9) • In the type ‘a -> _’ - In the type signature: h :: forall a. a -> _ + In the type signature: g :: forall a. a -> _ T16728a.hs:4:22: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘w’ @@ -17,4 +17,5 @@ T16728a.hs:4:22: warning: [-Wpartial-type-signatures (in -Wdefault)] h :: a -> w at T16728a.hs:(5,1)-(7,9) • In the type ‘a -> _’ - In the type signature: g :: forall a. a -> _ + In the type signature: h :: forall a. a -> _ + diff --git a/testsuite/tests/partial-sigs/should_compile/T16728b.stderr b/testsuite/tests/partial-sigs/should_compile/T16728b.stderr index 9948e78198..84d10c1f45 100644 --- a/testsuite/tests/partial-sigs/should_compile/T16728b.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T16728b.stderr @@ -1,13 +1,14 @@ T16728b.hs:4:22: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Bool’ - • In the type ‘a -> _’ - In the type signature: h :: forall a. a -> _ - -T16728b.hs:4:22: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘a’ Where: ‘a’ is a rigid type variable bound by the inferred type of g :: a -> a at T16728b.hs:4:14 • In the type ‘a -> _’ In the type signature: g :: forall a. a -> _ + +T16728b.hs:4:22: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Bool’ + • In the type ‘a -> _’ + In the type signature: h :: forall a. a -> _ + diff --git a/testsuite/tests/warnings/should_compile/T10637/T10637.stderr b/testsuite/tests/warnings/should_compile/T10637/T10637.stderr index 0778bed810..7be59d5f2b 100644 --- a/testsuite/tests/warnings/should_compile/T10637/T10637.stderr +++ b/testsuite/tests/warnings/should_compile/T10637/T10637.stderr @@ -1,3 +1,3 @@ -T10637.hs:3:23: - warning: {-# SOURCE #-} unnecessary in import of ‘A’ +T10637.hs:3:23: warning: + {-# SOURCE #-} unnecessary in import of ‘A’ |