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

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

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

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 = []
 
 
 --------------------------------------------------------------