diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3b2e3400a8e5d98bfaacf3c6510549800c9b3cf9..0d474466dffc21f1497db5bc33f7503e1083cfce 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -45,6 +45,7 @@ module DynFlags (
safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
packageTrustOn,
safeDirectImpsReq, safeImplicitImpsReq,
+ unsafeFlags,
-- ** System tool settings and locations
Settings(..),
@@ -1113,6 +1114,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
@@ -1349,10 +1363,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
@@ -1360,14 +1374,6 @@ safeFlagCheck cmdl dflags =
safeFailure loc str = [L loc $ "Warning: " ++ 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 2eb9e23501d82fe0049fa3bf2ce312781f41a66d..9658171d33fa45393c239607ce2b10ba3b3b85cf 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -7,6 +7,7 @@
module ErrUtils (
Message, mkLocMessage, printError, pprMessageBag, pprErrMsgBag,
+ pprErrMsgBagWithLoc,
Severity(..),
ErrMsg, WarnMsg,
@@ -153,6 +154,15 @@ pprErrMsgBag bag
errMsgExtraInfo = e,
errMsgContext = unqual } <- sortMsgBag bag ]
+pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
+pprErrMsgBagWithLoc bag
+ = [ let style = mkErrStyle unqual
+ in withPprStyle style (mkLocMessage s (d $$ e))
+ | ErrMsg { errMsgSpans = s:_,
+ errMsgShortDoc = d,
+ errMsgExtraInfo = e,
+ errMsgContext = unqual } <- sortMsgBag bag ]
+
printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
printMsgBag dflags bag sev
= sequence_ [ let style = mkErrStyle unqual
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index b2a7932ef37e38b6fc9c151241cb1f5d12ca438c..15a175fbcfa6504c76166e2f813051956968f3b8 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1029,13 +1029,16 @@ hscCheckSafe' dflags m l = do
(False, _ ) -> logWarnings modTrustErr >> return (trust == Sf_Trustworthy)
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
@@ -1092,18 +1095,28 @@ 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 [ text "Warning:" <+> quotes pprMod
+ wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
+ pprMod = ppr $ moduleName $ tcg_mod tcg_env
+ whyUnsafe' df = vcat [ text "Warning:" <+> quotes pprMod
<+> text "has been infered as unsafe!"
, text "Reason:"
- , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ]
+ , nest 4 $
+ (vcat $ badFlags df) $+$
+ (vcat $ pprErrMsgBagWithLoc whyUnsafe)
+ ]
+
+ badFlags df = concat $ map (badFlag df) unsafeFlags
+
+ badFlag df (str,loc,on,_)
+ | on df = [mkLocMessage (loc df) $
+ text str <+> text "is not allowed in Safe Haskell"]
+ | otherwise = []
--------------------------------------------------------------