summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlfredo Di Napoli <alfredo@well-typed.com>2021-03-01 09:27:54 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-04-01 16:13:23 -0400
commit15b6c9f920d8f60ebfef4580ec7e8f063799a83a (patch)
tree7e40890412df649c043881b57d44e6a157f4108c
parentd44e42a26e54857cc6174f2bb7dc86cc41fcd249 (diff)
downloadhaskell-15b6c9f920d8f60ebfef4580ec7e8f063799a83a.tar.gz
Compute Severity of diagnostics at birth
This commit further expand on the design for #18516 by getting rid of the `defaultReasonSeverity` in favour of a function called `diagReasonSeverity` which correctly takes the `DynFlags` as input. The idea is to compute the `Severity` and the `DiagnosticReason` of each message "at birth", without doing any later re-classifications, which are potentially error prone, as the `DynFlags` might evolve during the course of the program. In preparation for a proper refactoring, now `pprWarning` from the Parser.Ppr module has been renamed to `mkParserWarn`, which now takes a `DynFlags` as input. We also get rid of the reclassification we were performing inside `printOrThrowWarnings`. Last but not least, this commit removes the need for reclassify inside GHC.Tc.Errors, and also simplifies the implementation of `maybeReportError`. Update Haddock submodule
-rw-r--r--compiler/GHC.hs12
-rw-r--r--compiler/GHC/Core/Lint.hs2
-rw-r--r--compiler/GHC/Core/Opt/Monad.hs3
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs3
-rw-r--r--compiler/GHC/Driver/Backpack.hs6
-rw-r--r--compiler/GHC/Driver/Env.hs4
-rw-r--r--compiler/GHC/Driver/Errors.hs53
-rw-r--r--compiler/GHC/Driver/Main.hs67
-rw-r--r--compiler/GHC/Driver/Make.hs34
-rw-r--r--compiler/GHC/Driver/MakeFile.hs2
-rw-r--r--compiler/GHC/Driver/Monad.hs4
-rw-r--r--compiler/GHC/Driver/Pipeline.hs4
-rw-r--r--compiler/GHC/HsToCore/Monad.hs7
-rw-r--r--compiler/GHC/Iface/Rename.hs3
-rw-r--r--compiler/GHC/Linker/Loader.hs2
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs49
-rw-r--r--compiler/GHC/Parser/Header.hs9
-rw-r--r--compiler/GHC/Stg/Lint.hs47
-rw-r--r--compiler/GHC/SysTools/Process.hs2
-rw-r--r--compiler/GHC/Tc/Errors.hs360
-rw-r--r--compiler/GHC/Tc/Module.hs4
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs9
-rw-r--r--compiler/GHC/Types/Error.hs106
-rw-r--r--compiler/GHC/Utils/Error.hs109
-rw-r--r--testsuite/tests/regalloc/regalloc_unit_tests.hs4
-rw-r--r--testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr2
-rw-r--r--utils/check-exact/Parsers.hs8
-rw-r--r--utils/check-exact/Preprocess.hs2
m---------utils/haddock0
29 files changed, 465 insertions, 452 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index f77ab69532..4ba5e9b68a 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -907,8 +907,8 @@ checkNewInteractiveDynFlags logger dflags0 = do
-- We currently don't support use of StaticPointers in expressions entered on
-- the REPL. See #12356.
if xopt LangExt.StaticPointers dflags0
- then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag
- [mkPlainMsgEnvelope Session.WarningWithoutFlag interactiveSrcSpan
+ then do liftIO $ printOrThrowDiagnostics logger dflags0 $ listToBag
+ [mkPlainMsgEnvelope dflags0 Session.WarningWithoutFlag interactiveSrcSpan
$ text "StaticPointers is not supported in GHCi interactive expressions."]
return $ xopt_unset dflags0 LangExt.StaticPointers
else return dflags0
@@ -1605,7 +1605,7 @@ getTokenStream mod = do
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return ts
- PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
+ PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst))
-- | Give even more information on the source than 'getTokenStream'
-- This function allows reconstructing the source completely with
@@ -1616,7 +1616,7 @@ getRichTokenStream mod = do
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream (initParserOpts dflags) source startLoc of
POk _ ts -> return $ addSourceToTokens startLoc source ts
- PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
+ PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst))
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
@@ -1796,11 +1796,11 @@ parser str dflags filename =
PFailed pst ->
let (warns,errs) = getMessages pst in
- (fmap pprWarning warns, Left (fmap pprError errs))
+ (fmap (mkParserWarn dflags) warns, Left (fmap mkParserErr errs))
POk pst rdr_module ->
let (warns,_) = getMessages pst in
- (fmap pprWarning warns, Right rdr_module)
+ (fmap (mkParserWarn dflags) warns, Right rdr_module)
-- -----------------------------------------------------------------------------
-- | Find the package environment (if one exists)
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 116e26b3d1..3438f372fc 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -2774,7 +2774,7 @@ addMsg is_error env msgs msg
, isGoodSrcSpan span ] of
[] -> noSrcSpan
(s:_) -> s
- mk_msg msg = mkLocMessage (mkMCDiagnostic WarningWithoutFlag) msg_span
+ mk_msg msg = mkLocMessage (mkMCDiagnostic (le_dynflags env) 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 8b1b94b14f..3c6ff07a65 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -64,6 +64,7 @@ import GHC.Types.Name.Env
import GHC.Types.SrcLoc
import GHC.Types.Error
+import GHC.Utils.Error ( errorDiagnostic )
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger )
import GHC.Utils.Monad
@@ -820,7 +821,7 @@ errorMsgS = errorMsg . text
-- | Output an error to the screen. Does not cause the compiler to die.
errorMsg :: SDoc -> CoreM ()
-errorMsg = msg (mkMCDiagnostic ErrorWithoutFlag)
+errorMsg doc = msg errorDiagnostic doc
-- | Output a fatal error to the screen. Does not cause the compiler to die.
fatalErrorMsgS :: String -> CoreM ()
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 5caae8bf77..8efebd0cd5 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -55,6 +55,7 @@ import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Types.Error
+import GHC.Utils.Error ( mkMCDiagnostic )
import GHC.Utils.Monad ( foldlM )
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -809,7 +810,7 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn
where
allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
doWarn reason =
- msg (mkMCDiagnostic reason)
+ msg (mkMCDiagnostic dflags 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 4789af6fe7..5c45858570 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -107,7 +107,7 @@ doBackpack [src_filename] = do
buf <- liftIO $ hGetStringBuffer src_filename
let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
- PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
+ PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst))
POk _ pkgname_bkp -> do
-- OK, so we have an LHsUnit PackageName, but we want an
-- LHsUnit HsComponentId. So let's rename it.
@@ -802,8 +802,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 ErrorWithoutFlag
- loc (text "module" <+> ppr modname <+> text "was not found"))
+ Nothing -> throwOneError (mkPlainErrorMsgEnvelope 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/Env.hs b/compiler/GHC/Driver/Env.hs
index 6e843d2ea4..3fff8ab65c 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -30,7 +30,7 @@ import GHC.Prelude
import GHC.Driver.Ppr
import GHC.Driver.Session
-import GHC.Driver.Errors ( printOrThrowWarnings )
+import GHC.Driver.Errors ( printOrThrowDiagnostics )
import GHC.Runtime.Context
import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
@@ -70,7 +70,7 @@ import Data.IORef
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
(a, w) <- hsc hsc_env emptyBag
- printOrThrowWarnings (hsc_logger hsc_env) (hsc_dflags hsc_env) w
+ printOrThrowDiagnostics (hsc_logger hsc_env) (hsc_dflags hsc_env) w
return a
-- | Switches in the DynFlags and Plugins from the InteractiveContext
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index 9127e7d094..b6fdee5c9b 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -1,5 +1,5 @@
module GHC.Driver.Errors (
- printOrThrowWarnings
+ printOrThrowDiagnostics
, printBagOfErrors
, handleFlagWarnings
, partitionMessageBag
@@ -8,7 +8,7 @@ module GHC.Driver.Errors (
import GHC.Driver.Session
import GHC.Data.Bag
import GHC.Utils.Exception
-import GHC.Utils.Error ( formatBulleted, sortMsgBag )
+import GHC.Utils.Error ( formatBulleted, sortMsgBag, mkPlainMsgEnvelope )
import GHC.Types.SourceError ( mkSrcErr )
import GHC.Prelude
import GHC.Types.SrcLoc
@@ -40,10 +40,10 @@ handleFlagWarnings logger dflags warns = do
-- It would be nicer if warns :: [Located SDoc], but that
-- has circular import problems.
- bag = listToBag [ mkPlainMsgEnvelope WarningWithoutFlag loc (text warn)
+ bag = listToBag [ mkPlainMsgEnvelope dflags WarningWithoutFlag loc (text warn)
| CmdLine.Warn _ (L loc warn) <- warns' ]
- printOrThrowWarnings logger dflags bag
+ printOrThrowDiagnostics logger dflags bag
-- Given a warn reason, check to see if it's associated -W opt is enabled
shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool
@@ -54,40 +54,11 @@ shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag
shouldPrintWarning _ _
= True
--- | Given a bag of warnings, turn them into an exception if
--- -Werror is enabled, or print them out otherwise.
-printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO ()
-printOrThrowWarnings logger dflags warns = do
- let (make_error, warns') =
- mapAccumBagL
- (\make_err warn ->
- case warn_msg_severity dflags warn of
- SevWarning ->
- (make_err, warn)
- 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 }
-
+-- | Given a bag of diagnostics, turn them into an exception if
+-- any has 'SevError', or print them out otherwise.
+printOrThrowDiagnostics :: Logger -> DynFlags -> Bag WarnMsg -> IO ()
+printOrThrowDiagnostics logger dflags warns
+ | any ((==) SevError . errMsgSeverity) warns
+ = throwIO (mkSrcErr warns)
+ | otherwise
+ = printBagOfErrors logger dflags warns
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 0c67d05d3a..07f1e7acda 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -281,15 +281,16 @@ handleWarnings = do
dflags <- getDynFlags
logger <- getLogger
w <- getWarnings
- liftIO $ printOrThrowWarnings logger dflags w
+ liftIO $ printOrThrowDiagnostics logger dflags w
clearWarnings
-- | log warning in the monad, and if there are errors then
-- throw a SourceError exception.
logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc ()
logWarningsReportErrors (warnings,errors) = do
- let warns = fmap pprWarning warnings
- errs = fmap pprError errors
+ dflags <- getDynFlags
+ let warns = fmap (mkParserWarn dflags) warnings
+ errs = fmap mkParserErr errors
logDiagnostics warns
when (not $ isEmptyBag errs) $ throwErrors errs
@@ -297,10 +298,10 @@ logWarningsReportErrors (warnings,errors) = do
-- contain at least one error (e.g. coming from PFailed)
handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a
handleWarningsThrowErrors (warnings, errors) = do
- let warns = fmap pprWarning warnings
- errs = fmap pprError errors
- logDiagnostics warns
dflags <- getDynFlags
+ let warns = fmap (mkParserWarn dflags) warnings
+ errs = fmap mkParserErr errors
+ logDiagnostics warns
logger <- getLogger
let (wWarns, wErrs) = partitionMessageBag warns
liftIO $ printBagOfErrors logger dflags wWarns
@@ -415,7 +416,7 @@ hscParse' mod_summary
PFailed pst ->
handleWarningsThrowErrors (getMessages pst)
POk pst rdr_module -> do
- let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)
+ let (warns, errs) = bimap (fmap (mkParserWarn dflags)) (fmap mkParserErr) (getMessages pst)
logDiagnostics warns
liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"
FormatHaskell (ppr rdr_module)
@@ -563,7 +564,7 @@ tcRnModule' sum save_rn_syntax mod = do
when (not (safeHaskellModeEnabled dflags)
&& wopt Opt_WarnMissingSafeHaskellMode dflags) $
logDiagnostics $ unitBag $
- mkPlainMsgEnvelope reason (getLoc (hpm_module mod)) $
+ mkPlainMsgEnvelope dflags reason (getLoc (hpm_module mod)) $
warnMissingSafeHaskellMode
tcg_res <- {-# SCC "Typecheck-Rename" #-}
@@ -591,13 +592,13 @@ tcRnModule' sum save_rn_syntax mod = do
True
| safeHaskell dflags == Sf_Safe -> return ()
| otherwise -> (logDiagnostics $ unitBag $
- mkPlainMsgEnvelope (WarningWithFlag Opt_WarnSafe)
+ mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnSafe)
(warnSafeOnLoc dflags) $
errSafe tcg_res')
False | safeHaskell dflags == Sf_Trustworthy &&
wopt Opt_WarnTrustworthySafe dflags ->
(logDiagnostics $ unitBag $
- mkPlainMsgEnvelope (WarningWithFlag Opt_WarnTrustworthySafe)
+ mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnTrustworthySafe)
(trustworthyOnLoc dflags) $
errTwthySafe tcg_res')
False -> return ()
@@ -1127,22 +1128,22 @@ hscCheckSafeImports tcg_env = do
case safeLanguageOn dflags of
True -> do
-- XSafe: we nuke user written RULES
- logDiagnostics $ warns (tcg_rules tcg_env')
+ logDiagnostics $ warns dflags (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
-- SafeInferred: user defined RULES, so not safe
| safeInferOn dflags && not (null $ tcg_rules tcg_env')
- -> markUnsafeInfer tcg_env' $ warns (tcg_rules tcg_env')
+ -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
-- Trustworthy OR SafeInferred: with no RULES
| otherwise
-> return tcg_env'
- warns rules = listToBag $ map warnRules rules
+ warns dflags rules = listToBag $ map (warnRules dflags) rules
- warnRules :: LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage
- warnRules (L loc (HsRule { rd_name = n })) =
- mkPlainMsgEnvelope WarningWithoutFlag (locA loc) $
+ warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage
+ warnRules df (L loc (HsRule { rd_name = n })) =
+ mkPlainMsgEnvelope df WarningWithoutFlag (locA loc) $
text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
@@ -1218,9 +1219,9 @@ checkSafeImports tcg_env
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' v1 v2
| imv_is_safe v1 /= imv_is_safe v2
- = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag (imv_span v1)
- (text "Module" <+> ppr (imv_name v1) <+>
- (text $ "is imported both as a safe and unsafe import!"))
+ = throwOneError $ mkPlainErrorMsgEnvelope (imv_span v1)
+ (text "Module" <+> ppr (imv_name v1) <+>
+ (text $ "is imported both as a safe and unsafe import!"))
| otherwise
= return v1
@@ -1286,7 +1287,7 @@ hscCheckSafe' m l = do
iface <- lookup' m
case iface of
-- can't load iface to check trust!
- Nothing -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag l
+ Nothing -> throwOneError $ mkPlainErrorMsgEnvelope l
$ text "Can't load the interface file for" <+> ppr m
<> text ", to check that it can be safely imported"
@@ -1304,7 +1305,7 @@ hscCheckSafe' m l = do
warns = if wopt Opt_WarnInferredSafeImports dflags
&& safeLanguageOn dflags
&& trust == Sf_SafeInferred
- then inferredImportWarn
+ then inferredImportWarn dflags
else emptyBag
-- General errors we throw but Safe errors we log
errs = case (safeM, safeP) of
@@ -1318,23 +1319,25 @@ hscCheckSafe' m l = do
where
state = hsc_units hsc_env
- inferredImportWarn = unitBag
- $ mkShortMsgEnvelope (WarningWithFlag Opt_WarnInferredSafeImports)
+ inferredImportWarn dflags = unitBag
+ $ mkShortMsgEnvelope dflags (WarningWithFlag Opt_WarnInferredSafeImports)
l (pkgQual state)
$ sep
[ text "Importing Safe-Inferred module "
<> ppr (moduleName m)
<> text " from explicitly Safe module"
]
- pkgTrustErr = unitBag $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $
- sep [ ppr (moduleName m)
+ pkgTrustErr = unitBag
+ $ mkShortErrorMsgEnvelope 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 $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $
- sep [ ppr (moduleName m)
+ modTrustErr = unitBag
+ $ mkShortErrorMsgEnvelope l (pkgQual state)
+ $ sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The module itself isn't safe." ]
@@ -1379,7 +1382,7 @@ checkPkgTrust pkgs = do
| unitIsTrusted $ unsafeLookupUnitId state pkg
= acc
| otherwise
- = (:acc) $ mkShortMsgEnvelope ErrorWithoutFlag noSrcSpan (pkgQual state)
+ = (:acc) $ mkShortErrorMsgEnvelope noSrcSpan (pkgQual state)
$ pprWithUnitState state
$ text "The package ("
<> ppr pkg
@@ -1405,7 +1408,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
let reason = WarningWithFlag Opt_WarnUnsafe
when (wopt Opt_WarnUnsafe dflags)
(logDiagnostics $ unitBag $
- mkPlainMsgEnvelope reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
+ mkPlainMsgEnvelope dflags 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
@@ -1637,7 +1640,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
$ do
(warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
$ parseCmmFile dflags cmm_mod home_unit filename
- return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm)
+ return (mkMessages (fmap (mkParserWarn dflags) warns `unionBags` fmap mkParserErr errs), cmm)
liftIO $ do
dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
@@ -1998,7 +2001,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do
case is of
[L _ i] -> return i
_ -> liftIO $ throwOneError $
- mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $
+ mkPlainErrorMsgEnvelope noSrcSpan $
text "parse error in import declaration"
-- | Typecheck an expression (but don't run it)
@@ -2027,7 +2030,7 @@ hscParseExpr expr = do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (BodyStmt _ expr _ _)) -> return expr
- _ -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan
+ _ -> throwOneError $ mkPlainErrorMsgEnvelope 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 4036208954..b677f63681 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -319,7 +319,7 @@ warnMissingHomeModules hsc_env mod_graph =
4
(sep (map ppr missing))
warn =
- mkPlainMsgEnvelope (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg
+ mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg
-- | Describes which modules of the module graph need to be loaded.
data LoadHowMuch
@@ -385,7 +385,7 @@ warnUnusedPackages = do
requestedArgs
let warn =
- mkPlainMsgEnvelope (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg
+ mkPlainMsgEnvelope dflags (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:"
@@ -2214,15 +2214,15 @@ warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports sccs = do
dflags <- getDynFlags
when (wopt Opt_WarnUnusedImports dflags)
- (logWarnings (listToBag (concatMap (check . flattenSCC) sccs)))
- where check ms =
+ (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
+ where check dflags ms =
let mods_in_this_cycle = map ms_mod_name ms in
- [ warn i | m <- ms, i <- ms_home_srcimps m,
- unLoc i `notElem` mods_in_this_cycle ]
+ [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
+ unLoc i `notElem` mods_in_this_cycle ]
- warn :: Located ModuleName -> WarnMsg
- warn (L loc mod) =
- mkPlainMsgEnvelope WarningWithoutFlag loc
+ warn :: DynFlags -> Located ModuleName -> WarnMsg
+ warn dflags (L loc mod) =
+ mkPlainMsgEnvelope dflags WarningWithoutFlag loc
(text "{-# SOURCE #-} unnecessary in import of "
<+> quotes (ppr mod))
@@ -2295,7 +2295,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 ErrorWithoutFlag noSrcSpan $
+ else return $ Left $ unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $
text "can't find file:" <+> text file
getRootSummary Target { targetId = TargetModule modl
, targetAllowObjCode = obj_allowed
@@ -2730,7 +2730,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
| otherwise = HsSrcFile
when (pi_mod_name /= wanted_mod) $
- throwE $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag pi_mod_name_loc $
+ throwE $ unitBag $ mkPlainErrorMsgEnvelope 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 +2742,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 ErrorWithoutFlag pi_mod_name_loc $
+ in throwE $ unitBag $ mkPlainErrorMsgEnvelope 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)
@@ -2855,7 +2855,7 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags
popts = initParserOpts pi_local_dflags
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
- return (first (fmap pprError) mimps)
+ return (first (fmap mkParserErr) mimps)
return PreprocessedImports {..}
@@ -2902,21 +2902,21 @@ withDeferredDiagnostics f = do
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 ErrorWithoutFlag loc $ cannotFindModule hsc_env wanted_mod err
+ = mkPlainErrorMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err
noHsFileErr :: SrcSpan -> String -> ErrorMessages
noHsFileErr loc path
- = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag loc $ text "Can't find" <+> text path
+ = unitBag $ mkPlainErrorMsgEnvelope loc $ text "Can't find" <+> text path
moduleNotFoundErr :: ModuleName -> ErrorMessages
moduleNotFoundErr mod
- = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $
+ = unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_)
- = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $
+ = throwOneError $ mkPlainErrorMsgEnvelope 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 9324755d3d..ea1bf1f501 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 ErrorWithoutFlag srcloc $
+ throwOneError $ mkPlainErrorMsgEnvelope srcloc $
cannotFindModule hsc_env imp fail
-----------------------------
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 39ccdc7c21..1a42d8402f 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -36,7 +36,7 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
-import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors )
+import GHC.Driver.Errors ( printOrThrowDiagnostics, printBagOfErrors )
import GHC.Utils.Monad
import GHC.Utils.Exception
@@ -147,7 +147,7 @@ logWarnings :: GhcMonad m => WarningMessages -> m ()
logWarnings warns = do
dflags <- getSessionDynFlags
logger <- getLogger
- liftIO $ printOrThrowWarnings logger dflags warns
+ liftIO $ printOrThrowDiagnostics logger dflags warns
-- -----------------------------------------------------------------------------
-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 514c3c9701..e79d1ecab9 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 ErrorWithoutFlag srcspan $ text msg
+ mkPlainErrorMsgEnvelope srcspan $ text msg
handler ex = throwGhcExceptionIO ex
-- ---------------------------------------------------------------------------
@@ -1255,7 +1255,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn
popts = initParserOpts dflags
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
- Left errs -> throwErrors (fmap pprError errs)
+ Left errs -> throwErrors (fmap mkParserErr errs)
Right (src_imps,imps,L _ mod_name) -> return
(Just buf, mod_name, imps, src_imps)
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index f5be46006a..a16f70cded 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -105,9 +105,9 @@ import GHC.Types.CostCentre.State
import GHC.Types.TyThing
import GHC.Types.Error
+import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Utils.Error
import Data.IORef
@@ -460,7 +460,8 @@ diagnosticDs :: DiagnosticReason -> SDoc -> DsM ()
diagnosticDs reason warn
= do { env <- getGblEnv
; loc <- getSrcSpanDs
- ; let msg = mkShortMsgEnvelope reason loc (ds_unqual env) warn
+ ; dflags <- getDynFlags
+ ; let msg = mkShortMsgEnvelope dflags reason loc (ds_unqual env) warn
; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
-- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags
@@ -473,7 +474,7 @@ errDs :: SDoc -> DsM ()
errDs err
= do { env <- getGblEnv
; loc <- getSrcSpanDs
- ; let msg = mkShortMsgEnvelope ErrorWithoutFlag loc (ds_unqual env) err
+ ; let msg = mkShortErrorMsgEnvelope 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/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
index beb7aadbbb..f4e8b449f5 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ b/compiler/GHC/Iface/Rename.hs
@@ -43,6 +43,7 @@ import GHC.Types.Name.Shape
import GHC.Utils.Outputable
import GHC.Utils.Misc
+import GHC.Utils.Error
import GHC.Utils.Fingerprint
import GHC.Utils.Panic
@@ -76,7 +77,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 ErrorWithoutFlag noSrcSpan doc)
+ writeTcRef errs_var (errs `snocBag` mkPlainErrorMsgEnvelope 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 86fff45160..735f6ceb16 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -1433,7 +1433,7 @@ load_dyn interp hsc_env crash_early dll = do
else
when (wopt Opt_WarnMissedExtraSharedLib dflags)
$ putLogMsg logger dflags
- (mkMCDiagnostic $ WarningWithFlag Opt_WarnMissedExtraSharedLib)
+ (mkMCDiagnostic dflags $ WarningWithFlag Opt_WarnMissedExtraSharedLib)
noSrcSpan $ withPprStyle defaultUserStyle (note err)
where
dflags = hsc_dflags hsc_env
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index c0c09d6173..7b9f2e64a0 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -3,8 +3,8 @@
{-# LANGUAGE FlexibleContexts #-}
module GHC.Parser.Errors.Ppr
- ( pprWarning
- , pprError
+ ( mkParserWarn
+ , mkParserErr
)
where
@@ -24,27 +24,32 @@ import GHC.Hs.Expr (prependQualified,HsExpr(..))
import GHC.Hs.Type (pprLHsContext)
import GHC.Builtin.Names (allNameStrings)
import GHC.Builtin.Types (filterCTuple)
+import GHC.Driver.Session (DynFlags)
+import GHC.Utils.Error (diagReasonSeverity)
-mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage
-mkParserErr span doc = MsgEnvelope
+mk_parser_err :: SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage
+mk_parser_err span doc = MsgEnvelope
{ errMsgSpan = span
, errMsgContext = alwaysQualify
, errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) ErrorWithoutFlag
, errMsgSeverity = SevError
}
-mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage
-mkParserWarn flag span doc = MsgEnvelope
+mk_parser_warn :: DynFlags -> WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage
+mk_parser_warn df flag span doc = MsgEnvelope
{ errMsgSpan = span
, errMsgContext = alwaysQualify
- , errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) (WarningWithFlag flag)
- , errMsgSeverity = SevWarning
+ , errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) reason
+ , errMsgSeverity = diagReasonSeverity df reason
}
+ where
+ reason :: DiagnosticReason
+ reason = WarningWithFlag flag
-pprWarning :: PsWarning -> MsgEnvelope DiagnosticMessage
-pprWarning = \case
+mkParserWarn :: DynFlags -> PsWarning -> MsgEnvelope DiagnosticMessage
+mkParserWarn df = \case
PsWarnTab loc tc
- -> mkParserWarn Opt_WarnTabs loc $
+ -> mk_parser_warn df Opt_WarnTabs loc $
text "Tab character found here"
<> (if tc == 1
then text ""
@@ -53,7 +58,7 @@ pprWarning = \case
$+$ text "Please use spaces instead."
PsWarnTransitionalLayout loc reason
- -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $
+ -> mk_parser_warn df Opt_WarnAlternativeLayoutRuleTransitional loc $
text "transitional layout will not be accepted in the future:"
$$ text (case reason of
TransLayout_Where -> "`where' clause at the same depth as implicit layout block"
@@ -61,20 +66,20 @@ pprWarning = \case
)
PsWarnUnrecognisedPragma loc
- -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $
+ -> mk_parser_warn df Opt_WarnUnrecognisedPragmas loc $
text "Unrecognised pragma"
PsWarnHaddockInvalidPos loc
- -> mkParserWarn Opt_WarnInvalidHaddock loc $
+ -> mk_parser_warn df Opt_WarnInvalidHaddock loc $
text "A Haddock comment cannot appear in this position and will be ignored."
PsWarnHaddockIgnoreMulti loc
- -> mkParserWarn Opt_WarnInvalidHaddock loc $
+ -> mk_parser_warn df Opt_WarnInvalidHaddock loc $
text "Multiple Haddock comments for a single entity are not allowed." $$
text "The extraneous comment will be ignored."
PsWarnStarBinder loc
- -> mkParserWarn Opt_WarnStarBinder loc $
+ -> mk_parser_warn df Opt_WarnStarBinder loc $
text "Found binding occurrence of" <+> quotes (text "*")
<+> text "yet StarIsType is enabled."
$$ text "NB. To use (or export) this operator in"
@@ -82,7 +87,7 @@ pprWarning = \case
$$ text " including the definition module, you must qualify it."
PsWarnStarIsType loc
- -> mkParserWarn Opt_WarnStarIsType loc $
+ -> mk_parser_warn df Opt_WarnStarIsType loc $
text "Using" <+> quotes (text "*")
<+> text "(or its Unicode variant) to mean"
<+> quotes (text "Data.Kind.Type")
@@ -92,7 +97,7 @@ pprWarning = \case
<+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."
PsWarnImportPreQualified loc
- -> mkParserWarn Opt_WarnPrepositiveQualifiedModule loc $
+ -> mk_parser_warn df Opt_WarnPrepositiveQualifiedModule loc $
text "Found" <+> quotes (text "qualified")
<+> text "in prepositive position"
$$ text "Suggested fix: place " <+> quotes (text "qualified")
@@ -100,7 +105,7 @@ pprWarning = \case
$$ text "To allow this, enable language extension 'ImportQualifiedPost'"
PsWarnOperatorWhitespaceExtConflict loc sym
- -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $
+ -> mk_parser_warn df Opt_WarnOperatorWhitespaceExtConflict loc $
let mk_prefix_msg operator_symbol extension_name syntax_meaning =
text "The prefix use of a" <+> quotes (text operator_symbol)
<+> text "would denote" <+> text syntax_meaning
@@ -115,7 +120,7 @@ pprWarning = \case
PsWarnOperatorWhitespace loc sym occ_type
- -> mkParserWarn Opt_WarnOperatorWhitespace loc $
+ -> mk_parser_warn df Opt_WarnOperatorWhitespace loc $
let mk_msg occ_type_str =
text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)
<+> text "might be repurposed as special syntax"
@@ -127,8 +132,8 @@ pprWarning = \case
OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"
OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"
-pprError :: PsError -> MsgEnvelope DiagnosticMessage
-pprError err = mkParserErr (errLoc err) $ vcat
+mkParserErr :: PsError -> MsgEnvelope DiagnosticMessage
+mkParserErr err = mk_parser_err (errLoc err) $ vcat
(pp_err (errDesc err) : map pp_hint (errHints err))
pp_err :: PsErrorDesc -> SDoc
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index a80620eed4..c45cae45ca 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -48,6 +48,7 @@ import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Monad
+import GHC.Utils.Error
import GHC.Utils.Exception as Exception
import GHC.Data.StringBuffer
@@ -90,7 +91,7 @@ getImports popts implicit_prelude buf filename source_filename = do
-- don't log warnings: they'll be reported when we parse the file
-- for real. See #2500.
if not (isEmptyBag errs)
- then throwIO $ mkSrcErr (fmap pprError errs)
+ then throwIO $ mkSrcErr (fmap mkParserErr errs)
else
let hsmod = unLoc rdr_module
mb_mod = hsmodName hsmod
@@ -314,7 +315,7 @@ checkProcessArgsResult flags
= when (notNull flags) $
liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
where mkMsg (L loc flag)
- = mkPlainMsgEnvelope ErrorWithoutFlag loc $
+ = mkPlainErrorMsgEnvelope loc $
(text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
text flag)
@@ -358,7 +359,7 @@ optionsErrorMsgs unhandled_flags flags_lines _filename
, L l f' <- flags_lines
, f == f' ]
mkMsg (L flagSpan flag) =
- mkPlainMsgEnvelope ErrorWithoutFlag flagSpan $
+ mkPlainErrorMsgEnvelope flagSpan $
text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
optionsParseError :: String -> SrcSpan -> a -- #15053
@@ -371,4 +372,4 @@ optionsParseError str loc =
throwErr :: SrcSpan -> SDoc -> a -- #15053
throwErr loc doc =
- throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag loc doc
+ throw $ mkSrcErr $ unitBag $ mkPlainErrorMsgEnvelope loc doc
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 412d221794..abdc5e8328 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -75,7 +75,7 @@ lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds
= {-# SCC "StgLint" #-}
- case initL this_mod unarised opts top_level_binds (lint_binds binds) of
+ case initL dflags this_mod unarised opts top_level_binds (lint_binds binds) of
Nothing ->
return ()
Just msg -> do
@@ -247,6 +247,7 @@ The Lint monad
newtype LintM a = LintM
{ unLintM :: Module
-> LintFlags
+ -> DynFlags
-> StgPprOpts -- Pretty-printing options
-> [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
@@ -281,16 +282,16 @@ pp_binders bs
pp_binder b
= hsep [ppr b, dcolon, ppr (idType b)]
-initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
-initL this_mod unarised opts locals (LintM m) = do
- let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag
+initL :: DynFlags -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
+initL dflags this_mod unarised opts locals (LintM m) = do
+ let (_, errs) = m this_mod (LintFlags unarised) dflags opts [] locals emptyBag
if isEmptyBag errs then
Nothing
else
Just (vcat (punctuate blankLine (bagToList errs)))
instance Applicative LintM where
- pure a = LintM $ \_mod _lf _opts _loc _scope errs -> (a, errs)
+ pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)
(<*>) = ap
(*>) = thenL_
@@ -299,14 +300,14 @@ instance Monad LintM where
(>>) = (*>)
thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \mod lf opts loc scope errs
- -> case unLintM m mod lf opts loc scope errs of
- (r, errs') -> unLintM (k r) mod lf opts loc scope errs'
+thenL m k = LintM $ \mod lf dflags opts loc scope errs
+ -> case unLintM m mod lf dflags opts loc scope errs of
+ (r, errs') -> unLintM (k r) mod lf dflags opts loc scope errs'
thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \mod lf opts loc scope errs
- -> case unLintM m mod lf opts loc scope errs of
- (_, errs') -> unLintM k mod lf opts loc scope errs'
+thenL_ m k = LintM $ \mod lf dflags opts loc scope errs
+ -> case unLintM m mod lf dflags opts loc scope errs of
+ (_, errs') -> unLintM k mod lf dflags opts loc scope errs'
checkL :: Bool -> SDoc -> LintM ()
checkL True _ = return ()
@@ -351,37 +352,37 @@ checkPostUnariseId id =
is_sum <|> is_tuple <|> is_void
addErrL :: SDoc -> LintM ()
-addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc)
+addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc)
-addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
-addErr errs_so_far msg locs
+addErr :: DynFlags -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
+addErr dflags errs_so_far msg locs
= errs_so_far `snocBag` mk_msg locs
where
mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
- in mkLocMessage (Err.mkMCDiagnostic WarningWithoutFlag)
+ in mkLocMessage (Err.mkMCDiagnostic dflags WarningWithoutFlag)
l (hdr $$ msg)
mk_msg [] = msg
addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \mod lf opts loc scope errs
- -> unLintM m mod lf opts (extra_loc:loc) scope errs
+addLoc extra_loc m = LintM $ \mod lf dflags opts loc scope errs
+ -> unLintM m mod lf dflags opts (extra_loc:loc) scope errs
addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \mod lf opts loc scope errs
+addInScopeVars ids m = LintM $ \mod lf dflags opts loc scope errs
-> let
new_set = mkVarSet ids
- in unLintM m mod lf opts loc (scope `unionVarSet` new_set) errs
+ in unLintM m mod lf dflags opts loc (scope `unionVarSet` new_set) errs
getLintFlags :: LintM LintFlags
-getLintFlags = LintM $ \_mod lf _opts _loc _scope errs -> (lf, errs)
+getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)
getStgPprOpts :: LintM StgPprOpts
-getStgPprOpts = LintM $ \_mod _lf opts _loc _scope errs -> (opts, errs)
+getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \mod _lf _opts loc scope errs
+checkInScope id = LintM $ \mod _lf dflags _opts loc scope errs
-> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
- ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
+ ((), addErr dflags errs (hsep [ppr id, dcolon, ppr (idType id),
text "is out of scope"]) loc)
else
((), errs)
diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs
index c9cd24cf89..522c50f354 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 (mkMCDiagnostic ErrorWithoutFlag) (mkSrcSpan loc loc)
+ putLogMsg logger dflags errorDiagnostic (mkSrcSpan loc loc)
$ withPprStyle defaultUserStyle msg
log_loop chan t
EOF ->
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index 23cad15976..abb58cd58b 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -66,9 +66,10 @@ import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.FV ( fvVarList, unionFV )
-import Control.Monad ( when, unless )
+import Control.Monad ( unless, when )
import Data.Foldable ( toList )
import Data.List ( partition, mapAccumL, sortBy, unfoldr )
+import Data.Traversable ( for )
import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits )
@@ -758,24 +759,21 @@ machinery, in cases where it is definitely going to be a no-op.
mkUserTypeErrorReporter :: Reporter
mkUserTypeErrorReporter ctxt
- = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct
- ; maybeReportError ctxt err
+ = mapM_ $ \ct -> do { let err = mkUserTypeError ct
+ ; maybeReportError ctxt ct err
; addDeferredBinding ctxt err ct }
-mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage)
-mkUserTypeError ctxt ct = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct
- $ important
- $ pprUserTypeErrorTy
- $ case getUserTypeErrorMsg ct of
- Just msg -> msg
- Nothing -> pprPanic "mkUserTypeError" (ppr ct)
-
+mkUserTypeError :: Ct -> Report
+mkUserTypeError ct = important
+ $ pprUserTypeErrorTy
+ $ case getUserTypeErrorMsg ct of
+ Just msg -> msg
+ Nothing -> pprPanic "mkUserTypeError" (ppr ct)
mkGivenErrorReporter :: Reporter
-- See Note [Given errors]
mkGivenErrorReporter ctxt cts
= do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
- ; dflags <- getDynFlags
; let (implic:_) = cec_encl ctxt
-- Always non-empty when mkGivenErrorReporter is called
ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))
@@ -788,7 +786,9 @@ mkGivenErrorReporter ctxt cts
report = important inaccessible_msg `mappend`
mk_relevant_bindings binds_msg
- ; err <- mkEqErr_help (WarningWithFlag Opt_WarnInaccessibleCode) dflags ctxt report ct' ty1 ty2
+ ; report <- mkEqErr_help ctxt report ct' ty1 ty2
+ ; err <- mkErrorReport (WarningWithFlag Opt_WarnInaccessibleCode) ctxt
+ (ctLocEnv (ctLoc ct')) report
; traceTc "mkGivenErrorReporter" (ppr ct)
; reportDiagnostic err }
@@ -838,7 +838,7 @@ pattern match which binds some equality constraints. If we
find one, we report the insoluble Given.
-}
-mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage))
+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM Report)
-- Make error message for a group
-> Reporter -- Deal with lots of constraints
-- Group together errors from same location,
@@ -847,7 +847,8 @@ 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 DiagnosticMessage)) -> Reporter
+mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM Report)
+ -> Reporter
mkSuppressReporter mk_err ctxt cts
= mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
@@ -865,15 +866,15 @@ 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 DiagnosticMessage)) -> Reporter
-reportGroup mk_err ctxt cts =
- ASSERT( not (null cts))
+reportGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter
+reportGroup mk_err ctxt cts
+ | ct1 : _ <- cts =
do { err <- mk_err ctxt cts
; traceTc "About to maybeReportErr" $
vcat [ text "Constraint:" <+> ppr cts
, text "cec_suppress =" <+> ppr (cec_suppress ctxt)
, text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
- ; maybeReportError ctxt err
+ ; maybeReportError ctxt ct1 err
-- But see Note [Always warn with -fdefer-type-errors]
; traceTc "reportGroup" (ppr cts)
; mapM_ (addDeferredBinding ctxt err) cts }
@@ -881,51 +882,34 @@ reportGroup mk_err ctxt cts =
-- Redundant if we are going to abort compilation,
-- but that's hard to know for sure, and if we don't
-- abort, we need bindings for all (e.g. #12156)
+ | otherwise = panic "empty reportGroup"
-- like reportGroup, but does not actually report messages. It still adds
-- -fdefer-type-errors bindings, though.
-suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter
+suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter
suppressGroup mk_err ctxt cts
= do { err <- mk_err ctxt cts
; traceTc "Suppressing errors for" (ppr cts)
; mapM_ (addDeferredBinding ctxt err) cts }
-maybeReportError :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> TcM ()
--- Report the error and/or make a deferred binding for it
-maybeReportError ctxt msg
- | cec_suppress ctxt -- Some worse error has occurred;
- = return () -- so suppress this error/warning
-
+maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM ()
+maybeReportError ctxt ct report
| Just reason <- cec_defer_type_errors ctxt
- = reportDiagnostic (reclassify reason msg)
+ = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic
+ do msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report
+ reportDiagnostic msg
+
| otherwise
- = 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 ()
+ = return () -- nothing to report
+
+addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM ()
-- See Note [Deferring coercion errors to runtime]
addDeferredBinding ctxt err ct
| deferringAnyBindings ctxt
, CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
-- Only add deferred bindings for Wanted constraints
- = do { dflags <- getDynFlags
- ; let err_tm = mkErrorTerm dflags pred err
- ev_binds_var = cec_binds ctxt
+ = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err
+ ; let ev_binds_var = cec_binds ctxt
; case dest of
EvVarDest evar
@@ -939,13 +923,17 @@ addDeferredBinding ctxt err ct
| otherwise -- Do not set any evidence for Given/Derived
= return ()
-mkErrorTerm :: DynFlags -> Type -- of the error term
- -> 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)"
+mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term
+ -> Report -> TcM EvTerm
+mkErrorTerm ctxt ct_loc ty report
+ = do { msg <- mkErrorReport ErrorWithoutFlag ctxt (ctLocEnv ct_loc) report
+ -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"
+ ; dflags <- getDynFlags
+ ; let err_msg = pprLocMsgEnvelope msg
+ err_fs = mkFastString $ showSDoc dflags $
+ err_msg $$ text "(deferred type error)"
+
+ ; return $ evDelayedError ty err_fs }
tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
-- Use the first reporter in the list whose predicate says True
@@ -1015,10 +1003,6 @@ pprWithArising (ct:cts)
ppr_one ct' = hang (parens (pprType (ctPred ct')))
2 (pprCtLoc (ctLoc ct'))
-mkErrorMsgFromCt :: DiagnosticReason -> ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DiagnosticMessage)
-mkErrorMsgFromCt rea ctxt ct report
- = mkErrorReport rea ctxt (ctLocEnv (ctLoc ct)) report
-
mkErrorReport :: DiagnosticReason
-> ReportErrCtxt
-> TcLclEnv
@@ -1033,6 +1017,17 @@ mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs)
(vcat $ relevant_bindings ++ valid_subs)
}
+-- This version does not include the context
+mkErrorReportNC :: DiagnosticReason
+ -> TcLclEnv
+ -> Report
+ -> TcM (MsgEnvelope DiagnosticMessage)
+mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs)
+ = mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc tcl_env) Nothing)
+ (vcat important)
+ O.empty
+ (vcat $ relevant_bindings ++ valid_subs)
+
type UserGiven = Implication
getUserGivens :: ReportErrCtxt -> [UserGiven]
@@ -1051,12 +1046,9 @@ would get errors without -fdefer-type-errors, but if we suppress any of
them you might get a runtime error that wasn't warned about at compile
time.
-This is an easy design choice to change; just flip the order of the
-first two equations for maybeReportError
-
To be consistent, we should also report multiple warnings from a single
location in mkGroupReporter, when -fdefer-type-errors is on. But that
-is perhaps a bit *over*-consistent! Again, an easy choice to change.
+is perhaps a bit *over*-consistent!
With #10283, you can now opt out of deferred type error warnings.
@@ -1127,13 +1119,12 @@ solve it.
************************************************************************
-}
-mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
+mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM Report
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 ErrorWithoutFlag ctxt ct1 $
- msg `mappend` mk_relevant_bindings binds_msg }
+ ; return $ msg `mappend` mk_relevant_bindings binds_msg }
where
(ct1:_) = cts
@@ -1183,14 +1174,15 @@ mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ
; imp_info <- getImports
; curr_mod <- getModule
; hpt <- getHpt
- ; 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
+ ; let err = important out_of_scope_msg `mappend`
+ (mk_relevant_bindings $
+ unknownNameSuggestions dflags hpt curr_mod rdr_env
+ (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ))
+
+ ; maybeAddDeferredBindings ctxt hole err
+ ; for (cec_out_of_scope_holes ctxt) $ \ rea ->
+ mkErrorReportNC rea lcl_env err
+ -- Use NC variant: the context is generally not helpful here
}
where
herald | isDataOcc occ = text "Data constructor not in scope:"
@@ -1223,18 +1215,15 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
then validHoleFits ctxt tidy_simples hole
else return (ctxt, empty)
- ; 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
+ ; let err = important hole_msg `mappend`
+ mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend`
+ valid_hole_fits sub_msg
- ; maybeAddDeferredBindings ctxt hole mk_err
+ ; maybeAddDeferredBindings ctxt hole err
; let holes | ExprHole _ <- sort = cec_expr_holes ctxt
| otherwise = cec_type_holes ctxt
- ; whenNotDeferring holes mk_err
-
+ ; for holes $ \ rea -> mkErrorReport rea ctxt lcl_env err
}
where
@@ -1293,10 +1282,6 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1313,18 +1298,16 @@ so that the correct 'Severity' can be computed out of that later on.
-- See Note [Adding deferred bindings].
maybeAddDeferredBindings :: ReportErrCtxt
-> Hole
- -> (DiagnosticReason -> TcM (MsgEnvelope DiagnosticMessage))
+ -> Report
-> TcM ()
-maybeAddDeferredBindings ctxt hole mk_err = do
+maybeAddDeferredBindings ctxt hole report = 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
+ err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report
-- NB: ref_ty, not hole_ty. hole_ty might be rewritten.
-- See Note [Holes] in GHC.Tc.Types.Constraint
writeMutVar ref err_tm
@@ -1365,7 +1348,7 @@ givenConstraintsMsg ctxt =
2 (vcat $ map pprConstraint constraints)
----------------
-mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM Report
mkIPErr ctxt cts
= do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
; let orig = ctOrigin ct1
@@ -1378,8 +1361,7 @@ mkIPErr ctxt cts
| otherwise
= couldNotDeduce givens (preds, orig)
- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 $
- msg `mappend` mk_relevant_bindings binds_msg }
+ ; return $ msg `mappend` mk_relevant_bindings binds_msg }
where
(ct1:_) = cts
@@ -1442,11 +1424,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 DiagnosticMessage)
+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM Report
mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
mkEqErr _ [] = panic "mkEqErr"
-mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage)
+mkEqErr1 :: ReportErrCtxt -> Ct -> TcM Report
mkEqErr1 ctxt ct -- Wanted or derived;
-- givens handled in mkGivenErrorReporter
= do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
@@ -1455,11 +1437,10 @@ mkEqErr1 ctxt ct -- Wanted or derived;
; let coercible_msg = case ctEqRel ct of
NomEq -> empty
ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
- ; dflags <- getDynFlags
; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))
; let report = mconcat [ important coercible_msg
, mk_relevant_bindings binds_msg]
- ; mkEqErr_help ErrorWithoutFlag dflags ctxt report ct ty1 ty2 }
+ ; mkEqErr_help ctxt report ct ty1 ty2 }
where
(ty1, ty2) = getEqPredTys (ctPred ct)
@@ -1510,77 +1491,78 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
| otherwise
= False
-mkEqErr_help :: DiagnosticReason -> DynFlags -> ReportErrCtxt -> Report
+mkEqErr_help :: ReportErrCtxt -> Report
-> Ct
- -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage)
-mkEqErr_help rea dflags ctxt report ct ty1 ty2
+ -> TcType -> TcType -> TcM Report
+mkEqErr_help ctxt report ct ty1 ty2
| Just (tv1, _) <- tcGetCastedTyVar_maybe ty1
- = mkTyVarEqErr rea dflags ctxt report ct tv1 ty2
+ = mkTyVarEqErr ctxt report ct tv1 ty2
| Just (tv2, _) <- tcGetCastedTyVar_maybe ty2
- = mkTyVarEqErr rea dflags ctxt report ct tv2 ty1
+ = mkTyVarEqErr ctxt report ct tv2 ty1
| otherwise
- = reportEqErr rea ctxt report ct ty1 ty2
+ = return $ reportEqErr ctxt report ct ty1 ty2
-reportEqErr :: DiagnosticReason -> ReportErrCtxt -> Report
+reportEqErr :: ReportErrCtxt -> Report
-> Ct
- -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage)
-reportEqErr rea ctxt report ct ty1 ty2
- = mkErrorMsgFromCt rea ctxt ct (mconcat [misMatch, report, eqInfo])
+ -> TcType -> TcType -> Report
+reportEqErr ctxt report ct ty1 ty2
+ = mconcat [misMatch, report, eqInfo]
where
misMatch = misMatchOrCND False ctxt ct ty1 ty2
eqInfo = mkEqInfoMsg ct ty1 ty2
-mkTyVarEqErr, mkTyVarEqErr'
- :: DiagnosticReason
- -> DynFlags -> ReportErrCtxt -> Report -> Ct
- -> TcTyVar -> TcType -> TcM (MsgEnvelope DiagnosticMessage)
+mkTyVarEqErr :: ReportErrCtxt -> Report -> Ct
+ -> TcTyVar -> TcType -> TcM Report
-- tv1 and ty2 are already tidied
-mkTyVarEqErr reason dflags ctxt report ct tv1 ty2
+mkTyVarEqErr ctxt report ct tv1 ty2
= do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)
- ; mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 }
+ ; dflags <- getDynFlags
+ ; return $ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 }
-mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2
+mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct
+ -> TcTyVar -> TcType -> Report
+mkTyVarEqErr' 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 reason ctxt ct $ mconcat
- [ headline_msg
- , extraTyVarEqInfo ctxt tv1 ty2
- , suggestAddSig ctxt ty1 ty2
- , report
- ]
+ = mconcat [ headline_msg
+ , extraTyVarEqInfo ctxt tv1 ty2
+ , suggestAddSig ctxt ty1 ty2
+ , report
+ ]
| CTE_Occurs <- occ_check_expand
-- We report an "occurs check" even for a ~ F t a, where F is a type
-- function; it's not insoluble (because in principle F could reduce)
-- but we have certainly been unable to solve it
-- See Note [Occurs check error] in GHC.Tc.Solver.Canonical
- = do { let extra2 = mkEqInfoMsg ct ty1 ty2
-
- interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
- filter isTyVar $
- fvVarList $
- tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
- extra3 = mk_relevant_bindings $
- ppWhen (not (null interesting_tyvars)) $
- hang (text "Type variable kinds:") 2 $
- vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
- interesting_tyvars)
-
- tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $
- mconcat [headline_msg, extra2, extra3, report] }
+ = let extra2 = mkEqInfoMsg ct ty1 ty2
+
+ interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
+ filter isTyVar $
+ fvVarList $
+ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
+ extra3 = mk_relevant_bindings $
+ ppWhen (not (null interesting_tyvars)) $
+ hang (text "Type variable kinds:") 2 $
+ vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
+ interesting_tyvars)
+
+ tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+ in
+ mconcat [headline_msg, extra2, extra3, report]
| CTE_Bad <- occ_check_expand
- = do { let msg = vcat [ text "Cannot instantiate unification variable"
- <+> quotes (ppr tv1)
- , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]
+ = let msg = vcat [ text "Cannot instantiate unification variable"
+ <+> quotes (ppr tv1)
+ , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]
+ in
-- 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 ErrorWithoutFlag ctxt ct $ mconcat [ headline_msg, important msg, report ] }
+ 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
@@ -1589,35 +1571,35 @@ mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2
| (implic:_) <- cec_encl ctxt
, Implic { ic_skols = skols } <- implic
, tv1 `elem` skols
- = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat
- [ misMatchMsg ctxt ct ty1 ty2
- , extraTyVarEqInfo ctxt tv1 ty2
- , report
- ]
+ = mconcat [ misMatchMsg ctxt ct ty1 ty2
+ , extraTyVarEqInfo ctxt tv1 ty2
+ , report
+ ]
-- Check for skolem escape
| (implic:_) <- cec_encl ctxt -- Get the innermost context
, Implic { ic_skols = skols, ic_info = skol_info } <- implic
, let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
, not (null esc_skols)
- = do { let msg = misMatchMsg ctxt ct ty1 ty2
- esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
- <+> pprQuotedList esc_skols
- , text "would escape" <+>
- if isSingleton esc_skols then text "its scope"
- else text "their scope" ]
- tv_extra = important $
- vcat [ nest 2 $ esc_doc
- , sep [ (if isSingleton esc_skols
- then text "This (rigid, skolem)" <+>
- what <+> text "variable is"
- else text "These (rigid, skolem)" <+>
- what <+> text "variables are")
- <+> text "bound by"
- , nest 2 $ ppr skol_info
- , nest 2 $ text "at" <+>
- ppr (tcl_loc (ic_env implic)) ] ]
- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct (mconcat [msg, tv_extra, report]) }
+ = let msg = misMatchMsg ctxt ct ty1 ty2
+ esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
+ <+> pprQuotedList esc_skols
+ , text "would escape" <+>
+ if isSingleton esc_skols then text "its scope"
+ else text "their scope" ]
+ tv_extra = important $
+ vcat [ nest 2 $ esc_doc
+ , sep [ (if isSingleton esc_skols
+ then text "This (rigid, skolem)" <+>
+ what <+> text "variable is"
+ else text "These (rigid, skolem)" <+>
+ what <+> text "variables are")
+ <+> text "bound by"
+ , nest 2 $ ppr skol_info
+ , nest 2 $ text "at" <+>
+ ppr (tcl_loc (ic_env implic)) ] ]
+ in
+ 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
@@ -1628,21 +1610,21 @@ mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2
, Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic
= ASSERT2( not (isTouchableMetaTyVar lvl tv1)
, ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables]
- do { let msg = misMatchMsg ctxt ct ty1 ty2
- tclvl_extra = important $
- nest 2 $
- sep [ quotes (ppr tv1) <+> text "is untouchable"
- , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
- , nest 2 $ text "bound by" <+> ppr skol_info
- , nest 2 $ text "at" <+>
- ppr (tcl_loc (ic_env implic)) ]
- tv_extra = extraTyVarEqInfo ctxt tv1 ty2
- add_sig = suggestAddSig ctxt ty1 ty2
- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat
- [msg, tclvl_extra, tv_extra, add_sig, report] }
+ let msg = misMatchMsg ctxt ct ty1 ty2
+ tclvl_extra = important $
+ nest 2 $
+ sep [ quotes (ppr tv1) <+> text "is untouchable"
+ , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
+ , nest 2 $ text "bound by" <+> ppr skol_info
+ , nest 2 $ text "at" <+>
+ ppr (tcl_loc (ic_env implic)) ]
+ tv_extra = extraTyVarEqInfo ctxt tv1 ty2
+ add_sig = suggestAddSig ctxt ty1 ty2
+ in
+ mconcat [msg, tclvl_extra, tv_extra, add_sig, report]
| otherwise
- = reportEqErr ErrorWithoutFlag ctxt report ct (mkTyVarTy tv1) ty2
+ = reportEqErr 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.
@@ -1733,10 +1715,9 @@ 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 DiagnosticMessage)
-mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct report
+mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM Report
+mkBlockedEqErr _ (ct:_) = return $ important msg
where
- report = important msg
msg = vcat [ hang (text "Cannot use equality for substitution:")
2 (ppr (ctPred ct))
, text "Doing so would be ill-kinded." ]
@@ -2340,12 +2321,11 @@ Warn of loopy local equalities that were dropped.
************************************************************************
-}
-mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)
+mkDictErr :: ReportErrCtxt -> [Ct] -> TcM Report
mkDictErr ctxt cts
= ASSERT( not (null cts) )
do { inst_envs <- tcGetInstEnvs
- ; let (ct1:_) = cts -- ct1 just for its location
- min_cts = elim_superclasses cts
+ ; let min_cts = elim_superclasses cts
lookups = map (lookup_cls_inst inst_envs) min_cts
(no_inst_cts, overlap_cts) = partition is_no_inst lookups
@@ -2354,8 +2334,8 @@ mkDictErr ctxt cts
-- But we report only one of them (hence 'head') because they all
-- 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 ErrorWithoutFlag ctxt ct1 (important err) }
+ ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
+ ; return $ important err }
where
no_givens = null (getUserGivens ctxt)
@@ -2377,20 +2357,20 @@ mkDictErr ctxt cts
elim_superclasses cts = mkMinimalBySCs ctPred cts
mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
- -> TcM (ReportErrCtxt, SDoc)
+ -> TcM SDoc
-- Report an overlap error if this class constraint results
-- from an overlap (returning Left clas), otherwise return (Right pred)
mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))
| null matches -- No matches but perhaps several unifiers
- = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+ = do { (_, binds_msg, ct) <- relevantBindings True ctxt ct
; candidate_insts <- get_candidate_instances
- ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }
+ ; return (cannot_resolve_msg ct candidate_insts binds_msg) }
| null unsafe_overlapped -- Some matches => overlap errors
- = return (ctxt, overlap_msg)
+ = return overlap_msg
| otherwise
- = return (ctxt, safe_haskell_msg)
+ = return safe_haskell_msg
where
orig = ctOrigin ct
pred = ctPred ct
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 8833abe03d..0883ba1c8b 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -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 ErrorWithoutFlag loc $
+ err_msg = mkPlainErrorMsgEnvelope loc $
text "Module does not have a RealSrcSpan:" <+> ppr this_mod
pair :: (Module, SrcSpan)
@@ -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 ( mkPlainMsgEnvelope WarningWithoutFlag noSrcSpan
+ pluginUnsafe = unitBag ( mkPlainMsgEnvelope dflags WarningWithoutFlag noSrcSpan
(Outputable.text unsafeText) )
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 6fb31e2d7d..a8f6cbbc19 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -1033,8 +1033,9 @@ mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DiagnosticMessage)
mkLongErrAt loc msg extra
= do { printer <- getPrintUnqualified ;
unit_state <- hsc_units <$> getTopEnv ;
+ dflags <- getDynFlags ;
let msg' = pprWithUnitState unit_state msg in
- return $ mkLongMsgEnvelope ErrorWithoutFlag loc printer msg' extra }
+ return $ mkLongMsgEnvelope dflags ErrorWithoutFlag loc printer msg' extra }
mkDecoratedSDocAt :: DiagnosticReason
-> SrcSpan
@@ -1048,11 +1049,12 @@ mkDecoratedSDocAt :: DiagnosticReason
mkDecoratedSDocAt reason loc important context extra
= do { printer <- getPrintUnqualified ;
unit_state <- hsc_units <$> getTopEnv ;
+ dflags <- getDynFlags ;
let f = pprWithUnitState unit_state
errDoc = [important, context, extra]
errDoc' = DiagnosticMessage (mkDecorated $ map f errDoc) reason
in
- return $ mkMsgEnvelope (defaultReasonSeverity reason) loc printer errDoc' }
+ return $ mkMsgEnvelope dflags loc printer errDoc' }
addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn ()
addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic
@@ -1558,7 +1560,8 @@ add_diagnostic reason msg extra_info
add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn ()
add_diagnostic_at reason loc msg extra_info
= do { printer <- getPrintUnqualified ;
- let { dia = mkLongMsgEnvelope reason
+ dflags <- getDynFlags ;
+ let { dia = mkLongMsgEnvelope dflags reason
loc printer
msg extra_info } ;
reportDiagnostic dia }
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index 7edf599c9f..48cb9eaedd 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -19,7 +19,6 @@ module GHC.Types.Error
, MessageClass (..)
, Severity (..)
- , mkMCDiagnostic
, Diagnostic (..)
, DiagnosticMessage (..)
, DiagnosticReason (..)
@@ -33,14 +32,8 @@ module GHC.Types.Error
, mkLocMessage
, mkLocMessageAnn
, getCaretDiagnostic
- -- * Constructing individual diagnostic messages
- , mkMsgEnvelope
- , mkPlainMsgEnvelope
- , mkLongMsgEnvelope
- , mkShortMsgEnvelope
- , defaultReasonSeverity
-- * Queries
- , isErrorMessage
+ , isIntrinsicErrorMessage
, isWarningMessage
, getErrorMessages
, getWarningMessages
@@ -193,9 +186,9 @@ data DiagnosticReason
instance Outputable DiagnosticReason where
ppr = \case
- WarningWithoutFlag -> text "WarningWithoutFlag"
- WarningWithFlag wf -> text ("WarningWithFlag " ++ show wf)
- ErrorWithoutFlag -> text "ErrorWithoutFlag"
+ 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.
@@ -237,11 +230,6 @@ data MessageClass
-- /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,
@@ -325,14 +313,6 @@ mkLocMessageAnn ann msg_class locn msg
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
@@ -416,76 +396,40 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) =
caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
--
--- Creating MsgEnvelope(s)
+-- Queries
--
-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
- }
-
--- | 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)
+{- Note [Intrinsic And Extrinsic Failures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in the former category
+those diagnostics which are /essentially/ failures, and their nature can't be changed. This is
+the case for 'ErrorWithoutFlag'. We classify as /extrinsic/ all those diagnostics (like fatal warnings)
+which are born as warnings but which are still failures under particular 'DynFlags' settings. It's important
+to be aware of such logic distinction, because when we are inside the typechecker or the desugarer, we are
+interested about intrinsic errors, and to bail out as soon as we find one of them. Conversely, if we find
+an /extrinsic/ one, for example because a particular 'WarningFlag' makes a warning and error, we /don't/
+want to bail out, that's still not the right time to do so: Rather, we want to first collect all the
+diagnostics, and later classify and report them appropriately (in the driver).
+
+-}
---
--- Queries
---
-isErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool
-isErrorMessage MsgEnvelope { errMsgSeverity = SevError } = True
-isErrorMessage _ = False
+-- | Returns 'True' if this is, intrinsically, a failure. See Note [Intrinsic And Extrinsic Failures].
+isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool
+isIntrinsicErrorMessage = (==) ErrorWithoutFlag . diagnosticReason . errMsgDiagnostic
isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool
-isWarningMessage = not . isErrorMessage
+isWarningMessage = not . isIntrinsicErrorMessage
errorsFound :: Diagnostic e => Messages e -> Bool
-errorsFound (Messages msgs) = any isErrorMessage msgs
+errorsFound (Messages msgs) = any isIntrinsicErrorMessage msgs
getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs
getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e)
-getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs
+getErrorMessages (Messages xs) = fst $ partitionBag isIntrinsicErrorMessage xs
-- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the
-- second the errors.
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index aba5e64357..2ee1763ebb 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -31,8 +31,9 @@ module GHC.Utils.Error (
-- ** Construction
emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn,
- mkMsgEnvelope, mkPlainMsgEnvelope, mkLongMsgEnvelope,
- mkMCDiagnostic,
+ mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
+ mkShortMsgEnvelope, mkShortErrorMsgEnvelope, mkLongMsgEnvelope,
+ mkMCDiagnostic, errorDiagnostic, diagReasonSeverity,
-- * Utilities
doIfSet, doIfSet_dyn,
@@ -80,6 +81,106 @@ import Control.Monad.Catch as MC (handle)
import GHC.Conc ( getAllocationCounter )
import System.CPUTime
+-- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of
+-- the 'DynFlags'. This function /has/ to be called when a diagnostic is constructed,
+-- i.e. with a 'DynFlags' \"snapshot\" taken as close as possible to where a
+-- particular diagnostic message is built, otherwise the computed 'Severity' might
+-- not be correct, due to the mutable nature of the 'DynFlags' in GHC.
+diagReasonSeverity :: DynFlags -> DiagnosticReason -> Severity
+diagReasonSeverity dflags (WarningWithFlag wflag) | wopt_fatal wflag dflags = SevError
+ | otherwise = SevWarning
+diagReasonSeverity dflags WarningWithoutFlag | gopt Opt_WarnIsError dflags = SevError
+ | otherwise = SevWarning
+diagReasonSeverity _ ErrorWithoutFlag = SevError
+
+
+
+--
+-- Creating MsgEnvelope(s)
+--
+
+mk_msg_envelope
+ :: Diagnostic e
+ => Severity
+ -> SrcSpan
+ -> PrintUnqualified
+ -> e
+ -> MsgEnvelope e
+mk_msg_envelope severity locn print_unqual err
+ = MsgEnvelope { errMsgSpan = locn
+ , errMsgContext = print_unqual
+ , errMsgDiagnostic = err
+ , errMsgSeverity = severity
+ }
+
+mkMsgEnvelope
+ :: Diagnostic e
+ => DynFlags
+ -> SrcSpan
+ -> PrintUnqualified
+ -> e
+ -> MsgEnvelope e
+mkMsgEnvelope dflags locn print_unqual err
+ = mk_msg_envelope (diagReasonSeverity dflags (diagnosticReason err)) locn print_unqual err
+
+-- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the 'DynFlags'.
+mkMCDiagnostic :: DynFlags -> DiagnosticReason -> MessageClass
+mkMCDiagnostic dflags reason = MCDiagnostic (diagReasonSeverity dflags reason) reason
+
+-- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the
+-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'.
+errorDiagnostic :: MessageClass
+errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag
+
+-- | 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 :: DynFlags
+ -> DiagnosticReason
+ -> SrcSpan
+ -> PrintUnqualified
+ -> SDoc
+ -> SDoc
+ -> MsgEnvelope DiagnosticMessage
+mkLongMsgEnvelope dflags rea locn unqual msg extra =
+ mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg,extra]) rea)
+
+-- | A short (one-line) diagnostic message.
+-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
+mkShortMsgEnvelope :: DynFlags
+ -> DiagnosticReason
+ -> SrcSpan
+ -> PrintUnqualified
+ -> SDoc
+ -> MsgEnvelope DiagnosticMessage
+mkShortMsgEnvelope dflags rea locn unqual msg =
+ mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg]) rea)
+
+mkShortErrorMsgEnvelope :: SrcSpan
+ -> PrintUnqualified
+ -> SDoc
+ -> MsgEnvelope DiagnosticMessage
+mkShortErrorMsgEnvelope locn unqual msg =
+ mk_msg_envelope SevError locn unqual (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag)
+
+-- | Variant that doesn't care about qualified/unqualified names.
+-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'.
+mkPlainMsgEnvelope :: DynFlags
+ -> DiagnosticReason
+ -> SrcSpan
+ -> SDoc
+ -> MsgEnvelope DiagnosticMessage
+mkPlainMsgEnvelope dflags rea locn msg =
+ mkMsgEnvelope dflags locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea)
+
+-- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we
+-- are constructing a diagnostic with a 'ErrorWithoutFlag' reason.
+mkPlainErrorMsgEnvelope :: SrcSpan
+ -> SDoc
+ -> MsgEnvelope DiagnosticMessage
+mkPlainErrorMsgEnvelope locn msg =
+ mk_msg_envelope SevError locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag)
+
-------------------------
data Validity
= IsValid -- ^ Everything is fine
@@ -171,12 +272,12 @@ ifVerbose dflags val act
errorMsg :: Logger -> DynFlags -> SDoc -> IO ()
errorMsg logger dflags msg
- = putLogMsg logger dflags (mkMCDiagnostic ErrorWithoutFlag) noSrcSpan $
+ = putLogMsg logger dflags errorDiagnostic noSrcSpan $
withPprStyle defaultErrStyle msg
warningMsg :: Logger -> DynFlags -> SDoc -> IO ()
warningMsg logger dflags msg
- = putLogMsg logger dflags (mkMCDiagnostic WarningWithoutFlag) noSrcSpan $
+ = putLogMsg logger dflags (mkMCDiagnostic dflags WarningWithoutFlag) noSrcSpan $
withPprStyle defaultErrStyle msg
fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index cc4dcf7f9b..496c4dc6a0 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -117,8 +117,8 @@ compileCmmForRegAllocStats logger dflags' cmmFile ncgImplF us = do
-- parse the cmm file and output any warnings or errors
let fake_mod = mkHomeModule (hsc_home_unit hscEnv) (mkModuleName "fake")
(warnings, errors, parsedCmm) <- parseCmmFile dflags fake_mod (hsc_home_unit hscEnv) cmmFile
- let warningMsgs = fmap pprWarning warnings
- errorMsgs = fmap pprError errors
+ let warningMsgs = fmap (mkParserWarn dflags') warnings
+ errorMsgs = fmap mkParserErr errors
-- print parser errors or warnings
mapM_ (printBagOfErrors logger dflags) [warningMsgs, errorMsgs]
diff --git a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr
index ce90de4c72..4a4fb3779c 100644
--- a/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr
+++ b/testsuite/tests/safeHaskell/overlapping/SH_Overlap7.stderr
@@ -5,7 +5,7 @@
SH_Overlap7.hs:2:16: error: [-Wunsafe, -Werror=unsafe]
‘SH_Overlap7’ has been inferred as unsafe!
Reason:
- SH_Overlap7.hs:15:8: warning:
+ SH_Overlap7.hs:15:8:
• Unsafe overlapping instances for C [Int]
arising from a use of ‘f’
The matching instance is:
diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs
index eccf3f2612..f1437869ee 100644
--- a/utils/check-exact/Parsers.hs
+++ b/utils/check-exact/Parsers.hs
@@ -87,7 +87,7 @@ parseWith :: GHC.DynFlags
-> ParseResult w
parseWith dflags fileName parser s =
case runParser parser dflags fileName s of
- GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+ GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst)
GHC.POk _ pmod -> Right pmod
@@ -101,7 +101,7 @@ parseWithECP dflags fileName parser s =
-- case runParser ff dflags fileName s of
-- case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of
case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of
- GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+ GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst)
GHC.POk _ pmod -> Right pmod
-- ---------------------------------------------------------------------
@@ -192,7 +192,7 @@ parseModuleFromStringInternal :: Parser GHC.ParsedSource
parseModuleFromStringInternal dflags fileName str =
let (str1, lp) = stripLinePragmas str
res = case runParser GHC.parseModule dflags fileName str1 of
- GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+ GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst)
GHC.POk _ pmod -> Right (lp, dflags, pmod)
in postParseTransform res
@@ -263,7 +263,7 @@ parseModuleEpAnnsWithCppInternal cppOptions dflags file = do
return (contents1,lp,dflags)
return $
case parseFile dflags' file fileContents of
- GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst)
+ GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst)
GHC.POk _ pmod ->
Right $ (injectedComments, dflags', pmod)
diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs
index 761029adb2..904e76938e 100644
--- a/utils/check-exact/Preprocess.hs
+++ b/utils/check-exact/Preprocess.hs
@@ -277,7 +277,7 @@ parseError pst = do
let
-- (warns,errs) = GHC.getMessages pst dflags
-- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)
- GHC.throwErrors (fmap GHC.pprError (GHC.getErrorMessages pst))
+ GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst))
-- ---------------------------------------------------------------------
diff --git a/utils/haddock b/utils/haddock
-Subproject c623c7d2df417caac4b72b747ef5262d86ee776
+Subproject eebc74dc08987fdd9b1c289be38207af9b0334c