Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Tobias Decking
GHC
Commits
14bbddac
Commit
14bbddac
authored
Nov 16, 2011
by
dterei
Browse files
Add Safe Haskell '-fwarn-safe', '-fwarn-unsafe', '-fno-safe-infer' flags
parent
78ee2937
Changes
4
Hide whitespace changes
Inline
Side-by-side
compiler/iface/MkIface.lhs
View file @
14bbddac
...
...
@@ -262,7 +262,7 @@ mkIface_ hsc_env maybe_old_fingerprint
; iface_vect_info = flattenVectInfo vect_info
-- Check if we are in Safe Inference mode but we failed to pass
-- the muster
; safeMode = if safeInferOn dflags
&& not safeInf
; safeMode = if safeInferOn dflags && not safeInf
then Sf_None
else safeHaskell dflags
; trust_info = setSafeMode safeMode
...
...
compiler/main/DynFlags.hs
View file @
14bbddac
...
...
@@ -338,6 +338,8 @@ data WarningFlag =
|
Opt_WarnUnusedDoBind
|
Opt_WarnWrongDoBind
|
Opt_WarnAlternativeLayoutRuleTransitional
|
Opt_WarnUnsafe
|
Opt_WarnSafe
deriving
(
Eq
,
Show
)
data
Language
=
Haskell98
|
Haskell2010
...
...
@@ -560,6 +562,8 @@ data DynFlags = DynFlags {
-- them off.
thOnLoc
::
SrcSpan
,
newDerivOnLoc
::
SrcSpan
,
warnSafeOnLoc
::
SrcSpan
,
warnUnsafeOnLoc
::
SrcSpan
,
-- Don't change this without updating extensionFlags:
extensions
::
[
OnOff
ExtensionFlag
],
-- extensionFlags should always be equal to
...
...
@@ -894,6 +898,8 @@ defaultDynFlags mySettings =
safeHaskell
=
Sf_SafeInfered
,
thOnLoc
=
noSrcSpan
,
newDerivOnLoc
=
noSrcSpan
,
warnSafeOnLoc
=
noSrcSpan
,
warnUnsafeOnLoc
=
noSrcSpan
,
extensions
=
[]
,
extensionFlags
=
flattenExtensionFlags
Nothing
[]
,
log_action
=
defaultLogAction
,
...
...
@@ -1076,10 +1082,12 @@ safeImplicitImpsReq d = safeLanguageOn d
-- want to export this functionality from the module but do want to export the
-- type constructors.
combineSafeFlags
::
SafeHaskellMode
->
SafeHaskellMode
->
DynP
SafeHaskellMode
combineSafeFlags
a
b
|
a
`
elem
`
[
Sf_None
,
Sf_SafeInfered
]
=
return
b
|
b
`
elem
`
[
Sf_None
,
Sf_SafeInfered
]
=
return
a
|
a
==
b
=
return
a
|
otherwise
=
addErr
errm
>>
return
(
panic
errm
)
combineSafeFlags
a
b
|
a
==
Sf_SafeInfered
=
return
b
|
b
==
Sf_SafeInfered
=
return
a
|
a
==
Sf_None
=
return
b
|
b
==
Sf_None
=
return
a
|
a
==
b
=
return
a
|
otherwise
=
addErr
errm
>>
return
(
panic
errm
)
where
errm
=
"Incompatible Safe Haskell flags! ("
++
showPpr
a
++
", "
++
showPpr
b
++
")"
...
...
@@ -1638,6 +1646,7 @@ dynamic_flags = [
------ Safe Haskell flags -------------------------------------------
,
Flag
"fpackage-trust"
(
NoArg
(
setDynFlag
Opt_PackageTrust
))
,
Flag
"fno-safe-infer"
(
NoArg
(
setSafeHaskell
Sf_None
))
]
++
map
(
mkFlag
turnOn
"f"
setDynFlag
)
fFlags
++
map
(
mkFlag
turnOff
"fno-"
unSetDynFlag
)
fFlags
...
...
@@ -1737,10 +1746,12 @@ fWarningFlags = [
(
"warn-auto-orphans"
,
Opt_WarnAutoOrphans
,
nop
),
(
"warn-tabs"
,
Opt_WarnTabs
,
nop
),
(
"warn-unrecognised-pragmas"
,
Opt_WarnUnrecognisedPragmas
,
nop
),
(
"warn-lazy-unlifted-bindings"
,
Opt_WarnLazyUnliftedBindings
,
nop
),
(
"warn-lazy-unlifted-bindings"
,
Opt_WarnLazyUnliftedBindings
,
nop
),
(
"warn-unused-do-bind"
,
Opt_WarnUnusedDoBind
,
nop
),
(
"warn-wrong-do-bind"
,
Opt_WarnWrongDoBind
,
nop
),
(
"warn-alternative-layout-rule-transitional"
,
Opt_WarnAlternativeLayoutRuleTransitional
,
nop
)]
(
"warn-alternative-layout-rule-transitional"
,
Opt_WarnAlternativeLayoutRuleTransitional
,
nop
),
(
"warn-unsafe"
,
Opt_WarnUnsafe
,
setWarnUnsafe
),
(
"warn-safe"
,
Opt_WarnSafe
,
setWarnSafe
)
]
-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
fFlags
::
[
FlagSpec
DynFlag
]
...
...
@@ -2137,6 +2148,14 @@ rtsIsProfiled :: Bool
rtsIsProfiled
=
unsafePerformIO
rtsIsProfiledIO
/=
0
#
endif
setWarnSafe
::
Bool
->
DynP
()
setWarnSafe
True
=
getCurLoc
>>=
\
l
->
upd
(
\
d
->
d
{
warnSafeOnLoc
=
l
})
setWarnSafe
False
=
return
()
setWarnUnsafe
::
Bool
->
DynP
()
setWarnUnsafe
True
=
getCurLoc
>>=
\
l
->
upd
(
\
d
->
d
{
warnUnsafeOnLoc
=
l
})
setWarnUnsafe
False
=
return
()
setGenDeriving
::
Bool
->
DynP
()
setGenDeriving
True
=
getCurLoc
>>=
\
l
->
upd
(
\
d
->
d
{
newDerivOnLoc
=
l
})
setGenDeriving
False
=
return
()
...
...
compiler/main/ErrUtils.lhs
View file @
14bbddac
...
...
@@ -12,7 +12,7 @@
-- for details
module ErrUtils (
Message, mkLocMessage, printError, pprMessageBag,
Message, mkLocMessage, printError, pprMessageBag,
pprErrMsgBag,
Severity(..),
ErrMsg, WarnMsg,
...
...
@@ -149,23 +149,31 @@ printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printBagOfWarnings dflags bag_of_warns =
printMsgBag dflags bag_of_warns SevWarning
pprErrMsgBag :: Bag ErrMsg -> [SDoc]
pprErrMsgBag bag
= [ let style = mkErrStyle unqual
in withPprStyle style (d $$ e)
| ErrMsg { errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sortMsgBag bag ]
printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
printMsgBag dflags bag sev
= sequence_
[ let style = mkErrStyle unqual
in log_action dflags sev s style (d $$ e)
| ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sort
ed_errs
]
where
bag_ls = bagToList bag
sorted_errs = sortLe occ'ed_before bag_ls
occ'ed_before
err1 err2 =
case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
LT -> True
EQ -> True
GT -> False
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags sev s style (d $$ e)
| ErrMsg { errMsgSpans
= s:_,
errMsgShortDoc
= d,
errMsgExtraInfo = e,
errMsgContext
= unqual } <- sort
MsgBag bag
]
sortMsgBag :: Bag ErrMsg -> [ErrMsg]
sortMsgBag bag = sortLe srcOrder $ bagToList bag
where
srcOrder
err1 err2 =
case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
LT -> True
EQ -> True
GT -> False
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
...
...
compiler/main/HscMain.hs
View file @
14bbddac
...
...
@@ -167,7 +167,7 @@ newHscEnv dflags = do
mlc_var
<-
newIORef
emptyModuleEnv
optFuel
<-
initOptFuelState
safe_var
<-
newIORef
True
return
HscEnv
{
hsc_dflags
=
dflags
,
return
HscEnv
{
hsc_dflags
=
dflags
,
hsc_targets
=
[]
,
hsc_mod_graph
=
[]
,
hsc_IC
=
emptyInteractiveContext
,
...
...
@@ -790,10 +790,25 @@ hscFileFrontEnd mod_summary = do
ioMsgMaybe
$
tcRnModule
hsc_env
(
ms_hsc_src
mod_summary
)
False
rdr_module
tcSafeOK
<-
liftIO
$
readIORef
(
tcg_safeInfer
tcg_env
)
-- if safe haskell off or safe infer failed, wipe trust
-- end of the Safe Haskell line, how to respond to user?
if
not
(
safeHaskellOn
dflags
)
||
(
safeInferOn
dflags
&&
not
tcSafeOK
)
then
wipeTrust
tcg_env
else
hscCheckSafeImports
tcg_env
-- if safe haskell off or safe infer failed, wipe trust
then
wipeTrust
tcg_env
emptyBag
-- module safe, throw warning if needed
else
do
tcg_env'
<-
hscCheckSafeImports
tcg_env
safe
<-
liftIO
$
hscGetSafeInf
hsc_env
when
(
safe
&&
wopt
Opt_WarnSafe
dflags
)
(
logWarnings
$
unitBag
$
mkPlainWarnMsg
(
warnSafeOnLoc
dflags
)
$
errSafe
tcg_env'
)
return
tcg_env'
where
pprMod
t
=
ppr
$
moduleName
$
tcg_mod
t
errSafe
t
=
text
"Warning:"
<+>
quotes
(
pprMod
t
)
<+>
text
"has been infered as safe!"
--------------------------------------------------------------
-- Safe Haskell
...
...
@@ -850,9 +865,9 @@ hscCheckSafeImports tcg_env = do
-- user defined RULES, so not safe or already unsafe
|
safeInferOn
dflags
&&
not
(
null
$
tcg_rules
tcg_env'
)
||
safeHaskell
dflags
==
Sf_None
->
wipeTrust
tcg_env'
->
wipeTrust
tcg_env'
$
warns
(
tcg_rules
tcg_env'
)
-- trustworthy
-- trustworthy
OR safe infered with no RULES
|
otherwise
->
return
tcg_env'
...
...
@@ -900,7 +915,7 @@ checkSafeImports dflags hsc_env tcg_env
True
->
-- did we fail safe inference or fail -XSafe?
case
safeInferOn
dflags
of
True
->
wipeTrust
tcg_env
True
->
wipeTrust
tcg_env
errs
False
->
liftIO
.
throwIO
.
mkSrcErr
$
errs
-- All good matey!
...
...
@@ -1025,12 +1040,29 @@ checkSafeImports dflags hsc_env tcg_env
|
otherwise
=
Just
(
modulePackageId
m
)
-- | Set module to unsafe and wipe trust information.
wipeTrust
::
TcGblEnv
->
Hsc
TcGblEnv
wipeTrust
tcg_env
=
do
env
<-
getHscEnv
--
-- Make sure to call this method to set a module to infered unsafe,
-- it should be a central and single failure method.
wipeTrust
::
TcGblEnv
->
WarningMessages
->
Hsc
TcGblEnv
wipeTrust
tcg_env
whyUnsafe
=
do
env
<-
getHscEnv
dflags
<-
getDynFlags
when
(
wopt
Opt_WarnUnsafe
dflags
)
(
logWarnings
$
unitBag
$
mkPlainWarnMsg
(
warnUnsafeOnLoc
dflags
)
whyUnsafe'
)
liftIO
$
hscSetSafeInf
env
False
let
imps
=
(
tcg_imports
tcg_env
)
{
imp_trust_pkgs
=
[]
}
return
$
tcg_env
{
tcg_imports
=
imps
}
return
$
tcg_env
{
tcg_imports
=
wiped_trust
}
where
wiped_trust
=
(
tcg_imports
tcg_env
)
{
imp_trust_pkgs
=
[]
}
pprMod
=
ppr
$
moduleName
$
tcg_mod
tcg_env
whyUnsafe'
=
vcat
[
text
"Warning:"
<+>
quotes
pprMod
<+>
text
"has been infered as unsafe!"
,
text
"Reason:"
,
nest
4
(
vcat
$
pprErrMsgBag
whyUnsafe
)
]
--------------------------------------------------------------
-- Simplifiers
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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