Add Safe Haskell '-fwarn-safe', '-fwarn-unsafe', '-fno-safe-infer' flags

compiler/iface/MkIface.lhs

@@ -262,7 +262,7 @@ mkIface_ hsc_env maybe_old_fingerprint
                 ; iface_vect_info = flattenVectInfo vect_info
                 -- Check if we are in Safe Inference mode but we failed to pass
                 -- the muster
-                ; safeMode    = if safeInferOn dflags  && not safeInf
+                ; safeMode    = if safeInferOn dflags && not safeInf
                                     then Sf_None
                                     else safeHaskell dflags
                 ; trust_info  = setSafeMode safeMode

compiler/main/DynFlags.hs

@@ -338,6 +338,8 @@ data WarningFlag =
    | Opt_WarnUnusedDoBind
    | Opt_WarnWrongDoBind
    | Opt_WarnAlternativeLayoutRuleTransitional
+   | Opt_WarnUnsafe
+   | Opt_WarnSafe
    deriving (Eq, Show)
 
 data Language = Haskell98 | Haskell2010
@@ -560,6 +562,8 @@ data DynFlags = DynFlags {
   -- them off.
   thOnLoc               :: SrcSpan,
   newDerivOnLoc         :: SrcSpan,
+  warnSafeOnLoc         :: SrcSpan,
+  warnUnsafeOnLoc       :: SrcSpan,
   -- Don't change this without updating extensionFlags:
   extensions            :: [OnOff ExtensionFlag],
   -- extensionFlags should always be equal to
@@ -894,6 +898,8 @@ defaultDynFlags mySettings =
         safeHaskell = Sf_SafeInfered,
         thOnLoc = noSrcSpan,
         newDerivOnLoc = noSrcSpan,
+        warnSafeOnLoc = noSrcSpan,
+        warnUnsafeOnLoc = noSrcSpan,
         extensions = [],
         extensionFlags = flattenExtensionFlags Nothing [],
         log_action = defaultLogAction,
@@ -1076,10 +1082,12 @@ safeImplicitImpsReq d = safeLanguageOn d
 -- want to export this functionality from the module but do want to export the
 -- type constructors.
 combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode
-combineSafeFlags a b | a `elem` [Sf_None, Sf_SafeInfered] = return b
-                     | b `elem` [Sf_None, Sf_SafeInfered] = return a
-                     | a == b                             = return a
-                     | otherwise = addErr errm >> return (panic errm)
+combineSafeFlags a b | a == Sf_SafeInfered = return b
+                     | b == Sf_SafeInfered = return a
+                     | a == Sf_None        = return b
+                     | b == Sf_None        = return a
+                     | a == b              = return a
+                     | otherwise           = addErr errm >> return (panic errm)
     where errm = "Incompatible Safe Haskell flags! ("
                     ++ showPpr a ++ ", " ++ showPpr b ++ ")"
 
@@ -1638,6 +1646,7 @@ dynamic_flags = [
 
         ------ Safe Haskell flags -------------------------------------------
   , Flag "fpackage-trust"   (NoArg (setDynFlag Opt_PackageTrust))
+  , Flag "fno-safe-infer"   (NoArg (setSafeHaskell Sf_None))
  ]
  ++ map (mkFlag turnOn  "f"    setDynFlag  ) fFlags
  ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags
@@ -1737,10 +1746,12 @@ fWarningFlags = [
   ( "warn-auto-orphans",                Opt_WarnAutoOrphans, nop ),
   ( "warn-tabs",                        Opt_WarnTabs, nop ),
   ( "warn-unrecognised-pragmas",        Opt_WarnUnrecognisedPragmas, nop ),
-  ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings, nop),
+  ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings, nop ),
   ( "warn-unused-do-bind",              Opt_WarnUnusedDoBind, nop ),
   ( "warn-wrong-do-bind",               Opt_WarnWrongDoBind, nop ),
-  ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop )]
+  ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ),
+  ( "warn-unsafe",                      Opt_WarnUnsafe, setWarnUnsafe ),
+  ( "warn-safe",                        Opt_WarnSafe, setWarnSafe ) ]
 
 -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
 fFlags :: [FlagSpec DynFlag]
@@ -2137,6 +2148,14 @@ rtsIsProfiled :: Bool
 rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0
 #endif
 
+setWarnSafe :: Bool -> DynP ()
+setWarnSafe True  = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l })
+setWarnSafe False = return ()
+
+setWarnUnsafe :: Bool -> DynP ()
+setWarnUnsafe True  = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })
+setWarnUnsafe False = return ()
+
 setGenDeriving :: Bool -> DynP ()
 setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })
 setGenDeriving False = return ()

compiler/main/ErrUtils.lhs

