summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Deriv.hs8
-rw-r--r--compiler/GHC/Tc/Errors.hs431
-rw-r--r--compiler/GHC/Tc/Gen/Annotation.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs8
-rw-r--r--compiler/GHC/Tc/Gen/Foreign.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs16
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs4
-rw-r--r--compiler/GHC/Tc/Module.hs34
-rw-r--r--compiler/GHC/Tc/Solver.hs6
-rw-r--r--compiler/GHC/Tc/Solver/Monad.hs2
-rw-r--r--compiler/GHC/Tc/TyCl.hs4
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs18
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs2
-rw-r--r--compiler/GHC/Tc/Types.hs3
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs7
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs148
-rw-r--r--compiler/GHC/Tc/Validity.hs12
20 files changed, 373 insertions, 350 deletions
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
View Lorry Controller Status