Commit 9a62ecfa authored by Alfredo Di Napoli's avatar Alfredo Di Napoli Committed by Marge Bot

Remove errShortString, cleanup error-related functions

This commit removes the errShortString field from the ErrMsg type,
allowing us to cleanup a lot of dynflag-dependent error functions, and
move them in a more specialised 'GHC.Driver.Errors' closer to the
driver, where they are actually used.

Metric Increase:
  T4801
  T9961
parent bd877edd
Pipeline #29702 failed with stages
in 356 minutes and 23 seconds
......@@ -301,6 +301,7 @@ import GHC.Platform.Ways
import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename
, isSourceFilename, startPhase )
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.CmdLine
import GHC.Driver.Session hiding (WarnReason(..))
import GHC.Driver.Backend
......@@ -889,7 +890,7 @@ checkNewInteractiveDynFlags dflags0 = do
-- the REPL. See #12356.
if xopt LangExt.StaticPointers dflags0
then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
[mkPlainWarnMsg dflags0 interactiveSrcSpan
[mkPlainWarnMsg interactiveSrcSpan
$ text "StaticPointers is not supported in GHCi interactive expressions."]
return $ xopt_unset dflags0 LangExt.StaticPointers
else return dflags0
......
......@@ -30,6 +30,7 @@ import GHC.Driver.Ppr
import GHC.Driver.Main
import GHC.Driver.Make
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Parser
import GHC.Parser.Header
......@@ -96,7 +97,7 @@ doBackpack [src_filename] = do
(dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})
-- Cribbed from: preprocessFile / GHC.Driver.Pipeline
liftIO $ checkProcessArgsResult dflags unhandled_flags
liftIO $ checkProcessArgsResult unhandled_flags
liftIO $ handleFlagWarnings dflags warns
-- TODO: Preprocessing not implemented
......@@ -776,7 +777,6 @@ summariseDecl :: PackageName
summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
= do hsc_env <- getSession
let dflags = hsc_dflags hsc_env
-- TODO: this looks for modules in the wrong place
r <- liftIO $ summariseModule hsc_env
emptyModNodeMap -- GHC API recomp not supported
......@@ -786,7 +786,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
Nothing -- GHC API buffer support not supported
[] -- No exclusions
case r of
Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
Nothing -> throwOneError (mkPlainErrMsg loc (text "module" <+> ppr modname <+> text "was not found"))
Just (Left err) -> throwErrors err
Just (Right summary) -> return summary
......
......@@ -29,6 +29,7 @@ import GHC.Prelude
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Driver.Errors ( printOrThrowWarnings )
import GHC.Runtime.Context
import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )
......@@ -59,7 +60,6 @@ import GHC.Data.Bag
import GHC.Utils.Outputable
import GHC.Utils.Monad
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Misc
......
{-# LANGUAGE ViewPatterns #-}
module GHC.Driver.Errors (
warningsToMessages
, printOrThrowWarnings
, printBagOfErrors
, isWarnMsgFatal
, handleFlagWarnings
) where
import GHC.Driver.Session
import GHC.Data.Bag
import GHC.Utils.Exception
import GHC.Utils.Error ( formatErrDoc, sortMsgBag )
import GHC.Types.SourceError ( mkSrcErr )
import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.Error
import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )
import qualified GHC.Driver.CmdLine as CmdLine
-- | Converts a list of 'WarningMessages' into 'Messages', where the second element contains only
-- error, i.e. warnings that are considered fatal by GHC based on the input 'DynFlags'.
warningsToMessages :: DynFlags -> WarningMessages -> Messages
warningsToMessages dflags =
partitionBagWith $ \warn ->
case isWarnMsgFatal dflags warn of
Nothing -> Left warn
Just err_reason ->
Right warn{ errMsgSeverity = SevError
, errMsgReason = ErrReason err_reason }
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle unqual
ctx = initSDocContext dflags style
in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc)
| ErrMsg { errMsgSpan = s,
errMsgDoc = doc,
errMsgSeverity = sev,
errMsgReason = reason,
errMsgContext = unqual } <- sortMsgBag (Just dflags)
bag_of_errors ]
handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO ()
handleFlagWarnings dflags warns = do
let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns
-- It would be nicer if warns :: [Located MsgDoc], but that
-- has circular import problems.
bag = listToBag [ mkPlainWarnMsg loc (text warn)
| CmdLine.Warn _ (L loc warn) <- warns' ]
printOrThrowWarnings dflags bag
-- | Checks if given 'WarnMsg' is a fatal warning.
isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}
= if wopt_fatal wflag dflags
then Just (Just wflag)
else Nothing
isWarnMsgFatal dflags _
= if gopt Opt_WarnIsError dflags
then Just Nothing
else Nothing
-- Given a warn reason, check to see if it's associated -W opt is enabled
shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool
shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag
= wopt Opt_WarnDeprecatedFlags dflags
shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag
= wopt Opt_WarnUnrecognisedWarningFlags dflags
shouldPrintWarning _ _
= True
-- | Given a bag of warnings, turn them into an exception if
-- -Werror is enabled, or print them out otherwise.
printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printOrThrowWarnings dflags warns = do
let (make_error, warns') =
mapAccumBagL
(\make_err warn ->
case isWarnMsgFatal dflags warn of
Nothing ->
(make_err, warn)
Just err_reason ->
(True, warn{ errMsgSeverity = SevError
, errMsgReason = ErrReason err_reason
}))
False warns
if make_error
then throwIO (mkSrcErr warns')
else printBagOfErrors dflags warns
......@@ -93,6 +93,7 @@ import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.CodeOutput
import GHC.Driver.Config
import GHC.Driver.Hooks
......@@ -562,7 +563,7 @@ tcRnModule' sum save_rn_syntax mod = do
&& wopt Opt_WarnMissingSafeHaskellMode dflags) $
logWarnings $ unitBag $
makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $
mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $
mkPlainWarnMsg (getLoc (hpm_module mod)) $
warnMissingSafeHaskellMode
tcg_res <- {-# SCC "Typecheck-Rename" #-}
......@@ -591,13 +592,13 @@ tcRnModule' sum save_rn_syntax mod = do
| safeHaskell dflags == Sf_Safe -> return ()
| otherwise -> (logWarnings $ unitBag $
makeIntoWarning (Reason Opt_WarnSafe) $
mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
mkPlainWarnMsg (warnSafeOnLoc dflags) $
errSafe tcg_res')
False | safeHaskell dflags == Sf_Trustworthy &&
wopt Opt_WarnTrustworthySafe dflags ->
(logWarnings $ unitBag $
makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
mkPlainWarnMsg (trustworthyOnLoc dflags) $
errTwthySafe tcg_res')
False -> return ()
return tcg_res'
......@@ -1119,22 +1120,22 @@ hscCheckSafeImports tcg_env = do
case safeLanguageOn dflags of
True -> do
-- XSafe: we nuke user written RULES
logWarnings $ warns dflags (tcg_rules tcg_env')
logWarnings $ warns (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
-- SafeInferred: user defined RULES, so not safe
| safeInferOn dflags && not (null $ tcg_rules tcg_env')
-> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
-> markUnsafeInfer tcg_env' $ warns (tcg_rules tcg_env')
-- Trustworthy OR SafeInferred: with no RULES
| otherwise
-> return tcg_env'
warns dflags rules = listToBag $ map (warnRules dflags) rules
warns rules = listToBag $ map warnRules rules
warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg
warnRules dflags (L loc (HsRule { rd_name = n })) =
mkPlainWarnMsg dflags loc $
warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg
warnRules (L loc (HsRule { rd_name = n })) =
mkPlainWarnMsg loc $
text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
......@@ -1211,8 +1212,7 @@ checkSafeImports tcg_env
cond' v1 v2
| imv_is_safe v1 /= imv_is_safe v2
= do
dflags <- getDynFlags
throwOneError $ mkPlainErrMsg dflags (imv_span v1)
throwOneError $ mkPlainErrMsg (imv_span v1)
(text "Module" <+> ppr (imv_name v1) <+>
(text $ "is imported both as a safe and unsafe import!"))
| otherwise
......@@ -1280,7 +1280,7 @@ hscCheckSafe' m l = do
iface <- lookup' m
case iface of
-- can't load iface to check trust!
Nothing -> throwOneError $ mkPlainErrMsg dflags l
Nothing -> throwOneError $ mkPlainErrMsg l
$ text "Can't load the interface file for" <+> ppr m
<> text ", to check that it can be safely imported"
......@@ -1314,20 +1314,20 @@ hscCheckSafe' m l = do
state = hsc_units hsc_env
inferredImportWarn = unitBag
$ makeIntoWarning (Reason Opt_WarnInferredSafeImports)
$ mkWarnMsg dflags l (pkgQual state)
$ mkWarnMsg l (pkgQual state)
$ sep
[ text "Importing Safe-Inferred module "
<> ppr (moduleName m)
<> text " from explicitly Safe module"
]
pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $
pkgTrustErr = unitBag $ mkErrMsg l (pkgQual state) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The package ("
<> (pprWithUnitState state $ ppr (moduleUnit m))
<> text ") the module resides in isn't trusted."
]
modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $
modTrustErr = unitBag $ mkErrMsg l (pkgQual state) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The module itself isn't safe." ]
......@@ -1366,7 +1366,6 @@ hscCheckSafe' m l = do
-- | Check the list of packages are trusted.
checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust pkgs = do
dflags <- getDynFlags
hsc_env <- getHscEnv
let errors = S.foldr go [] pkgs
state = hsc_units hsc_env
......@@ -1374,7 +1373,7 @@ checkPkgTrust pkgs = do
| unitIsTrusted $ unsafeLookupUnitId state pkg
= acc
| otherwise
= (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state)
= (:acc) $ mkErrMsg noSrcSpan (pkgQual state)
$ pprWithUnitState state
$ text "The package ("
<> ppr pkg
......@@ -1399,7 +1398,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
when (wopt Opt_WarnUnsafe dflags)
(logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $
mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
-- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other
......@@ -1925,7 +1924,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do
case is of
[L _ i] -> return i
_ -> liftIO $ throwOneError $
mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
mkPlainErrMsg noSrcSpan $
text "parse error in import declaration"
-- | Typecheck an expression (but don't run it)
......@@ -1951,11 +1950,10 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr expr = do
hsc_env <- getHscEnv
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (BodyStmt _ expr _ _)) -> return expr
_ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
_ -> throwOneError $ mkPlainErrMsg noSrcSpan
(text "not an expression:" <+> quotes (text expr))
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
......
......@@ -59,6 +59,7 @@ import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Monad
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Main
import GHC.Parser.Header
......@@ -315,7 +316,7 @@ warnMissingHomeModules hsc_env mod_graph =
(sep (map ppr missing))
warn = makeIntoWarning
(Reason Opt_WarnMissingHomeModules)
(mkPlainErrMsg dflags noSrcSpan msg)
(mkPlainErrMsg noSrcSpan msg)
-- | Describes which modules of the module graph need to be loaded.
data LoadHowMuch
......@@ -382,7 +383,7 @@ warnUnusedPackages = do
let warn = makeIntoWarning
(Reason Opt_WarnUnusedPackages)
(mkPlainErrMsg dflags noSrcSpan msg)
(mkPlainErrMsg noSrcSpan msg)
msg = vcat [ text "The following packages were specified" <+>
text "via -package or -package-id flags,"
, text "but were not needed for compilation:"
......@@ -2200,15 +2201,15 @@ warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports sccs = do
dflags <- getDynFlags
when (wopt Opt_WarnUnusedImports dflags)
(logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
where check dflags ms =
(logWarnings (listToBag (concatMap (check . flattenSCC) sccs)))
where check ms =
let mods_in_this_cycle = map ms_mod_name ms in
[ warn dflags i | m <- ms, i <- ms_home_srcimps m,
unLoc i `notElem` mods_in_this_cycle ]
[ warn i | m <- ms, i <- ms_home_srcimps m,
unLoc i `notElem` mods_in_this_cycle ]
warn :: DynFlags -> Located ModuleName -> WarnMsg
warn dflags (L loc mod) =
mkPlainErrMsg dflags loc
warn :: Located ModuleName -> WarnMsg
warn (L loc mod) =
mkPlainErrMsg loc
(text "Warning: {-# SOURCE #-} unnecessary in import of "
<+> quotes (ppr mod))
......@@ -2277,14 +2278,14 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
if exists || isJust maybe_buf
then summariseFile hsc_env old_summaries file mb_phase
obj_allowed maybe_buf
else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $
else return $ Left $ unitBag $ mkPlainErrMsg noSrcSpan $
text "can't find file:" <+> text file
getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
= do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
(L rootLoc modl) obj_allowed
maybe_buf excl_mods
case maybe_summary of
Nothing -> return $ Left $ moduleNotFoundErr dflags modl
Nothing -> return $ Left $ moduleNotFoundErr modl
Just s -> return s
rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
......@@ -2301,7 +2302,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
checkDuplicates root_map
| allow_dup_roots = return ()
| null dup_roots = return ()
| otherwise = liftIO $ multiRootsErr dflags (emsModSummary <$> head dup_roots)
| otherwise = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots)
where
dup_roots :: [[ExtendedModSummary]] -- Each at least of length 2
dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map
......@@ -2320,7 +2321,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
= if isSingleton summs then
loop ss done
else
do { multiRootsErr dflags (emsModSummary <$> rights summs)
do { multiRootsErr (emsModSummary <$> rights summs)
; return (ModNodeMap Map.empty)
}
| otherwise
......@@ -2696,7 +2697,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
-- It might have been deleted since the Finder last found it
maybe_t <- modificationTimeIfExists src_fn
case maybe_t of
Nothing -> return $ Left $ noHsFileErr dflags loc src_fn
Nothing -> return $ Left $ noHsFileErr loc src_fn
Just t -> new_summary location' mod src_fn t
new_summary location mod src_fn src_timestamp
......@@ -2717,7 +2718,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
| otherwise = HsSrcFile
when (pi_mod_name /= wanted_mod) $
throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
throwE $ unitBag $ mkPlainErrMsg pi_mod_name_loc $
text "File name does not match module name:"
$$ text "Saw:" <+> quotes (ppr pi_mod_name)
$$ text "Expected:" <+> quotes (ppr wanted_mod)
......@@ -2729,7 +2730,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
| (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)
: homeUnitInstantiations home_unit)
])
in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
in throwE $ unitBag $ mkPlainErrMsg pi_mod_name_loc $
text "Unexpected signature:" <+> quotes (ppr pi_mod_name)
$$ if gopt Opt_BuildingCabalPackage dflags
then parens (text "Try adding" <+> quotes (ppr pi_mod_name)
......@@ -2888,21 +2889,21 @@ withDeferredDiagnostics f = do
noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
-- ToDo: we don't have a proper line number for this error
noModError hsc_env loc wanted_mod err
= mkPlainErrMsg (hsc_dflags hsc_env) loc $ cannotFindModule hsc_env wanted_mod err
= mkPlainErrMsg loc $ cannotFindModule hsc_env wanted_mod err
noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages
noHsFileErr dflags loc path
= unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
noHsFileErr :: SrcSpan -> String -> ErrorMessages
noHsFileErr loc path
= unitBag $ mkPlainErrMsg loc $ text "Can't find" <+> text path
moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages
moduleNotFoundErr dflags mod
= unitBag $ mkPlainErrMsg dflags noSrcSpan $
moduleNotFoundErr :: ModuleName -> ErrorMessages
moduleNotFoundErr mod
= unitBag $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
multiRootsErr _ [] = panic "multiRootsErr"
multiRootsErr dflags summs@(summ1:_)
= throwOneError $ mkPlainErrMsg dflags noSrcSpan $
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_)
= throwOneError $ mkPlainErrMsg noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
sep (map text files)
......
......@@ -288,9 +288,8 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
-> return Nothing
fail ->
let dflags = hsc_dflags hsc_env
in throwOneError $ mkPlainErrMsg dflags srcloc $
cannotFindModule hsc_env imp fail
throwOneError $ mkPlainErrMsg srcloc $
cannotFindModule hsc_env imp fail
}
-----------------------------
......
......@@ -28,6 +28,7 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors )
import GHC.Utils.Monad
import GHC.Utils.Exception
......
......@@ -46,6 +46,7 @@ import GHC.Tc.Types
import GHC.Driver.Main
import GHC.Driver.Env hiding ( Hsc )
import GHC.Driver.Errors
import GHC.Driver.Pipeline.Monad
import GHC.Driver.Config
import GHC.Driver.Phases
......@@ -149,7 +150,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
where
srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
handler (ProgramError msg) = return $ Left $ unitBag $
mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg
mkPlainErrMsg srcspan $ text msg
handler ex = throwGhcExceptionIO ex
-- ---------------------------------------------------------------------------
......@@ -1127,7 +1128,7 @@ runPhase (RealPhase (Cpp sf)) input_fn
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicFilePragma dflags0 src_opts
setDynFlags dflags1
liftIO $ checkProcessArgsResult dflags1 unhandled_flags
liftIO $ checkProcessArgsResult unhandled_flags
if not (xopt LangExt.Cpp dflags1) then do
-- we have to be careful to emit warnings only once.
......@@ -1148,7 +1149,7 @@ runPhase (RealPhase (Cpp sf)) input_fn
src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- liftIO $ parseDynamicFilePragma dflags0 src_opts
liftIO $ checkProcessArgsResult dflags2 unhandled_flags
liftIO $ checkProcessArgsResult unhandled_flags
unless (gopt Opt_Pp dflags2) $
liftIO $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
......@@ -1182,7 +1183,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do
(dflags1, unhandled_flags, warns)
<- liftIO $ parseDynamicFilePragma dflags src_opts
setDynFlags dflags1
liftIO $ checkProcessArgsResult dflags1 unhandled_flags
liftIO $ checkProcessArgsResult unhandled_flags
liftIO $ handleFlagWarnings dflags1 warns
return (RealPhase (Hsc sf), output_fn)
......
......@@ -453,9 +453,8 @@ warnDs :: WarnReason -> SDoc -> DsM ()
warnDs reason warn
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; dflags <- getDynFlags
; let msg = makeIntoWarning reason $
mkWarnMsg dflags loc (ds_unqual env) warn
mkWarnMsg loc (ds_unqual env) warn
; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
-- | Emit a warning only if the correct WarnReason is set in the DynFlags
......@@ -468,8 +467,7 @@ errDs :: SDoc -> DsM ()
errDs err
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; dflags <- getDynFlags
; let msg = mkErrMsg dflags loc (ds_unqual env) err
; let msg = mkErrMsg loc (ds_unqual env) err
; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
-- | Issue an error, but return the expression for (), so that we can continue
......
......@@ -18,7 +18,6 @@ module GHC.Iface.Rename (
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Tc.Utils.Monad
......@@ -75,10 +74,9 @@ tcRnModExports x y = do
failWithRn :: SDoc -> ShIfM a
failWithRn doc = do
errs_var <- fmap sh_if_errs getGblEnv
dflags <- getDynFlags
errs <- readTcRef errs_var
-- TODO: maybe associate this with a source location?
writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)
writeTcRef errs_var (errs `snocBag` mkPlainErrMsg noSrcSpan doc)
failM
-- | What we have is a generalized ModIface, which corresponds to
......
......@@ -29,7 +29,6 @@ mkParserErr span doc = ErrMsg
{ errMsgSpan = span
, errMsgContext = alwaysQualify
, errMsgDoc = ErrDoc [doc] [] []
, errMsgShortString = renderWithContext defaultSDocContext doc
, errMsgSeverity = SevError
, errMsgReason = NoReason
}
......@@ -39,7 +38,6 @@ mkParserWarn flag span doc = ErrMsg
{ errMsgSpan = span
, errMsgContext = alwaysQualify
, errMsgDoc = ErrDoc [doc] [] []
, errMsgShortString = renderWithContext defaultSDocContext doc
, errMsgSeverity = SevWarning
, errMsgReason = Reason flag
}
......
......@@ -39,11 +39,11 @@ import GHC.Hs
import GHC.Unit.Module
import GHC.Builtin.Names
import GHC.Types.Error
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.SourceText
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
......@@ -259,7 +259,7 @@ getOptions' dflags toks
| IToptions_prag str <- unLoc open
, ITclose_prag <- unLoc close
= case toArgs str of
Left _err -> optionsParseError str dflags $ -- #15053
Left _err -> optionsParseError str $ -- #15053
combineSrcSpans (getLoc open) (getLoc close)
Right args -> map (L (getLoc open)) args ++ parseToks xs
parseToks (open:close:xs)
......@@ -284,10 +284,10 @@ getOptions' dflags toks
case rest of
(L _loc ITcomma):more -> parseLanguage more
(L _loc ITclose_prag):more -> parseToks more
(L loc _):_ -> languagePragParseError dflags loc
(L loc _):_ -> languagePragParseError loc
[] -> panic "getOptions'.parseLanguage(1) went past eof token"
parseLanguage (tok:_)
= languagePragParseError dflags (getLoc tok)
= languagePragParseError (getLoc tok)
parseLanguage []
= panic "getOptions'.parseLanguage(2) went past eof token"
......@@ -308,12 +308,12 @@ getOptions' dflags toks
--
-- Throws a 'SourceError' if the input list is non-empty claiming that the
-- input flags are unknown.
checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
checkProcessArgsResult dflags flags
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
checkProcessArgsResult flags
= when (notNull flags) $
liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
where mkMsg (L loc flag)
= mkPlainErrMsg dflags loc $
= mkPlainErrMsg loc $
(text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
text flag)
......@@ -330,9 +330,9 @@ checkExtension dflags (L l ext)
ext' = unpackFS ext
supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags
languagePragParseError :: DynFlags -> SrcSpan -> a
languagePragParseError dflags loc =