@@ -12,7 +12,7 @@
 -- for details
 
 module ErrUtils (
-	Message, mkLocMessage, printError, pprMessageBag,
+	Message, mkLocMessage, printError, pprMessageBag, pprErrMsgBag,
 	Severity(..),
 
 	ErrMsg, WarnMsg,
@@ -149,23 +149,31 @@ printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
 printBagOfWarnings dflags bag_of_warns = 
   printMsgBag dflags bag_of_warns SevWarning
 
+pprErrMsgBag :: Bag ErrMsg -> [SDoc]
+pprErrMsgBag bag
+  = [ let style = mkErrStyle unqual
+      in withPprStyle style (d $$ e)
+    | ErrMsg { errMsgShortDoc  = d,
+               errMsgExtraInfo = e,
+               errMsgContext   = unqual } <- sortMsgBag bag ]
+
 printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
 printMsgBag dflags bag sev
-  = sequence_   [ let style = mkErrStyle unqual
-		  in log_action dflags sev s style (d $$ e)
-		| ErrMsg { errMsgSpans = s:_,
-			   errMsgShortDoc = d,
-			   errMsgExtraInfo = e,
-			   errMsgContext = unqual } <- sorted_errs ]
-    where
-      bag_ls	  = bagToList bag
-      sorted_errs = sortLe occ'ed_before bag_ls
-
-      occ'ed_before err1 err2 = 
-         case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
-		LT -> True
-		EQ -> True
-		GT -> False
+  = sequence_ [ let style = mkErrStyle unqual
+                in log_action dflags sev s style (d $$ e)
+              | ErrMsg { errMsgSpans     = s:_,
+                         errMsgShortDoc  = d,
+                         errMsgExtraInfo = e,
+                         errMsgContext   = unqual } <- sortMsgBag bag ]
+
+sortMsgBag :: Bag ErrMsg -> [ErrMsg]
+sortMsgBag bag = sortLe srcOrder $ bagToList bag
+  where
+    srcOrder err1 err2 = 
+        case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
+            LT -> True
+            EQ -> True
+            GT -> False
 
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val

compiler/main/HscMain.hs

@@ -167,7 +167,7 @@ newHscEnv dflags = do
     mlc_var <- newIORef emptyModuleEnv
     optFuel <- initOptFuelState
     safe_var <- newIORef True
-    return HscEnv { hsc_dflags       = dflags,
+    return HscEnv {  hsc_dflags       = dflags,
                      hsc_targets      = [],
                      hsc_mod_graph    = [],
                      hsc_IC           = emptyInteractiveContext,
@@ -790,10 +790,25 @@ hscFileFrontEnd mod_summary = do
         ioMsgMaybe $
             tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
     tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env)
-    -- if safe haskell off or safe infer failed, wipe trust
+
+    -- end of the Safe Haskell line, how to respond to user?
     if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK)
-        then wipeTrust tcg_env
-        else hscCheckSafeImports tcg_env
+
+        -- if safe haskell off or safe infer failed, wipe trust
+        then wipeTrust tcg_env emptyBag
+
+        -- module safe, throw warning if needed
+        else do
+            tcg_env' <- hscCheckSafeImports tcg_env
+            safe <- liftIO $ hscGetSafeInf hsc_env
+            when (safe && wopt Opt_WarnSafe dflags)
+                 (logWarnings $ unitBag $
+                     mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_env')
+            return tcg_env'
+  where
+    pprMod t  = ppr $ moduleName $ tcg_mod t
+    errSafe t = text "Warning:" <+> quotes (pprMod t)
+                   <+> text "has been infered as safe!"
 
 --------------------------------------------------------------
 -- Safe Haskell
@@ -850,9 +865,9 @@ hscCheckSafeImports tcg_env = do
               -- user defined RULES, so not safe or already unsafe
             | safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
               safeHaskell dflags == Sf_None
-            -> wipeTrust tcg_env'
+            -> wipeTrust tcg_env' $ warns (tcg_rules tcg_env')
 
-              -- trustworthy
+              -- trustworthy OR safe infered with no RULES
             | otherwise
             -> return tcg_env'
 
@@ -900,7 +915,7 @@ checkSafeImports dflags hsc_env tcg_env
             True ->
                 -- did we fail safe inference or fail -XSafe?
                 case safeInferOn dflags of
-                    True  -> wipeTrust tcg_env
+                    True  -> wipeTrust tcg_env errs
                     False -> liftIO . throwIO . mkSrcErr $ errs
             
             -- All good matey!
@@ -1025,12 +1040,29 @@ checkSafeImports dflags hsc_env tcg_env
                            | otherwise   = Just (modulePackageId m)
 
 -- | Set module to unsafe and wipe trust information.
-wipeTrust :: TcGblEnv -> Hsc TcGblEnv
-wipeTrust tcg_env = do
-    env <- getHscEnv
+--
+-- Make sure to call this method to set a module to infered unsafe,
+-- it should be a central and single failure method.
+wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
+wipeTrust tcg_env whyUnsafe = do
+    env    <- getHscEnv
+    dflags <- getDynFlags
+
+    when (wopt Opt_WarnUnsafe dflags)
+         (logWarnings $ unitBag $
+             mkPlainWarnMsg (warnUnsafeOnLoc dflags) whyUnsafe')
+
     liftIO $ hscSetSafeInf env False
-    let imps = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
-    return $ tcg_env { tcg_imports = imps }
+    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
+                             <+> text "has been infered as unsafe!"
+                       , text "Reason:"
+                       , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ]
+
 
 --------------------------------------------------------------
 -- Simplifiers