Commit c690214d authored by dterei's avatar dterei

Fix tracking of reason safe inference failed. (#5988)

parent 2bf60839
......@@ -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_flags
(dflags', warns) = foldl check_method (dflags, []) unsafeFlags
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
......
......@@ -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
......
......@@ -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 = []
--------------------------------------------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment