Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/c690214d52904d4209d929fce739b831c287c6e8 >--------------------------------------------------------------- commit c690214d52904d4209d929fce739b831c287c6e8 Author: David Terei <[email protected]> Date: Mon Apr 2 18:58:43 2012 -0700 Fix tracking of reason safe inference failed. (#5988) >--------------------------------------------------------------- compiler/main/DynFlags.hs | 26 ++++++++++++++++---------- compiler/main/ErrUtils.lhs | 5 ++++- compiler/main/HscMain.hs | 39 ++++++++++++++++++++++++++------------- 3 files changed, 46 insertions(+), 24 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index e111bea..2cc8446 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index be7f254..dc73257 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -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 diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index efad3b7..8847793 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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 = [] -------------------------------------------------------------- _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
