Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
6f43ec8c
Commit
6f43ec8c
authored
Oct 17, 2011
by
dterei
Browse files
Fix safe haskell warnings to include src locations
parent
c532c16f
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/main/CmdLineParser.hs
View file @
6f43ec8c
...
...
@@ -15,7 +15,7 @@ module CmdLineParser (
Flag
(
..
),
errorsToGhcException
,
EwM
,
addErr
,
addWarn
,
getArg
,
liftEwM
,
deprecate
EwM
,
addErr
,
addWarn
,
getArg
,
getCurLoc
,
liftEwM
,
deprecate
)
where
#
include
"HsVersions.h"
...
...
@@ -91,6 +91,9 @@ deprecate s
getArg
::
Monad
m
=>
EwM
m
String
getArg
=
EwM
(
\
(
L
_
arg
)
es
ws
->
return
(
es
,
ws
,
arg
))
getCurLoc
::
Monad
m
=>
EwM
m
SrcSpan
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
)
})
...
...
compiler/main/DynFlags.hs
View file @
6f43ec8c
...
...
@@ -547,6 +547,11 @@ data DynFlags = DynFlags {
language
::
Maybe
Language
,
-- | Safe Haskell mode
safeHaskell
::
SafeHaskellMode
,
-- We store the location of where template haskell and newtype deriving were
-- turned on so we can produce accurate error messages when Safe Haskell turns
-- them off.
thOnLoc
::
SrcSpan
,
newDerivOnLoc
::
SrcSpan
,
-- Don't change this without updating extensionFlags:
extensions
::
[
OnOff
ExtensionFlag
],
-- extensionFlags should always be equal to
...
...
@@ -869,6 +874,8 @@ defaultDynFlags mySettings =
warningFlags
=
standardWarnings
,
language
=
Nothing
,
safeHaskell
=
Sf_None
,
thOnLoc
=
noSrcSpan
,
newDerivOnLoc
=
noSrcSpan
,
extensions
=
[]
,
extensionFlags
=
flattenExtensionFlags
Nothing
[]
,
log_action
=
defaultLogAction
...
...
@@ -1267,16 +1274,18 @@ parseDynamicFlags dflags0 args cmdline = do
shFlagsDisallowed
::
DynFlags
->
(
DynFlags
,
[
Located
String
])
shFlagsDisallowed
dflags
=
foldl
check_method
(
dflags
,
[]
)
bad_flags
where
check_method
(
df
,
warns
)
(
test
,
st
r
,
fix
)
|
test
df
=
(
fix
df
,
warns
++
safeFailure
str
)
check_method
(
df
,
warns
)
(
str
,
loc
,
te
st
,
fix
)
|
test
df
=
(
fix
df
,
warns
++
safeFailure
loc
str
)
|
otherwise
=
(
df
,
warns
)
bad_flags
=
[(
xopt
Opt_GeneralizedNewtypeDeriving
,
"-XGeneralizedNewtypeDeriving"
,
flip
xopt_unset
Opt_GeneralizedNewtypeDeriving
),
(
xopt
Opt_TemplateHaskell
,
"-XTemplateHaskell"
,
flip
xopt_unset
Opt_TemplateHaskell
)]
bad_flags
=
[(
"-XGeneralizedNewtypeDeriving"
,
newDerivOnLoc
dflags
,
xopt
Opt_GeneralizedNewtypeDeriving
,
flip
xopt_unset
Opt_GeneralizedNewtypeDeriving
),
(
"-XTemplateHaskell"
,
thOnLoc
dflags
,
xopt
Opt_TemplateHaskell
,
flip
xopt_unset
Opt_TemplateHaskell
)]
safeFailure
str
=
[
L
noSrcSpan
$
"Warning: "
++
str
++
" is not allowed in"
safeFailure
loc
str
=
[
L
loc
$
"Warning: "
++
str
++
" is not allowed in"
++
" Safe Haskell; ignoring "
++
str
]
...
...
@@ -1895,7 +1904,7 @@ xFlags = [
(
"ConstrainedClassMethods"
,
Opt_ConstrainedClassMethods
,
nop
),
(
"MultiParamTypeClasses"
,
Opt_MultiParamTypeClasses
,
nop
),
(
"FunctionalDependencies"
,
Opt_FunctionalDependencies
,
nop
),
(
"GeneralizedNewtypeDeriving"
,
Opt_GeneralizedNewtypeDeriving
,
nop
),
(
"GeneralizedNewtypeDeriving"
,
Opt_GeneralizedNewtypeDeriving
,
setGenDeriving
),
(
"OverlappingInstances"
,
Opt_OverlappingInstances
,
nop
),
(
"UndecidableInstances"
,
Opt_UndecidableInstances
,
nop
),
(
"IncoherentInstances"
,
Opt_IncoherentInstances
,
nop
),
...
...
@@ -2085,13 +2094,17 @@ rtsIsProfiled :: Bool
rtsIsProfiled
=
unsafePerformIO
rtsIsProfiledIO
/=
0
#
endif
setGenDeriving
::
Bool
->
DynP
()
setGenDeriving
True
=
getCurLoc
>>=
\
l
->
upd
(
\
d
->
d
{
newDerivOnLoc
=
l
})
setGenDeriving
False
=
return
()
checkTemplateHaskellOk
::
Bool
->
DynP
()
#
ifdef
GHCI
checkTemplateHaskellOk
turn_on
|
turn_on
&&
rtsIsProfiled
=
addErr
"You can't use Template Haskell with a profiled compiler"
|
otherwise
=
r
etur
n
(
)
=
g
et
C
ur
Loc
>>=
\
l
->
upd
(
\
d
->
d
{
thOnLoc
=
l
}
)
#
else
-- In stage 1 we don't know that the RTS has rts_isProfiled,
-- so we simply say "ok". It doesn't matter because TH isn't
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment