Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
c3a62c56
Commit
c3a62c56
authored
Jun 12, 2012
by
Ian Lynagh
Browse files
Pass DynFlags down to mk_err_msg
parent
91667cc9
Changes
13
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 }
...
...
Write
Preview