Skip to content
GitLab
Commit c3a62c56 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Pass DynFlags down to mk_err_msg

parent 91667cc9
Hide whitespace changes
Inline Side-by-side
compiler/cmm/CmmParse.y
View file @ c3a62c56
......@@ -1070,7 +1070,7 @@ parseCmmFile dflags filename = do
-- in there we don't want.
case unP cmmParse init_state of
PFailed span err -> do
let msg = mkPlainErrMsg span err
let msg = mkPlainErrMsg dflags span err
return ((emptyBag, unitBag msg), Nothing)
POk pst code -> do
cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
......
compiler/deSugar/DsMonad.lhs
View file @ c3a62c56
......@@ -361,14 +361,16 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc})
warnDs :: SDoc -> DsM ()
warnDs warn = do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkWarnMsg loc (ds_unqual env) warn
; dflags <- getDynFlags
; let msg = mkWarnMsg dflags loc (ds_unqual env) warn
; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
failWithDs :: SDoc -> DsM a
failWithDs err
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkErrMsg loc (ds_unqual env) err
; dflags <- getDynFlags
; let msg = mkErrMsg dflags loc (ds_unqual env) err
; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
; failM }
......
compiler/iface/MkIface.lhs
View file @ c3a62c56
......@@ -322,10 +322,10 @@ mkIface_ hsc_env maybe_old_fingerprint
| otherwise = emptyBag
errs_and_warns = (orph_warnings, emptyBag)
unqual = mkPrintUnqualified dflags rdr_env
inst_warns = listToBag [ instOrphWarn unqual d
inst_warns = listToBag [ instOrphWarn dflags unqual d
| (d,i) <- insts `zip` iface_insts
, isNothing (ifInstOrph i) ]
rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r
| r <- iface_rules
, isNothing (ifRuleOrph r)
, if ifRuleAuto r then warn_auto_orphs
......@@ -849,14 +849,14 @@ oldMD5 dflags bh = do
return $! readHexFingerprint hash_str
-}
instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg
instOrphWarn unqual inst
= mkWarnMsg (getSrcSpan inst) unqual $
instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg
instOrphWarn dflags unqual inst
= mkWarnMsg dflags (getSrcSpan inst) unqual $
hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn unqual mod rule
= mkWarnMsg silly_loc unqual $
ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn dflags unqual mod rule
= mkWarnMsg dflags silly_loc unqual $
ptext (sLit "Orphan rule:") <+> ppr rule
where
silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
......
compiler/main/DriverMkDepend.hs
View file @ c3a62c56
......@@ -240,8 +240,10 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
| otherwise
-> return Nothing
fail -> throwOneError $ mkPlainErrMsg srcloc $
cannotFindModule (hsc_dflags hsc_env) imp fail
fail ->
let dflags = hsc_dflags hsc_env
in throwOneError $ mkPlainErrMsg dflags srcloc $
cannotFindModule dflags imp fail
}
-----------------------------
......
compiler/main/DriverPipeline.hs
View file @ c3a62c56
......@@ -774,7 +774,7 @@ runPhase (Cpp sf) input_fn dflags0
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicFilePragma dflags0 src_opts
setDynFlags dflags1
io $ checkProcessArgsResult unhandled_flags
io $ checkProcessArgsResult dflags1 unhandled_flags
if not (xopt Opt_Cpp dflags1) then do
-- we have to be careful to emit warnings only once.
......@@ -791,7 +791,7 @@ runPhase (Cpp sf) input_fn dflags0
src_opts <- io $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- io $ parseDynamicFilePragma dflags0 src_opts
io $ checkProcessArgsResult unhandled_flags
io $ checkProcessArgsResult dflags2 unhandled_flags
unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
......@@ -826,7 +826,7 @@ runPhase (HsPp sf) input_fn dflags
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicFilePragma dflags src_opts
setDynFlags dflags1
io $ checkProcessArgsResult unhandled_flags
io $ checkProcessArgsResult dflags1 unhandled_flags
io $ handleFlagWarnings dflags1 warns
return (Hsc sf, output_fn)
......
compiler/main/ErrUtils.lhs
View file @ c3a62c56
......@@ -107,32 +107,33 @@ makeIntoWarning err = err { errMsgSeverity = SevWarning }
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.
mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
mk_err_msg sev locn print_unqual msg extra
mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
mk_err_msg _ sev locn print_unqual msg extra
= ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
, errMsgShortDoc = msg, errMsgExtraInfo = extra
, errMsgSeverity = sev }
mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
-- A long (multi-line) error message
mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
-- A short (one-line) error message
mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
-- Variant that doesn't care about qualified/unqualified names
mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual msg extra
mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual msg empty
mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify msg empty
mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual msg extra
mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual msg empty
mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify msg empty
mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual msg extra
mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual msg empty
mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify msg empty
mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual msg extra
mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual msg empty
mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify msg empty
----------------
emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)
warnIsErrorMsg :: ErrMsg
warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.")
warnIsErrorMsg :: DynFlags -> ErrMsg
warnIsErrorMsg dflags
= mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
errorsFound :: DynFlags -> Messages -> Bool
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
......
compiler/main/GHC.hs
View file @ c3a62c56
......@@ -1198,7 +1198,9 @@ getTokenStream mod = do
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
PFailed span err ->
do dflags <- getDynFlags
throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
-- | Give even more information on the source than 'getTokenStream'
-- This function allows reconstructing the source completely with
......@@ -1209,7 +1211,9 @@ getRichTokenStream mod = do
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
PFailed span err ->
do dflags <- getDynFlags
throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
......@@ -1381,7 +1385,7 @@ parser str dflags filename =
case unP Parser.parseModule (mkPState dflags buf loc) of
PFailed span err ->
Left (unitBag (mkPlainErrMsg span err))
Left (unitBag (mkPlainErrMsg dflags span err))
POk pst rdr_module ->
let (warns,_) = getMessages pst in
......
compiler/main/GhcMake.hs
View file @ c3a62c56
......@@ -1021,15 +1021,16 @@ nodeMapElts = Map.elems
-- were necessary, then the edge would be part of a cycle.
warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
warnUnnecessarySourceImports sccs = do
logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
where check ms =
dflags <- getDynFlags
logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))
where check dflags ms =
let mods_in_this_cycle = map ms_mod_name ms in
[ warn i | m <- ms, i <- ms_home_srcimps m,
unLoc i `notElem` mods_in_this_cycle ]
[ warn dflags i | m <- ms, i <- ms_home_srcimps m,
unLoc i `notElem` mods_in_this_cycle ]
warn :: Located ModuleName -> WarnMsg
warn (L loc mod) =
mkPlainErrMsg loc
warn :: DynFlags -> Located ModuleName -> WarnMsg
warn dflags (L loc mod) =
mkPlainErrMsg dflags loc
(ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
<+> quotes (ppr mod))
......@@ -1067,6 +1068,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
summs <- loop (concatMap msDeps rootSummaries) root_map
return summs
where
dflags = hsc_dflags hsc_env
roots = hsc_targets hsc_env
old_summary_map :: NodeMap ModSummary
......@@ -1078,14 +1080,14 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
if exists
then summariseFile hsc_env old_summaries file mb_phase
obj_allowed maybe_buf
else throwOneError $ mkPlainErrMsg noSrcSpan $
else throwOneError $ mkPlainErrMsg dflags 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 False
(L rootLoc modl) obj_allowed
maybe_buf excl_mods
case maybe_summary of
Nothing -> packageModErr modl
Nothing -> packageModErr dflags modl
Just s -> return s
rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
......@@ -1098,7 +1100,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 (head dup_roots)
| otherwise = liftIO $ multiRootsErr dflags (head dup_roots)
where
dup_roots :: [[ModSummary]] -- Each at least of length 2
dup_roots = filterOut isSingleton (nodeMapElts root_map)
......@@ -1118,7 +1120,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
= if isSingleton summs then
loop ss done
else
do { multiRootsErr summs; return [] }
do { multiRootsErr dflags summs; return [] }
| otherwise
= do mb_s <- summariseModule hsc_env old_summary_map
is_boot wanted_mod True
......@@ -1342,7 +1344,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 -> noHsFileErr loc src_fn
Nothing -> noHsFileErr dflags loc src_fn
Just t -> new_summary location' mod src_fn t
......@@ -1354,7 +1356,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
(srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
when (mod_name /= wanted_mod) $
throwOneError $ mkPlainErrMsg mod_loc $
throwOneError $ mkPlainErrMsg dflags' mod_loc $
text "File name does not match module name:"
$$ text "Saw:" <+> quotes (ppr mod_name)
$$ text "Expected:" <+> quotes (ppr wanted_mod)
......@@ -1402,7 +1404,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
(dflags', leftovers, warns)
<- parseDynamicFilePragma dflags local_opts
checkProcessArgsResult leftovers
checkProcessArgsResult dflags leftovers
handleFlagWarnings dflags' warns
let needs_preprocessing
......@@ -1426,21 +1428,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
-- ToDo: we don't have a proper line number for this error
noModError dflags loc wanted_mod err
= throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
= throwOneError $ mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err
noHsFileErr :: SrcSpan -> String -> IO a
noHsFileErr loc path
= throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
noHsFileErr :: DynFlags -> SrcSpan -> String -> IO a
noHsFileErr dflags loc path
= throwOneError $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
packageModErr :: ModuleName -> IO a
packageModErr mod
= throwOneError $ mkPlainErrMsg noSrcSpan $
packageModErr :: DynFlags -> ModuleName -> IO a
packageModErr dflags mod
= throwOneError $ mkPlainErrMsg dflags noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "is a package module"
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
multiRootsErr summs@(summ1:_)
= throwOneError $ mkPlainErrMsg noSrcSpan $
multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
multiRootsErr _ [] = panic "multiRootsErr"
multiRootsErr dflags summs@(summ1:_)
= throwOneError $ mkPlainErrMsg dflags noSrcSpan $
text "module" <+> quotes (ppr mod) <+>
text "is defined in multiple files:" <+>
sep (map text files)
......
compiler/main/HeaderInfo.hs
View file @ c3a62c56
......@@ -64,7 +64,7 @@ getImports :: DynFlags
getImports dflags buf filename source_filename = do
let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState dflags buf loc) of
PFailed span err -> parseError span err
PFailed span err -> parseError dflags span err
POk pst rdr_module -> do
let _ms@(_warns, errs) = getMessages pst
-- don't log warnings: they'll be reported when we parse the file
......@@ -123,8 +123,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls
ideclAs = Nothing,
ideclHiding = Nothing }
parseError :: SrcSpan -> MsgDoc -> IO a
parseError span err = throwOneError $ mkPlainErrMsg span err
parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
--------------------------------------------------------------
-- Get options
......@@ -141,7 +141,8 @@ getOptionsFromFile dflags filename
(openBinaryFile filename ReadMode)
(hClose)
(\handle -> do
opts <- fmap getOptions' $ lazyGetToks dflags' filename handle
opts <- fmap (getOptions' dflags)
(lazyGetToks dflags' filename handle)
seqList opts $ return opts)
where -- We don't need to get haddock doc tokens when we're just
-- getting the options from pragmas, and lazily lexing them
......@@ -214,15 +215,16 @@ getOptions :: DynFlags
-> FilePath -- ^ Source filename. Used for location info.
-> [Located String] -- ^ Parsed options.
getOptions dflags buf filename
= getOptions' (getToks dflags filename buf)
= getOptions' dflags (getToks dflags filename buf)
-- The token parser is written manually because Happy can't
-- return a partial result when it encounters a lexer error.
-- We want to extract options before the buffer is passed through
-- CPP, so we can't use the same trick as 'getImports'.
getOptions' :: [Located Token] -- Input buffer
getOptions' :: DynFlags
-> [Located Token] -- Input buffer
-> [Located String] -- Options.
getOptions' toks
getOptions' dflags toks
= parseToks toks
where
getToken (L _loc tok) = tok
......@@ -252,14 +254,14 @@ getOptions' toks
= parseLanguage xs
parseToks _ = []
parseLanguage (L loc (ITconid fs):rest)
= checkExtension (L loc fs) :
= checkExtension dflags (L loc fs) :
case rest of
(L _loc ITcomma):more -> parseLanguage more
(L _loc ITclose_prag):more -> parseToks more
(L loc _):_ -> languagePragParseError loc
(L loc _):_ -> languagePragParseError dflags loc
[] -> panic "getOptions'.parseLanguage(1) went past eof token"
parseLanguage (tok:_)
= languagePragParseError (getLoc tok)
= languagePragParseError dflags (getLoc tok)
parseLanguage []
= panic "getOptions'.parseLanguage(2) went past eof token"
......@@ -269,51 +271,51 @@ getOptions' toks
--
-- Throws a 'SourceError' if the input list is non-empty claiming that the
-- input flags are unknown.
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
checkProcessArgsResult flags
checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
checkProcessArgsResult dflags flags
= when (notNull flags) $
liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
where mkMsg (L loc flag)
= mkPlainErrMsg loc $
= mkPlainErrMsg dflags loc $
(text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
text flag)
-----------------------------------------------------------------------------
checkExtension :: Located FastString -> Located String
checkExtension (L l ext)
checkExtension :: DynFlags -> Located FastString -> Located String
checkExtension dflags (L l ext)
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
= let ext' = unpackFS ext in
if ext' `elem` supportedLanguagesAndExtensions
then L l ("-X"++ext')
else unsupportedExtnError l ext'
else unsupportedExtnError dflags l ext'
languagePragParseError :: SrcSpan -> a
languagePragParseError loc =
languagePragParseError :: DynFlags -> SrcSpan -> a
languagePragParseError dflags loc =
throw $ mkSrcErr $ unitBag $
(mkPlainErrMsg loc $
(mkPlainErrMsg dflags loc $
vcat [ text "Cannot parse LANGUAGE pragma"
, text "Expecting comma-separated list of language options,"
, text "each starting with a capital letter"
, nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
unsupportedExtnError :: SrcSpan -> String -> a
unsupportedExtnError loc unsup =
unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
unsupportedExtnError dflags loc unsup =
throw $ mkSrcErr $ unitBag $
mkPlainErrMsg loc $
mkPlainErrMsg dflags loc $
text "Unsupported extension: " <> text unsup $$
if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
where
suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
optionsErrorMsgs unhandled_flags flags_lines _filename
optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
optionsErrorMsgs dflags unhandled_flags flags_lines _filename
= (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
L l f' <- flags_lines, f == f' ]
mkMsg (L flagSpan flag) =
ErrUtils.mkPlainErrMsg flagSpan $
ErrUtils.mkPlainErrMsg dflags flagSpan $
text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
compiler/main/HscMain.hs
View file @ c3a62c56
......@@ -359,7 +359,7 @@ hscParse' mod_summary = do
case unP parseModule (mkPState dflags buf loc) of
PFailed span err ->
liftIO $ throwOneError (mkPlainErrMsg span err)
liftIO $ throwOneError (mkPlainErrMsg dflags span err)
POk pst rdr_module -> do
logWarningsReportErrors (getMessages pst)
......@@ -443,7 +443,7 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do
safe <- liftIO $ readIORef (tcg_safeInfer tcg_res')
when (safe && wopt Opt_WarnSafe dflags)
(logWarnings $ unitBag $
mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_res')
mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ errSafe tcg_res')
return tcg_res'
where
pprMod t = ppr $ moduleName $ tcg_mod t
......@@ -919,22 +919,22 @@ hscCheckSafeImports tcg_env = do
case safeLanguageOn dflags of
True -> do
-- we nuke user written RULES in -XSafe
logWarnings $ warns (tcg_rules tcg_env')
logWarnings $ warns dflags (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
-- user defined RULES, so not safe or already unsafe
| safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
safeHaskell dflags == Sf_None
-> wipeTrust tcg_env' $ warns (tcg_rules tcg_env')
-> wipeTrust tcg_env' $ warns dflags (tcg_rules tcg_env')
-- trustworthy OR safe infered with no RULES
| otherwise
-> return tcg_env'
where
warns rules = listToBag $ map warnRules rules
warnRules (L loc (HsRule n _ _ _ _ _ _)) =
mkPlainWarnMsg loc $
warns dflags rules = listToBag $ map (warnRules dflags) rules
warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
mkPlainWarnMsg dflags loc $
text "Rule \"" <> ftext n <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
......@@ -1001,7 +1001,7 @@ checkSafeImports dflags tcg_env
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' v1@(m1,_,l1,s1) (_,_,_,s2)
| s1 /= s2
= throwErrors $ unitBag $ mkPlainErrMsg l1
= throwErrors $ unitBag $ mkPlainErrMsg dflags l1
(text "Module" <+> ppr m1 <+>
(text $ "is imported both as a safe and unsafe import!"))
| otherwise
......@@ -1040,7 +1040,7 @@ hscCheckSafe' dflags m l = do
iface <- lookup' m
case iface of
-- can't load iface to check trust!
Nothing -> throwErrors $ unitBag $ mkPlainErrMsg l
Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
$ text "Can't load the interface file for" <+> ppr m
<> text ", to check that it can be safely imported"
......@@ -1062,13 +1062,13 @@ hscCheckSafe' dflags m l = do
return (trust == Sf_Trustworthy, pkgRs)
where
pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $
pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg dflags l $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The package (" <> ppr (modulePackageId m)
<> text ") the module resides in isn't trusted."
]
modTrustErr = unitBag $ mkPlainErrMsg l $
modTrustErr = unitBag $ mkPlainErrMsg dflags l $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The module itself isn't safe." ]
......@@ -1124,7 +1124,7 @@ checkPkgTrust dflags pkgs =
| trusted $ getPackageDetails (pkgState dflags) pkg
= Nothing
| otherwise
= Just $ mkPlainErrMsg noSrcSpan
= Just $ mkPlainErrMsg dflags noSrcSpan
$ text "The package (" <> ppr pkg <> text ") is required" <>
text " to be trusted but it isn't!"
......@@ -1138,7 +1138,7 @@ wipeTrust tcg_env whyUnsafe = do
when (wopt Opt_WarnUnsafe dflags)
(logWarnings $ unitBag $
mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
liftIO $ writeIORef (tcg_safeInfer tcg_env) False
return $ tcg_env { tcg_imports = wiped_trust }
......@@ -1538,7 +1538,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do
case is of
[i] -> return (unLoc i)
_ -> liftIO $ throwOneError $
mkPlainErrMsg noSrcSpan $
mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
ptext (sLit "parse error in import declaration")
-- | Typecheck an expression (but don't run it)
......@@ -1552,7 +1552,7 @@ hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
Just (L _ (ExprStmt expr _ _ _)) ->
ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
_ ->
throwErrors $ unitBag $ mkPlainErrMsg noSrcSpan
throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
(text "not an expression:" <+> quotes (text expr))
-- | Find the kind of a type
......@@ -1597,7 +1597,7 @@ hscParseThingWithLocation source linenumber parser str
case unP parser (mkPState dflags buf loc) of
PFailed span err -> do
let msg = mkPlainErrMsg span err
let msg = mkPlainErrMsg dflags span err
throwErrors $ unitBag msg
POk pst thing -> do
......
compiler/main/HscTypes.lhs
View file @ c3a62c56
......@@ -235,7 +235,7 @@ printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printOrThrowWarnings dflags warns
| dopt Opt_WarnIsError dflags
= when (not (isEmptyBag warns)) $ do
throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg
throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags
| otherwise
= printBagOfErrors dflags warns
......@@ -244,7 +244,7 @@ handleFlagWarnings dflags warns
= when (wopt Opt_WarnDeprecatedFlags dflags) $ do
-- It would be nicer if warns :: [Located MsgDoc], but that
-- has circular import problems.
let bag = listToBag [ mkPlainWarnMsg loc (text warn)
let bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
| L loc warn <- warns ]
printOrThrowWarnings dflags bag
......
compiler/parser/Lexer.x
View file @ c3a62c56
......@@ -1960,7 +1960,7 @@ mkPState flags buf loc =
addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
= P $ \s@PState{messages=(ws,es), dflags=d} ->
let warning' = mkWarnMsg srcspan alwaysQualify warning
let warning' = mkWarnMsg d srcspan alwaysQualify warning
ws' = if wopt option d then ws `snocBag` warning' else ws
in POk s{messages=(ws', es)} ()
......
compiler/typecheck/TcRnMonad.lhs
View file @ c3a62c56
......@@ -635,7 +635,7 @@ mkLongErrAt loc msg extra
= do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ;
rdr_env <- getGlobalRdrEnv ;
dflags <- getDynFlags ;
return $ mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra }
return $ mkLongErrMsg dflags loc (mkPrintUnqualified dflags rdr_env) msg extra }
addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
......@@ -917,7 +917,7 @@ add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
add_warn_at loc msg extra_info
= do { rdr_env <- getGlobalRdrEnv ;
dflags <- getDynFlags ;
let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
let { warn = mkLongWarnMsg dflags loc (mkPrintUnqualified dflags rdr_env)
msg extra_info } ;
reportWarning warn }
......