diff options
26 files changed, 178 insertions, 172 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 4ba5e9b68a..134580c653 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -899,7 +899,7 @@ checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags checkNewDynFlags logger dflags = do -- See Note [DynFlags consistency] let (dflags', warnings) = makeDynFlagsConsistent dflags - liftIO $ handleFlagWarnings logger dflags (map (Warn NoReason) warnings) + liftIO $ handleFlagWarnings logger dflags (map (Warn WarningWithoutFlag) warnings) return dflags' checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags @@ -1949,4 +1949,3 @@ instance Exception GhcApiError mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) - diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs index 50d8276278..568e83e795 100644 --- a/compiler/GHC/Driver/CmdLine.hs +++ b/compiler/GHC/Driver/CmdLine.hs @@ -20,8 +20,7 @@ module GHC.Driver.CmdLine Err(..), Warn(..), WarnReason(..), - EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, - deprecate + EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM ) where #include "HsVersions.h" @@ -35,6 +34,8 @@ import GHC.Data.Bag import GHC.Types.SrcLoc import GHC.Utils.Json +import GHC.Types.Error ( DiagnosticReason(..) ) + import Data.Function import Data.List (sortBy, intercalate, stripPrefix) @@ -107,7 +108,7 @@ newtype Err = Err { errMsg :: Located String } -- | A command-line warning message and the reason it arose data Warn = Warn - { warnReason :: WarnReason, + { warnReason :: DiagnosticReason, warnMsg :: Located String } @@ -141,17 +142,12 @@ addErr :: Monad m => String -> EwM m () addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) addWarn :: Monad m => String -> EwM m () -addWarn = addFlagWarn NoReason +addWarn = addFlagWarn WarningWithoutFlag -addFlagWarn :: Monad m => WarnReason -> String -> EwM m () +addFlagWarn :: Monad m => DiagnosticReason -> String -> EwM m () addFlagWarn reason msg = EwM $ (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) -deprecate :: Monad m => String -> EwM m () -deprecate s = do - arg <- getArg - addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s) - getArg :: Monad m => EwM m String getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index b6fdee5c9b..eafcfe73f3 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -36,23 +36,22 @@ printBagOfErrors logger dflags bag_of_errors handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO () handleFlagWarnings logger dflags warns = do - let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns - + let warns' = filter (should_print_warning dflags . CmdLine.warnReason) warns -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems. bag = listToBag [ mkPlainMsgEnvelope dflags WarningWithoutFlag loc (text warn) | CmdLine.Warn _ (L loc warn) <- warns' ] printOrThrowDiagnostics logger dflags bag - --- Given a warn reason, check to see if it's associated -W opt is enabled -shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool -shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag - = wopt Opt_WarnDeprecatedFlags dflags -shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag - = wopt Opt_WarnUnrecognisedWarningFlags dflags -shouldPrintWarning _ _ - = True + where + -- Given a warn reason, check to see if it's associated -W opt is enabled + should_print_warning :: DynFlags -> DiagnosticReason -> Bool + should_print_warning dflags (WarningWithFlag Opt_WarnDeprecatedFlags) + = wopt Opt_WarnDeprecatedFlags dflags + should_print_warning dflags (WarningWithFlag Opt_WarnUnrecognisedWarningFlags) + = wopt Opt_WarnUnrecognisedWarningFlags dflags + should_print_warning _ _ + = True -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index b677f63681..484353ae4d 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -270,7 +270,7 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check -- The warning in enabled by `-Wmissing-home-modules`. See #13129 warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () warnMissingHomeModules hsc_env mod_graph = - when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $ + when (not (null missing)) $ logWarnings (listToBag [warn]) where dflags = hsc_dflags hsc_env @@ -391,7 +391,7 @@ warnUnusedPackages = do , text "but were not needed for compilation:" , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] - when (wopt Opt_WarnUnusedPackages dflags && not (null unusedArgs)) $ + when (not (null unusedArgs)) $ logWarnings (listToBag [warn]) where diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index b3052978af..c1142137cc 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -235,7 +235,6 @@ import GHC.Settings.Config import GHC.Utils.CliOption import {-# SOURCE #-} GHC.Core.Unfold import GHC.Driver.CmdLine -import qualified GHC.Driver.CmdLine as Cmd import GHC.Settings.Constants import GHC.Utils.Panic import qualified GHC.Utils.Ppr.Colour as Col @@ -1869,7 +1868,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do liftIO $ setUnsafeGlobalDynFlags dflags4 - let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) + let warns' = map (Warn WarningWithoutFlag) (consistency_warnings ++ sh_warns) return (dflags4, leftover, warns' ++ warns) @@ -2889,7 +2888,7 @@ unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action) action :: String -> EwM (CmdLineP DynFlags) () action flag = do f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState - when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $ + when f $ addFlagWarn (WarningWithFlag Opt_WarnUnrecognisedWarningFlags) $ "unrecognised warning flag: -" ++ prefix ++ flag -- See Note [Supporting CLI completion] @@ -3050,6 +3049,12 @@ mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) = (dep, Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) +-- here to avoid module cycle with GHC.Driver.CmdLine +deprecate :: Monad m => String -> EwM m () +deprecate s = do + arg <- getArg + addFlagWarn (WarningWithFlag Opt_WarnDeprecatedFlags) (arg ++ " is deprecated: " ++ s) + deprecatedForExtension :: String -> TurnOnFlag -> String deprecatedForExtension lang turn_on = "use -X" ++ flag ++ diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index c9dacae70d..a4bbc290e2 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -90,7 +90,6 @@ import GHC.Unit.Module.ModIface import Data.List (partition) import Data.IORef -import Control.Monad( when ) import GHC.Driver.Plugins ( LoadedPlugin(..) ) {- @@ -438,8 +437,7 @@ dsRule (L loc (HsRule { rd_name = name ; rule <- dsMkUserRule this_mod is_local rule_name rule_act fn_name final_bndrs args final_rhs - ; when (wopt Opt_WarnInlineRuleShadowing dflags) $ - warnRuleShadowing rule_name rule_act fn_id arg_ids + ; warnRuleShadowing rule_name rule_act fn_id arg_ids ; return (Just rule) } } } diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 928db49ddc..7af84d1d06 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -767,8 +767,7 @@ dsMkUserRule :: Module -> Bool -> RuleName -> Activation -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule dsMkUserRule this_mod is_local name act fn bndrs args rhs = do let rule = mkRule this_mod False is_local name act fn bndrs args rhs - dflags <- getDynFlags - when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $ + when (isOrphan (ru_orphan rule)) $ diagnosticDs (WarningWithFlag Opt_WarnOrphans) (ruleOrphWarn rule) return rule diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index da2794f805..67b3d0d8c0 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -1047,8 +1047,7 @@ lookup_demoted rdr_name ; case mb_demoted_name of Nothing -> unboundNameX WL_Any rdr_name star_info Just demoted_name -> - do { whenWOptM Opt_WarnUntickedPromotedConstructors $ - addDiagnostic + do { addDiagnostic (WarningWithFlag Opt_WarnUntickedPromotedConstructors) (untickedPromConstrWarn demoted_name) ; return demoted_name } } diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 07cc79fd17..fbdcc15730 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -1648,8 +1648,7 @@ dataKindsErr env thing warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names - = whenWOptM Opt_WarnUnusedForalls $ - unless (hsTyVarName tv `elemNameSet` used_names) $ + = unless (hsTyVarName tv `elemNameSet` used_names) $ addDiagnosticAt (WarningWithFlag Opt_WarnUnusedForalls) (locA loc) $ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , inHsDocContext doc ] diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index b5c91c8cc3..d5a787f9ab 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1945,16 +1945,15 @@ warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> RnM () warnNoDerivStrat mds loc = do { dyn_flags <- getDynFlags - ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $ - case mds of - Nothing -> addDiagnosticAt - (WarningWithFlag Opt_WarnMissingDerivingStrategies) - loc - (if xopt LangExt.DerivingStrategies dyn_flags - then no_strat_warning - else no_strat_warning $+$ deriv_strat_nenabled - ) - _ -> pure () + ; case mds of + Nothing -> addDiagnosticAt + (WarningWithFlag Opt_WarnMissingDerivingStrategies) + loc + (if xopt LangExt.DerivingStrategies dyn_flags + then no_strat_warning + else no_strat_warning $+$ deriv_strat_nenabled + ) + _ -> pure () } where no_strat_warning :: SDoc diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index aa5019895f..0502d8d962 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -394,12 +394,10 @@ rnImportDecl this_mod imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv) -- Complain if we import a deprecated module - whenWOptM Opt_WarnWarningsDeprecations ( - case (mi_warns iface) of - WarnAll txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) - (moduleWarn imp_mod_name txt) - _ -> return () - ) + case mi_warns iface of + WarnAll txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) + (moduleWarn imp_mod_name txt) + _ -> return () -- Complain about -Wcompat-unqualified-imports violations. warnUnqualifiedImport decl iface @@ -522,8 +520,7 @@ calculateAvails home_unit iface mod_safe' want_boot imported_by = -- Currently not used for anything. warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () warnUnqualifiedImport decl iface = - whenWOptM Opt_WarnCompatUnqualifiedImports - $ when bad_import + when bad_import $ addDiagnosticAt (WarningWithFlag Opt_WarnCompatUnqualifiedImports) loc warning where mod = mi_module iface diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index b41170014c..f3bab6c3fe 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -912,10 +912,9 @@ check_cross_stage_lifting top_lvl name ps_var pend_splice = PendingRnSplice UntypedExpSplice name lift_expr -- Warning for implicit lift (#17804) - ; whenWOptM Opt_WarnImplicitLift $ - addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift) - (text "The variable" <+> quotes (ppr name) <+> - text "is implicitly lifted in the TH quotation") + ; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift) + (text "The variable" <+> quotes (ppr name) <+> + text "is implicitly lifted in the TH quotation") -- Update the pending splices ; ps <- readMutVar ps_var diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 198bfa2477..40761ed38c 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -738,10 +738,9 @@ tcStandaloneDerivInstType ctxt warnUselessTypeable :: TcM () warnUselessTypeable - = do { warn <- woptM Opt_WarnDerivingTypeable - ; when warn $ addDiagnosticTc (WarningWithFlag Opt_WarnDerivingTypeable) - $ text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" } + = do { addDiagnosticTc (WarningWithFlag Opt_WarnDerivingTypeable) + $ text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" } ------------------------------------------------------------------ deriveTyData :: TyCon -> [Type] -- LHS of data or data instance @@ -1610,8 +1609,7 @@ mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys = cls_tys -- DeriveAnyClass, but emitting a warning about the choice. -- See Note [Deriving strategies] when (newtype_deriving && deriveAnyClass) $ - lift $ whenWOptM Opt_WarnDerivingDefaults $ - addDiagnosticTc (WarningWithFlag Opt_WarnDerivingDefaults) $ sep + lift $ addDiagnosticTc (WarningWithFlag Opt_WarnDerivingDefaults) $ sep [ text "Both DeriveAnyClass and" <+> text "GeneralizedNewtypeDeriving are enabled" , text "Defaulting to the DeriveAnyClass strategy" diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index abb58cd58b..dda7c0eeac 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -50,7 +50,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name.Set import GHC.Data.Bag -import GHC.Utils.Error ( pprLocMsgEnvelope ) +import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) import GHC.Types.Basic import GHC.Types.Error import GHC.Core.ConLike ( ConLike(..)) @@ -66,10 +66,9 @@ import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.FV ( fvVarList, unionFV ) -import Control.Monad ( unless, when ) +import Control.Monad ( unless, when, forM_ ) import Data.Foldable ( toList ) import Data.List ( partition, mapAccumL, sortBy, unfoldr ) -import Data.Traversable ( for ) import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) @@ -132,34 +131,24 @@ reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) reportUnsolved wanted = do { binds_var <- newTcEvBinds ; defer_errors <- goptM Opt_DeferTypeErrors - ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283 - ; let type_errors | not defer_errors = Just ErrorWithoutFlag - | warn_errors = Just (WarningWithFlag Opt_WarnDeferredTypeErrors) - | otherwise = Nothing + ; let type_errors | not defer_errors = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors ; defer_holes <- goptM Opt_DeferTypedHoles - ; warn_holes <- woptM Opt_WarnTypedHoles - ; let expr_holes | not defer_holes = Just ErrorWithoutFlag - | warn_holes = Just (WarningWithFlag Opt_WarnTypedHoles) - | otherwise = Nothing + ; let expr_holes | not defer_holes = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnTypedHoles ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures ; let type_holes | not partial_sigs - = Just ErrorWithoutFlag - | warn_partial_sigs - = Just (WarningWithFlag Opt_WarnPartialTypeSignatures) + = ErrorWithoutFlag | otherwise - = Nothing + = WarningWithFlag Opt_WarnPartialTypeSignatures ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables - ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables ; let out_of_scope_holes | not defer_out_of_scope - = Just ErrorWithoutFlag - | warn_out_of_scope - = Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables) + = ErrorWithoutFlag | otherwise - = Nothing + = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables ; report_unsolved type_errors expr_holes type_holes out_of_scope_holes @@ -180,13 +169,11 @@ reportAllUnsolved wanted = do { ev_binds <- newNoTcEvBinds ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures - ; let type_holes | not partial_sigs = Just ErrorWithoutFlag - | warn_partial_sigs = Just (WarningWithFlag Opt_WarnPartialTypeSignatures) - | otherwise = Nothing + ; let type_holes | not partial_sigs = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures - ; report_unsolved (Just ErrorWithoutFlag) - (Just ErrorWithoutFlag) type_holes (Just ErrorWithoutFlag) + ; report_unsolved ErrorWithoutFlag + ErrorWithoutFlag type_holes ErrorWithoutFlag ev_binds wanted } -- | Report all unsolved goals as warnings (but without deferring any errors to @@ -195,17 +182,17 @@ reportAllUnsolved wanted warnAllUnsolved :: WantedConstraints -> TcM () warnAllUnsolved wanted = do { ev_binds <- newTcEvBinds - ; report_unsolved (Just WarningWithoutFlag) - (Just WarningWithoutFlag) - (Just WarningWithoutFlag) - (Just WarningWithoutFlag) + ; report_unsolved WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag ev_binds wanted } -- | Report unsolved goals as errors or warnings. -report_unsolved :: Maybe DiagnosticReason -- Deferred type errors - -> Maybe DiagnosticReason -- Expression holes - -> Maybe DiagnosticReason -- Type holes - -> Maybe DiagnosticReason -- Out of scope holes +report_unsolved :: DiagnosticReason -- Deferred type errors + -> DiagnosticReason -- Expression holes + -> DiagnosticReason -- Type holes + -> DiagnosticReason -- Out of scope holes -> EvBindsVar -- cec_binds -> WantedConstraints -> TcM () report_unsolved type_errors expr_holes @@ -320,15 +307,15 @@ data ReportErrCtxt -- into warnings, and emit evidence bindings -- into 'cec_binds' for unsolved constraints - , cec_defer_type_errors :: Maybe DiagnosticReason -- Nothing: Defer type errors until runtime + , cec_defer_type_errors :: DiagnosticReason -- 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 :: 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_expr_holes :: DiagnosticReason -- Holes in expressions. + , cec_type_holes :: DiagnosticReason -- Holes in types. + , cec_out_of_scope_holes :: DiagnosticReason -- Out of scope holes. , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints , cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms @@ -361,19 +348,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 = Just ErrorWithoutFlag - , cec_expr_holes = Just ErrorWithoutFlag - , cec_out_of_scope_holes = Just ErrorWithoutFlag }) = False -deferringAnyBindings _ = True +deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag + , cec_expr_holes = ErrorWithoutFlag + , cec_out_of_scope_holes = 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 = Just ErrorWithoutFlag - , cec_expr_holes = Just ErrorWithoutFlag - , cec_out_of_scope_holes = Just ErrorWithoutFlag } + = ctxt { cec_defer_type_errors = ErrorWithoutFlag + , cec_expr_holes = ErrorWithoutFlag + , cec_out_of_scope_holes = ErrorWithoutFlag } | otherwise = ctxt @@ -727,22 +714,22 @@ mkSkolReporter ctxt cts reportHoles :: [Ct] -- other (tidied) constraints -> ReportErrCtxt -> [Hole] -> TcM () -reportHoles tidy_cts ctxt - = mapM_ $ \hole -> unless (ignoreThisHole ctxt hole) $ - do { msg_mb <- mkHoleError tidy_cts ctxt hole - ; whenIsJust msg_mb reportDiagnostic } +reportHoles tidy_cts ctxt holes + = do df <- getDynFlags + forM_ holes $ \hole -> unless (ignoreThisHole df ctxt hole) $ + mkHoleError tidy_cts ctxt hole >>= reportDiagnostic -ignoreThisHole :: ReportErrCtxt -> Hole -> Bool +ignoreThisHole :: DynFlags -> ReportErrCtxt -> Hole -> Bool -- See Note [Skip type holes rapidly] -ignoreThisHole ctxt hole +ignoreThisHole df ctxt hole = case hole_sort hole of ExprHole {} -> False TypeHole -> ignore_type_hole ConstraintHole -> ignore_type_hole where - ignore_type_hole = case cec_type_holes ctxt of - Nothing -> True - _ -> False + ignore_type_hole = case diagReasonSeverity df (cec_type_holes ctxt) of + SevIgnore -> True + _ -> False {- Note [Skip type holes rapidly] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -894,14 +881,11 @@ suppressGroup mk_err ctxt cts maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM () maybeReportError ctxt ct report - | Just reason <- cec_defer_type_errors ctxt = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic - do msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report + do let reason = cec_defer_type_errors ctxt + msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report reportDiagnostic msg - | otherwise - = return () -- nothing to report - addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct @@ -1164,7 +1148,7 @@ See also 'reportUnsolved'. ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. -mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (Maybe (MsgEnvelope DiagnosticMessage)) +mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DiagnosticMessage) mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) @@ -1180,8 +1164,7 @@ mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ (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 + ; mkErrorReportNC (cec_out_of_scope_holes ctxt) lcl_env err -- Use NC variant: the context is generally not helpful here } where @@ -1223,7 +1206,7 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ ; let holes | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt - ; for holes $ \ rea -> mkErrorReport rea ctxt lcl_env err + ; mkErrorReport holes ctxt lcl_env err } where @@ -1260,7 +1243,7 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ -- hole, via kind casts type_hole_hint - | Just ErrorWithoutFlag <- cec_type_holes ctxt + | ErrorWithoutFlag <- cec_type_holes ctxt = text "To use the inferred type, enable PartialTypeSignatures" | otherwise = empty diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 228c3d3644..10294998c0 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -801,9 +801,7 @@ mkExport prag_fn insoluble qtvs theta else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty - ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures - ; when warn_missing_sigs $ - localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig + ; localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig ; return (ABE { abe_ext = noExtField , abe_wrap = wrap diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 552b010994..a874e04fd7 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -236,9 +236,8 @@ exports_from_avail Nothing rdr_env _imports _this_mod -- so that's how we handle it, except we also export the data family -- when a data instance is exported. = do { - ; warnMissingExportList <- woptM Opt_WarnMissingExportList ; warnIfFlag Opt_WarnMissingExportList - warnMissingExportList + True (missingModuleExportWarn $ moduleName _this_mod) ; let avails = map fix_faminst . gresToAvailInfo @@ -393,12 +392,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod let gres = findChildren kids_env name (non_flds, flds) = classifyGREs gres addUsedKids (ieWrappedName rdr) gres - warnDodgyExports <- woptM Opt_WarnDodgyExports when (null gres) $ if isTyConName name - then when warnDodgyExports $ - addDiagnostic (WarningWithFlag Opt_WarnDodgyExports) - (dodgyExportWarn name) + then 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 662a418116..ecd07c6059 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -1409,8 +1409,7 @@ checkMissingFields con_like rbinds arg_tys -- Illegal if any arg is strict addErrTc (missingStrictFields con_like []) else do - warn <- woptM Opt_WarnMissingFields - when (warn && notNull field_strs && null field_labels) + when (notNull field_strs && null field_labels) (diagnosticTc (WarningWithFlag Opt_WarnMissingFields) True (missingFields con_like [])) diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index d823cdbafb..57b99e703a 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -324,7 +324,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - checkMissingAmpersand dflags (map scaledThing arg_tys) res_ty + checkMissingAmpersand (map scaledThing arg_tys) res_ty case target of StaticTarget _ _ _ False | not (null arg_tys) -> @@ -343,10 +343,9 @@ checkCTarget (StaticTarget _ str _ _) = do checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" -checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () -checkMissingAmpersand dflags arg_tys res_ty - | null arg_tys && isFunPtrTy res_ty && - wopt Opt_WarnDodgyForeignImports dflags +checkMissingAmpersand :: [Type] -> Type -> TcM () +checkMissingAmpersand arg_tys res_ty + | null arg_tys && isFunPtrTy res_ty = addDiagnosticTc (WarningWithFlag Opt_WarnDodgyForeignImports) (text "possible missing & in foreign import of FunPtr") | otherwise @@ -534,9 +533,8 @@ checkCConv StdCallConv = do dflags <- getDynFlags if platformArch platform == ArchX86 then return StdCallConv else do -- This is a warning, not an error. see #3336 - when (wopt Opt_WarnUnsupportedCallingConventions dflags) $ - addDiagnosticTc (WarningWithFlag Opt_WarnUnsupportedCallingConventions) - (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") + 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'") return PrimCallConv diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 0f1859ab55..85fd9d51f4 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -1114,10 +1114,9 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) [getRuntimeRep id_ty, id_ty] -- Warning for implicit lift (#17804) - ; whenWOptM Opt_WarnImplicitLift $ - addDiagnosticTc (WarningWithFlag 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/Module.hs b/compiler/GHC/Tc/Module.hs index 0883ba1c8b..e906dd267f 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -258,9 +258,8 @@ tcRnModuleTcRnM hsc_env mod_sum ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc implicit_prelude import_decls } - ; whenWOptM Opt_WarnImplicitPrelude $ - when (notNull prel_imports) $ - addDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) (implicitPreludeWarn) + ; when (notNull prel_imports) $ + addDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) = diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index b4efeaabdd..d4e9003b72 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -1344,8 +1344,7 @@ decideMonoTyVars infer_mode name_taus psigs candidates mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs -- Warn about the monomorphism restriction - ; warn_mono <- woptM Opt_WarnMonomorphism - ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $ + ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ diagnosticTc (WarningWithFlag Opt_WarnMonomorphism) (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) mr_msg diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index a8f6cbbc19..bddb585a51 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -1507,9 +1507,8 @@ failIfTcM True err = failWithTcM err -- and the warning is enabled warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn () warnIfFlag warn_flag is_bad msg - = do { warn_on <- woptM warn_flag - ; when (warn_on && is_bad) $ - addDiagnostic (WarningWithFlag warn_flag) msg } + = do { -- No need to check the flag here, it will be done in 'diagReasonSeverity'. + ; when is_bad $ addDiagnostic (WarningWithFlag warn_flag) msg } -- | Display a warning if a condition is met. warnIf :: Bool -> SDoc -> TcRn () diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index 610c31789c..173a8e68cf 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1103,7 +1103,7 @@ check_valid_theta _ _ _ [] check_valid_theta env ctxt expand theta = do { dflags <- getDynFlags ; diagnosticTcM (WarningWithFlag Opt_WarnDuplicateConstraints) - (wopt Opt_WarnDuplicateConstraints dflags && notNull dups) + (notNull dups) (dupPredWarn env dups) ; traceTc "check_valid_theta" (ppr theta) ; mapM_ (check_pred_ty env dflags ctxt expand) theta } diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 48cb9eaedd..bf5481cc2c 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -90,12 +90,30 @@ mkMessages = Messages isEmptyMessages :: Messages e -> Bool isEmptyMessages (Messages msgs) = isEmptyBag msgs +{- Note [Discarding Messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Discarding a 'SevIgnore' message from 'addMessage' and 'unionMessages' is +just an optimisation, as GHC would /also/ suppress any diagnostic which severity is +'SevIgnore' before printing the message: See for example 'putLogMsg' and 'defaultLogAction'. + +-} + +-- | Adds a 'Message' to the input collection of messages. +-- See Note [Discarding Messages]. addMessage :: MsgEnvelope e -> Messages e -> Messages e -addMessage x (Messages xs) = Messages (x `consBag` xs) +addMessage x (Messages xs) + | SevIgnore <- errMsgSeverity x = Messages xs + | otherwise = Messages (x `consBag` xs) -- | Joins two collections of messages together. +-- See Note [Discarding Messages]. unionMessages :: Messages e -> Messages e -> Messages e -unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2) +unionMessages (Messages msgs1) (Messages msgs2) = + Messages (filterBag interesting $ msgs1 `unionBags` msgs2) + where + interesting :: MsgEnvelope e -> Bool + interesting = (/=) SevIgnore . errMsgSeverity type WarningMessages = Bag (MsgEnvelope DiagnosticMessage) type ErrorMessages = Bag (MsgEnvelope DiagnosticMessage) @@ -230,19 +248,45 @@ data MessageClass -- /especially/ when emitting compiler diagnostics, use the smart constructor. deriving (Eq, Show) +{- Note [Suppressing Messages] + +The 'SevIgnore' constructor is used to generate messages for diagnostics which are +meant to be suppressed and not reported to the user: the classic example are warnings +for which the user didn't enable the corresponding 'WarningFlag', so GHC shouldn't print them. + +A different approach would be to extend the zoo of 'mkMsgEnvelope' functions to return +a 'Maybe (MsgEnvelope e)', so that we won't need to even create the message to begin with. +Both approaches have been evaluated, but we settled on the "SevIgnore one" for a number of reasons: + +* It's less invasive to deal with; +* It plays slightly better with deferred diagnostics (see 'GHC.Tc.Errors') as for those we need + to be able to /always/ produce a message (so that is reported at runtime); +* It gives us more freedom: we can still decide to drop a 'SevIgnore' message at leisure, or we can + decide to keep it around until the last moment. Maybe in the future we would need to + turn a 'SevIgnore' into something else, for example to "unsuppress" diagnostics if a flag is + set: with this approach, we have more leeway to accommodate new features. + +-} + -- | Used to describe warnings and errors -- o The message has a file\/line\/column heading, -- plus "warning:" or "error:", -- added by mkLocMessage +-- o With 'SevIgnore' the message is suppressed -- o Output is intended for end users data Severity - = SevWarning + = SevIgnore + -- ^ Ignore this message, for example in + -- case of suppression of warnings users + -- don't want to see. See Note [Suppressing Messages] + | SevWarning | SevError deriving (Eq, Show) instance Outputable Severity where ppr = \case + SevIgnore -> text "SevIgnore" SevWarning -> text "SevWarning" SevError -> text "SevError" diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 2ee1763ebb..d18791d0c6 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -87,7 +87,8 @@ import System.CPUTime -- 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 +diagReasonSeverity dflags (WarningWithFlag wflag) | not (wopt wflag dflags) = SevIgnore + | wopt_fatal wflag dflags = SevError | otherwise = SevWarning diagReasonSeverity dflags WarningWithoutFlag | gopt Opt_WarnIsError dflags = SevError | otherwise = SevWarning diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs index fbbacb2b48..2e5a9b06a7 100644 --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -198,6 +198,7 @@ makeThreadSafe logger = do -- See Note [JSON Error Messages] -- jsonLogAction :: LogAction +jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message jsonLogAction dflags msg_class srcSpan msg = defaultLogActionHPutStrDoc dflags True stdout @@ -214,12 +215,13 @@ defaultLogAction :: LogAction defaultLogAction dflags msg_class srcSpan msg | dopt Opt_D_dump_json dflags = jsonLogAction dflags msg_class srcSpan msg | otherwise = case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic sev rea -> printDiagnostics sev rea + MCOutput -> printOut msg + MCDump -> printOut (msg $$ blankLine) + MCInteractive -> putStrSDoc msg + MCInfo -> printErrs msg + MCFatal -> printErrs msg + MCDiagnostic SevIgnore _ -> pure () -- suppress the message + MCDiagnostic sev rea -> printDiagnostics sev rea where printOut = defaultLogActionHPrintDoc dflags False stdout printErrs = defaultLogActionHPrintDoc dflags False stderr @@ -242,6 +244,7 @@ defaultLogAction dflags msg_class srcSpan msg -- each unicode char. flagMsg :: Severity -> DiagnosticReason -> Maybe String + flagMsg SevIgnore _ = panic "Called flagMsg with SevIgnore" flagMsg SevError WarningWithoutFlag = Just "-Werror" flagMsg SevError (WarningWithFlag wflag) = do spec <- flagSpecOf wflag |