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

3 files changed, 51 insertions, 22 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3b2e3400a8..0d474466df 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 2eb9e23501..9658171d33 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 b2a7932ef3..15a175fbcf 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 = []
 
 
 --------------------------------------------------------------