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
c690214d
Commit
c690214d
authored
Apr 02, 2012
by
dterei
Browse files
Fix tracking of reason safe inference failed. (
#5988
)
parent
2bf60839
Changes
3
Hide whitespace changes
Inline
Side-by-side
compiler/main/DynFlags.hs
View file @
c690214d
...
...
@@ -48,6 +48,7 @@ module DynFlags (
safeHaskellOn
,
safeImportsOn
,
safeLanguageOn
,
safeInferOn
,
packageTrustOn
,
safeDirectImpsReq
,
safeImplicitImpsReq
,
unsafeFlags
,
-- ** System tool settings and locations
Settings
(
..
),
...
...
@@ -1151,6 +1152,19 @@ combineSafeFlags a b | a == Sf_SafeInfered = return b
where
errm
=
"Incompatible Safe Haskell flags! ("
++
showPpr
a
++
", "
++
showPpr
b
++
")"
-- | A list of unsafe flags under Safe Haskell. Tuple elements are:
-- * name of the flag
-- * function to get srcspan that enabled the flag
-- * function to test if the flag is on
-- * function to turn the flag off
unsafeFlags
::
[(
String
,
DynFlags
->
SrcSpan
,
DynFlags
->
Bool
,
DynFlags
->
DynFlags
)]
unsafeFlags
=
[(
"-XGeneralizedNewtypeDeriving"
,
newDerivOnLoc
,
xopt
Opt_GeneralizedNewtypeDeriving
,
flip
xopt_unset
Opt_GeneralizedNewtypeDeriving
),
(
"-XTemplateHaskell"
,
thOnLoc
,
xopt
Opt_TemplateHaskell
,
flip
xopt_unset
Opt_TemplateHaskell
)]
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts
::
DynFlags
-- ^ 'DynFlags' to retrieve the options from
->
(
DynFlags
->
[
a
])
-- ^ Relevant record accessor: one of the @opt_*@ accessors
...
...
@@ -1388,10 +1402,10 @@ safeFlagCheck cmdl dflags =
-- TODO: Can we do better than this for inference?
safeInfOk
=
not
$
xopt
Opt_OverlappingInstances
dflags
(
dflags'
,
warns
)
=
foldl
check_method
(
dflags
,
[]
)
bad_f
lags
(
dflags'
,
warns
)
=
foldl
check_method
(
dflags
,
[]
)
unsafeF
lags
check_method
(
df
,
warns
)
(
str
,
loc
,
test
,
fix
)
|
test
df
=
(
apFix
fix
df
,
warns
++
safeFailure
loc
str
)
|
test
df
=
(
apFix
fix
df
,
warns
++
safeFailure
(
loc
dflags
)
str
)
|
otherwise
=
(
df
,
warns
)
apFix
f
=
if
safeInferOn
dflags
then
id
else
f
...
...
@@ -1399,14 +1413,6 @@ safeFlagCheck cmdl dflags =
safeFailure
loc
str
=
[
L
loc
$
str
++
" is not allowed in Safe Haskell; ignoring "
++
str
]
bad_flags
=
[(
"-XGeneralizedNewtypeDeriving"
,
newDerivOnLoc
dflags
,
xopt
Opt_GeneralizedNewtypeDeriving
,
flip
xopt_unset
Opt_GeneralizedNewtypeDeriving
),
(
"-XTemplateHaskell"
,
thOnLoc
dflags
,
xopt
Opt_TemplateHaskell
,
flip
xopt_unset
Opt_TemplateHaskell
)]
{- **********************************************************************
%* *
DynFlags specifications
...
...
compiler/main/ErrUtils.lhs
View file @
c690214d
...
...
@@ -9,7 +9,7 @@ module ErrUtils (
ErrMsg, WarnMsg, Severity(..),
Messages, ErrorMessages, WarningMessages,
errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag,
MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag,
pprErrMsgBagWithLoc,
pprLocErrMsg, makeIntoWarning,
errorsFound, emptyMessages,
...
...
@@ -144,6 +144,9 @@ pprErrMsgBag bag
errMsgExtraInfo = e,
errMsgContext = unqual } <- sortMsgBag bag ]
pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ]
pprLocErrMsg :: ErrMsg -> SDoc
pprLocErrMsg (ErrMsg { errMsgSpans = spans
, errMsgShortDoc = d
...
...
compiler/main/HscMain.hs
View file @
c690214d
...
...
@@ -1052,13 +1052,16 @@ hscCheckSafe' dflags m l = do
return
(
trust
==
Sf_Trustworthy
,
pkgRs
)
where
pkgTrustErr
=
mkSrcErr
$
unitBag
$
mkPlainErrMsg
l
$
ppr
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
$
ppr
m
<+>
text
"can't be safely imported!"
<+>
text
"The module itself isn't safe."
pkgTrustErr
=
mkSrcErr
$
unitBag
$
mkPlainErrMsg
l
$
sep
[
ppr
(
moduleName
m
)
<>
text
":"
,
text
"Can't be safely imported!"
,
text
"The package ("
<>
ppr
(
modulePackageId
m
)
<>
text
") the module resides in isn't trusted."
]
modTrustErr
=
unitBag
$
mkPlainErrMsg
l
$
sep
[
ppr
(
moduleName
m
)
<>
text
":"
,
text
"Can't be safely imported!"
,
text
"The module itself isn't safe."
]
-- | Check the package a module resides in is trusted. Safe compiled
-- modules are trusted without requiring that their package is trusted. For
...
...
@@ -1126,17 +1129,27 @@ wipeTrust tcg_env whyUnsafe = do
when
(
wopt
Opt_WarnUnsafe
dflags
)
(
logWarnings
$
unitBag
$
mkPlainWarnMsg
(
warnUnsafeOnLoc
dflags
)
whyUnsafe'
)
mkPlainWarnMsg
(
warnUnsafeOnLoc
dflags
)
(
whyUnsafe'
dflags
)
)
liftIO
$
hscSetSafeInf
env
False
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
[
quotes
pprMod
<+>
text
"has been infered as unsafe!"
,
text
"Reason:"
,
nest
4
(
vcat
$
pprErrMsgBag
whyUnsafe
)
]
wiped_trust
=
(
tcg_imports
tcg_env
)
{
imp_trust_pkgs
=
[]
}
pprMod
=
ppr
$
moduleName
$
tcg_mod
tcg_env
whyUnsafe'
df
=
vcat
[
quotes
pprMod
<+>
text
"has been infered as unsafe!"
,
text
"Reason:"
,
nest
4
$
(
vcat
$
badFlags
df
)
$+$
(
vcat
$
pprErrMsgBagWithLoc
whyUnsafe
)
]
badFlags
df
=
concat
$
map
(
badFlag
df
)
unsafeFlags
badFlag
df
(
str
,
loc
,
on
,
_
)
|
on
df
=
[
mkLocMessage
SevOutput
(
loc
df
)
$
text
str
<+>
text
"is not allowed in Safe Haskell"
]
|
otherwise
=
[]
--------------------------------------------------------------
...
...
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