diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Backpack.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/CmdLine.hs | 56 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Errors.hs | 17 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Errors/Ppr.hs | 33 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Errors/Types.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline/Execute.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Pipeline/Phases.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 66 | ||||
| -rw-r--r-- | compiler/GHC/Types/Error/Codes.hs | 5 |
12 files changed, 116 insertions, 91 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 0182b5a2a1..49c94930ae 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -838,7 +838,7 @@ parseDynamicFlags => Logger -> DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) + -> m (DynFlags, [Located String], Messages DriverMessage) parseDynamicFlags logger dflags cmdline = do (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline -- flags that have just been read are used by the logger when loading package @@ -940,7 +940,8 @@ checkNewDynFlags logger dflags = do let (dflags', warnings) = makeDynFlagsConsistent dflags let diag_opts = initDiagOpts dflags print_config = initPrintConfig dflags - liftIO $ handleFlagWarnings logger print_config diag_opts (map (Warn WarningWithoutFlag) warnings) + liftIO $ printOrThrowDiagnostics logger print_config diag_opts + $ fmap GhcDriverMessage $ warnsToMessages diag_opts warnings return dflags' checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 9ca39b68ae..46aca5a99b 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -108,7 +108,7 @@ doBackpack [src_filename] = do liftIO $ checkProcessArgsResult unhandled_flags let print_config = initPrintConfig dflags liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns) - liftIO $ handleFlagWarnings logger print_config (initDiagOpts dflags) warns + liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcDriverMessage <$> warns) -- TODO: Preprocessing not implemented buf <- liftIO $ hGetStringBuffer src_filename diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs index e7d734bb42..57ad36431b 100644 --- a/compiler/GHC/Driver/CmdLine.hs +++ b/compiler/GHC/Driver/CmdLine.hs @@ -17,22 +17,23 @@ module GHC.Driver.CmdLine Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag, errorsToGhcException, - Err(..), Warn(..), WarnReason(..), + Err(..), Warn, warnsToMessages, - EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM + EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, ) where import GHC.Prelude import GHC.Utils.Misc -import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.SrcLoc -import GHC.Utils.Json - -import GHC.Types.Error ( DiagnosticReason(..) ) +import GHC.Types.Error +import GHC.Utils.Error +import GHC.Driver.Errors.Types +import GHC.Driver.Errors.Ppr () +import GHC.Utils.Outputable (text) import Data.Function import Data.List (sortBy, intercalate, stripPrefix) @@ -107,32 +108,16 @@ data OptKind m -- Suppose the flag is -f -- The EwM monad -------------------------------------------------------- --- | Used when filtering warnings: if a reason is given --- it can be filtered out when displaying. -data WarnReason - = NoReason - | ReasonDeprecatedFlag - | ReasonUnrecognisedFlag - deriving (Eq, Show) - -instance Outputable WarnReason where - ppr = text . show - -instance ToJson WarnReason where - json NoReason = JSNull - json reason = JSString $ show reason - -- | A command-line error message newtype Err = Err { errMsg :: Located String } -- | A command-line warning message and the reason it arose -data Warn = Warn - { warnReason :: DiagnosticReason, - warnMsg :: Located String - } +-- +-- This used to be own type, but now it's just @'MsgEnvelope' 'DriverMessage'@. +type Warn = Located DriverMessage type Errs = Bag Err -type Warns = Bag Warn +type Warns = [Warn] -- EwM ("errors and warnings monad") is a monad -- transformer for m that adds an (err, warn) state @@ -152,7 +137,7 @@ instance MonadIO m => MonadIO (EwM m) where liftIO = liftEwM . liftIO runEwM :: EwM m a -> m (Errs, Warns, a) -runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag +runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag mempty setArg :: Located String -> EwM m () -> EwM m () setArg l (EwM f) = EwM (\_ es ws -> f l es ws) @@ -161,11 +146,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 WarningWithoutFlag +addWarn msg = addFlagWarn $ DriverUnknownMessage $ UnknownDiagnostic $ + mkPlainDiagnostic WarningWithoutFlag noHints $ text msg -addFlagWarn :: Monad m => DiagnosticReason -> String -> EwM m () -addFlagWarn reason msg = EwM $ - (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) +addFlagWarn :: Monad m => DriverMessage -> EwM m () +addFlagWarn msg = EwM + (\(L loc _) es ws -> return (es, L loc msg : ws, ())) getArg :: Monad m => EwM m String getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) @@ -176,6 +162,10 @@ getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) liftEwM :: Monad m => m a -> EwM m a liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) +warnsToMessages :: DiagOpts -> [Warn] -> Messages DriverMessage +warnsToMessages diag_opts = foldr + (\(L loc w) ws -> addMessage (mkPlainMsgEnvelope diag_opts loc w) ws) + emptyMessages -------------------------------------------------------- -- Processing arguments @@ -187,10 +177,10 @@ processArgs :: Monad m -> (FilePath -> EwM m [Located String]) -- ^ response file handler -> m ( [Located String], -- spare args [Err], -- errors - [Warn] ) -- warnings + Warns ) -- warnings processArgs spec args handleRespFile = do (errs, warns, spare) <- runEwM action - return (spare, bagToList errs, bagToList warns) + return (spare, bagToList errs, warns) where action = process args [] diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index ab62682517..fc19e15494 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -2,20 +2,16 @@ module GHC.Driver.Errors ( printOrThrowDiagnostics , printMessages - , handleFlagWarnings , mkDriverPsHeaderMessage ) where import GHC.Driver.Errors.Types -import GHC.Data.Bag import GHC.Prelude -import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error import GHC.Utils.Error import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext ) import GHC.Utils.Logger -import qualified GHC.Driver.CmdLine as CmdLine printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () printMessages logger msg_opts opts msgs @@ -38,19 +34,6 @@ printMessages logger msg_opts opts msgs hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted $ mkDecorated . map ppr $ hs) -handleFlagWarnings :: Logger -> GhcMessageOpts -> DiagOpts -> [CmdLine.Warn] -> IO () -handleFlagWarnings logger print_config opts warns = do - let -- It would be nicer if warns :: [Located SDoc], but that - -- has circular import problems. - bag = listToBag [ mkPlainMsgEnvelope opts loc $ - GhcDriverMessage $ - DriverUnknownMessage $ - UnknownDiagnostic $ - mkPlainDiagnostic reason noHints $ text warn - | CmdLine.Warn reason (L loc warn) <- warns ] - - printOrThrowDiagnostics logger print_config opts (mkMessages bag) - -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO () diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs index a7a3135b13..89dd28eb74 100644 --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -222,6 +222,19 @@ instance Diagnostic DriverMessage where ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids) DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason + DriverInconsistentDynFlags msg + -> mkSimpleDecorated $ text msg + DriverSafeHaskellIgnoredExtension ext + -> let arg = text "-X" <> ppr ext + in mkSimpleDecorated $ arg <+> text "is not allowed in Safe Haskell; ignoring" <+> arg + DriverPackageTrustIgnored + -> mkSimpleDecorated $ text "-fpackage-trust ignored; must be specified with a Safe Haskell flag" + + DriverUnrecognisedFlag arg + -> mkSimpleDecorated $ text $ "unrecognised warning flag: -" ++ arg + DriverDeprecatedFlag arg msg + -> mkSimpleDecorated $ text $ arg ++ " is deprecated: " ++ msg + diagnosticReason = \case DriverUnknownMessage m -> diagnosticReason m @@ -276,6 +289,16 @@ instance Diagnostic DriverMessage where DriverHomePackagesNotClosed {} -> ErrorWithoutFlag DriverInterfaceError reason -> diagnosticReason reason + DriverInconsistentDynFlags {} + -> WarningWithoutFlag + DriverSafeHaskellIgnoredExtension {} + -> WarningWithoutFlag + DriverPackageTrustIgnored {} + -> WarningWithoutFlag + DriverUnrecognisedFlag {} + -> WarningWithFlag Opt_WarnUnrecognisedWarningFlags + DriverDeprecatedFlag {} + -> WarningWithFlag Opt_WarnDeprecatedFlags diagnosticHints = \case DriverUnknownMessage m @@ -333,5 +356,15 @@ instance Diagnostic DriverMessage where DriverHomePackagesNotClosed {} -> noHints DriverInterfaceError reason -> diagnosticHints reason + DriverInconsistentDynFlags {} + -> noHints + DriverSafeHaskellIgnoredExtension {} + -> noHints + DriverPackageTrustIgnored {} + -> noHints + DriverUnrecognisedFlag {} + -> noHints + DriverDeprecatedFlag {} + -> noHints diagnosticCode = constructorCode diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs index 2e116bd8b6..a7b955267e 100644 --- a/compiler/GHC/Driver/Errors/Types.hs +++ b/compiler/GHC/Driver/Errors/Types.hs @@ -35,6 +35,7 @@ import GHC.HsToCore.Errors.Types ( DsMessage ) import GHC.Hs.Extension (GhcTc) import Language.Haskell.Syntax.Decls (RuleDecl) +import qualified GHC.LanguageExtensions as LangExt import GHC.Generics ( Generic ) @@ -372,6 +373,16 @@ data DriverMessage where DriverInterfaceError :: !IfaceMessage -> DriverMessage + DriverInconsistentDynFlags :: String -> DriverMessage + + DriverSafeHaskellIgnoredExtension :: !LangExt.Extension -> DriverMessage + + DriverPackageTrustIgnored :: DriverMessage + + DriverUnrecognisedFlag :: String -> DriverMessage + + DriverDeprecatedFlag :: String -> String -> DriverMessage + deriving instance Generic DriverMessage data DriverMessageOpts = diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 3321d1203f..e795b5cd55 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1710,9 +1710,9 @@ markUnsafeInfer tcg_env whyUnsafe = do (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer - badFlag df (str,loc,on,_) + badFlag df (ext,loc,on,_) | on df = [mkLocMessage MCOutput (loc df) $ - text str <+> text "is not allowed in Safe Haskell"] + text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"] | otherwise = [] badInsts insts = concatMap badInst insts diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index cb4aa6d8a2..6e398af51e 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -737,7 +737,7 @@ preprocessPipeline pipe_env hsc_env input_fn = do let print_config = initPrintConfig dflags3 liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3)) - liftIO (handleFlagWarnings (hsc_logger hsc_env) print_config (initDiagOpts dflags3) warns3) + liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcDriverMessage <$> warns3)) return (dflags3, pp_fn) diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index fb3de7925a..ebfb90a76d 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -28,7 +28,6 @@ import GHC.Unit.Module.Status import GHC.Unit.Module.ModIface import GHC.Driver.Backend import GHC.Driver.Session -import GHC.Driver.CmdLine import GHC.Unit.Module.ModSummary import qualified GHC.LanguageExtensions as LangExt import GHC.Types.SrcLoc @@ -683,7 +682,7 @@ runUnlitPhase hsc_env input_fn output_fn = do return output_fn -getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn])) +getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages DriverMessage)) getFileArgs hsc_env input_fn = do let dflags0 = hsc_dflags hsc_env parser_opts = initParserOpts dflags0 diff --git a/compiler/GHC/Driver/Pipeline/Phases.hs b/compiler/GHC/Driver/Pipeline/Phases.hs index 01a507be67..410d488773 100644 --- a/compiler/GHC/Driver/Pipeline/Phases.hs +++ b/compiler/GHC/Driver/Pipeline/Phases.hs @@ -7,7 +7,6 @@ import GHC.Prelude import GHC.Driver.Pipeline.Monad import GHC.Driver.Env.Types import GHC.Driver.Session -import GHC.Driver.CmdLine import GHC.Types.SourceFile import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Status @@ -29,7 +28,7 @@ import GHC.Unit.Home.ModInfo -- phase if the inputs have been modified. data TPhase res where T_Unlit :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath - T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, [Warn]) + T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, Messages DriverMessage) T_Cpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_HsPp :: PipeEnv -> HscEnv -> FilePath -> FilePath -> TPhase FilePath T_HscRecomp :: PipeEnv -> HscEnv -> FilePath -> HscSource -> TPhase (HscEnv, ModSummary, HscRecompStatus) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index dd5bb6b7cb..115a55d1ed 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -235,8 +235,10 @@ import GHC.Unit.Parser import GHC.Unit.Module import GHC.Unit.Module.Warnings import GHC.Driver.DynFlags +import GHC.Driver.Config.Diagnostic import GHC.Driver.Flags import GHC.Driver.Backend +import GHC.Driver.Errors.Types import GHC.Driver.Plugins.External import GHC.Settings.Config import GHC.Core.Unfold @@ -247,6 +249,7 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.GlobalVars import GHC.Data.Maybe import GHC.Data.Bool +import GHC.Types.Error import GHC.Utils.Monad import GHC.Types.SrcLoc import GHC.Types.SafeHaskell @@ -357,7 +360,6 @@ import qualified GHC.LanguageExtensions as LangExt -- ----------------------------------------------------------------------------- -- DynFlags - {- Note [RHS Floating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to @@ -545,14 +547,14 @@ combineSafeFlags a b | a == Sf_None = return b -- * function to test if the flag is on -- * function to turn the flag off unsafeFlags, unsafeFlagsForInfer - :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] -unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, + :: [(LangExt.Extension, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [ (LangExt.GeneralizedNewtypeDeriving, newDerivOnLoc, xopt LangExt.GeneralizedNewtypeDeriving, flip xopt_unset LangExt.GeneralizedNewtypeDeriving) - , ("-XDerivingVia", deriveViaOnLoc, + , (LangExt.DerivingVia, deriveViaOnLoc, xopt LangExt.DerivingVia, flip xopt_unset LangExt.DerivingVia) - , ("-XTemplateHaskell", thOnLoc, + , (LangExt.TemplateHaskell, thOnLoc, xopt LangExt.TemplateHaskell, flip xopt_unset LangExt.TemplateHaskell) ] @@ -753,7 +755,7 @@ updOptLevel n = fst . updOptLevelChanged n -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments). parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) + -> m (DynFlags, [Located String], Messages DriverMessage) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True @@ -763,7 +765,7 @@ parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True -- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). -- Used to parse flags set in a modules pragma. parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) + -> m (DynFlags, [Located String], Messages DriverMessage) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False @@ -803,6 +805,7 @@ processCmdLineP activeFlags s0 args = getCmdLineP :: CmdLineP s a -> StateT s m a getCmdLineP (CmdLineP k) = k + -- | Parses the dynamically set flags for GHC. This is the most general form of -- the dynamic flag parser that the other methods simply wrap. It allows -- saying which flags are valid flags and indicating if we are parsing @@ -813,9 +816,9 @@ parseDynamicFlagsFull -> Bool -- ^ are the arguments from the command line? -> DynFlags -- ^ current dynamic flags -> [Located String] -- ^ arguments to parse - -> m (DynFlags, [Located String], [Warn]) + -> m (DynFlags, [Located String], Messages DriverMessage) parseDynamicFlagsFull activeFlags cmdline dflags0 args = do - ((leftover, errs, warns), dflags1) <- processCmdLineP activeFlags dflags0 args + ((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args -- See Note [Handling errors when parsing command-line flags] let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle) @@ -840,28 +843,29 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do liftIO $ setUnsafeGlobalDynFlags dflags3 - let warns' = map (Warn WarningWithoutFlag) (consistency_warnings ++ sh_warns) + -- create message envelopes using final DynFlags: #23402 + let diag_opts = initDiagOpts dflags3 + warns = warnsToMessages diag_opts $ mconcat [consistency_warnings, sh_warns, cli_warns] - return (dflags3, leftover, warns' ++ warns) + return (dflags3, leftover, warns) -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. -- -- The bool is to indicate if we are parsing command line flags (false means -- file pragma). This allows us to generate better warnings. -safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Warn]) safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) where -- Handle illegal flags under safe language. - (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags + (dflagsUnset, warns) = foldl' check_method (dflags, mempty) unsafeFlags - check_method (df, warns) (str,loc,test,fix) - | test df = (fix df, warns ++ safeFailure (loc df) str) + check_method (df, warns) (ext,loc,test,fix) + | test df = (fix df, safeFailure (loc df) ext : warns) | otherwise = (df, warns) - safeFailure loc str - = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " - ++ str] + safeFailure loc ext + = L loc $ DriverSafeHaskellIgnoredExtension ext safeFlagCheck cmdl dflags = case safeInferOn dflags of @@ -874,11 +878,10 @@ safeFlagCheck cmdl dflags = (dflags', warn) | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) - | otherwise = (dflags, []) + | otherwise = (dflags, mempty) - pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ - "-fpackage-trust ignored;" ++ - " must be specified with a Safe Haskell flag"] + pkgWarnMsg :: [Warn] + pkgWarnMsg = [ L (pkgTrustOnLoc dflags') DriverPackageTrustIgnored ] -- Have we inferred Unsafe? See Note [Safe Haskell Inference] in GHC.Driver.Main -- Force this to avoid retaining reference to old DynFlags value @@ -1894,7 +1897,7 @@ warningControls set unset set_werror unset_fatal xs = customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags) customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action) where - action :: String -> EwM (CmdLineP DynFlags) () + action :: String -> DynP () action flag | validWarningCategory cat = custom cat | otherwise = unrecognised flag @@ -1902,9 +1905,11 @@ customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action) cat = mkWarningCategory (mkFastString flag) unrecognised flag = do + -- #23402 and #12056 + -- for unrecognised flags we consider current dynflags, not the final one. + -- But if final state says to not report unrecognised flags, they won't anyway. f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState - when f $ addFlagWarn (WarningWithFlag Opt_WarnUnrecognisedWarningFlags) $ - "unrecognised warning flag: -" ++ prefix ++ flag + when f $ addFlagWarn (DriverUnrecognisedFlag (prefix ++ flag)) -- See Note [Supporting CLI completion] package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] @@ -2089,11 +2094,10 @@ 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 :: String -> DynP () deprecate s = do arg <- getArg - addFlagWarn (WarningWithFlag Opt_WarnDeprecatedFlags) (arg ++ " is deprecated: " ++ s) + addFlagWarn (DriverDeprecatedFlag arg s) deprecatedForExtension :: String -> TurnOnFlag -> String deprecatedForExtension lang turn_on @@ -3589,7 +3593,7 @@ T10052 and #10052). -- | Resolve any internal inconsistencies in a set of 'DynFlags'. -- Returns the consistent 'DynFlags' as well as a list of warnings -- to report to the user. -makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String]) +makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn]) -- Whenever makeDynFlagsConsistent does anything, it starts over, to -- ensure that a later change doesn't invalidate an earlier check. -- Be careful not to introduce potential loops! @@ -3674,11 +3678,11 @@ makeDynFlagsConsistent dflags , Nothing <- outputFile dflags = pgmError "--output must be specified when using --merge-objs" - | otherwise = (dflags, []) + | otherwise = (dflags, mempty) where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") loop updated_dflags warning = case makeDynFlagsConsistent updated_dflags of - (dflags', ws) -> (dflags', L loc warning : ws) + (dflags', ws) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws) platform = targetPlatform dflags arch = platformArch platform os = platformOS platform diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index 25f78f9fbd..fd96b13c7d 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -297,6 +297,11 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "DriverCannotImportFromUntrustedPackage" = 75165 GhcDiagnosticCode "DriverRedirectedNoMain" = 95379 GhcDiagnosticCode "DriverHomePackagesNotClosed" = 03271 + GhcDiagnosticCode "DriverInconsistentDynFlags" = 74335 + GhcDiagnosticCode "DriverSafeHaskellIgnoredExtension" = 98887 + GhcDiagnosticCode "DriverPackageTrustIgnored" = 83552 + GhcDiagnosticCode "DriverUnrecognisedFlag" = 93741 + GhcDiagnosticCode "DriverDeprecatedFlag" = 53692 -- Constraint solver diagnostic codes GhcDiagnosticCode "BadTelescope" = 97739 |