Review, part 3wip/adinapoli-suppress-warning-design-b

5 files changed, 31 insertions, 24 deletions

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index fd5548934b..afd81533ae 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -284,7 +284,9 @@ clearWarnings :: Hsc ()
 clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
 
 logDiagnostics :: Bag (MsgEnvelope DiagnosticMessage) -> Hsc ()
-logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
+logDiagnostics w
+  | isEmptyBag w = pure ()
+  | otherwise    = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
 
 getHscEnv :: Hsc HscEnv
 getHscEnv = Hsc $ \e w -> return (e, w)
@@ -1338,7 +1340,7 @@ hscCheckSafe' m l = do
 
                 where
                     state = hsc_units hsc_env
-                    inferredImportWarn dflags = catBagMaybes $ unitBag
+                    inferredImportWarn dflags = maybeToBag
                         $ mkShortMsgEnvelope dflags (WarningWithFlag Opt_WarnInferredSafeImports)
                                              l (pkgQual state)
                         $ sep
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index fe269e0f85..a069fd186d 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -69,10 +69,10 @@ import GHC.Iface.Load      ( cannotFindModule )
 import GHC.IfaceToCore     ( typecheckIface )
 import GHC.Iface.Recomp    ( RecompileRequired ( MustCompile ) )
 
-import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag )
+import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag, maybeToBag )
 import GHC.Data.Graph.Directed
 import GHC.Data.FastString
-import GHC.Data.Maybe      (whenIsJust,  expectJust )
+import GHC.Data.Maybe      ( expectJust )
 import GHC.Data.StringBuffer
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -270,7 +270,7 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check
 warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
 warnMissingHomeModules hsc_env mod_graph =
     when (not (null missing)) $
-        whenIsJust warn $ logWarnings . unitBag
+        logWarnings warn
   where
     dflags = hsc_dflags hsc_env
     targets = map targetId (hsc_targets hsc_env)
@@ -317,8 +317,8 @@ warnMissingHomeModules hsc_env mod_graph =
           (text "Modules are not listed in command line but needed for compilation: ")
           4
           (sep (map ppr missing))
-    warn =
-      mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg
+    warn = maybeToBag
+         $ mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg
 
 -- | Describes which modules of the module graph need to be loaded.
 data LoadHowMuch
@@ -383,15 +383,15 @@ warnUnusedPackages = do
           = filter (\arg -> not $ any (matching state arg) loadedPackages)
                    requestedArgs
 
-    let warn =
-          mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg
+    let warn = maybeToBag
+             $ mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg
         msg = vcat [ text "The following packages were specified" <+>
                      text "via -package or -package-id flags,"
                    , text "but were not needed for compilation:"
                    , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ]
 
     when (not (null unusedArgs)) $
-      whenIsJust warn $ logWarnings . unitBag
+      logWarnings warn
 
     where
         packageArg (ExposePackage _ arg _) = Just arg
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 1a42d8402f..587d594dba 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -33,6 +33,7 @@ module GHC.Driver.Monad (
   ) where
 
 import GHC.Prelude
+import GHC.Data.Bag ( isEmptyBag )
 
 import GHC.Driver.Session
 import GHC.Driver.Env
@@ -144,10 +145,12 @@ withTimingM doc force action = do
 -- | A monad that allows logging of warnings.
 
 logWarnings :: GhcMonad m => WarningMessages -> m ()
-logWarnings warns = do
-  dflags <- getSessionDynFlags
-  logger <- getLogger
-  liftIO $ printOrThrowDiagnostics logger dflags warns
+logWarnings warns
+  | isEmptyBag warns = pure ()
+  | otherwise = do
+      dflags <- getSessionDynFlags
+      logger <- getLogger
+      liftIO $ printOrThrowDiagnostics logger dflags warns
 
 -- -----------------------------------------------------------------------------
 -- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index fbdcc15730..07cc79fd17 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -1648,7 +1648,8 @@ dataKindsErr env thing
 warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
                  => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
 warnUnusedForAll doc (L loc tv) used_names
-  = unless (hsTyVarName tv `elemNameSet` used_names) $
+  = whenWOptM Opt_WarnUnusedForalls $
+    unless (hsTyVarName tv `elemNameSet` used_names) $
     addDiagnosticAt (WarningWithFlag Opt_WarnUnusedForalls) (locA loc) $
     vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
          , inHsDocContext doc ]
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index d5a787f9ab..b5c91c8cc3 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -1945,15 +1945,16 @@ warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
                  -> RnM ()
 warnNoDerivStrat mds loc
   = do { dyn_flags <- getDynFlags
-       ; case mds of
-           Nothing -> addDiagnosticAt
-             (WarningWithFlag Opt_WarnMissingDerivingStrategies)
-             loc
-             (if xopt LangExt.DerivingStrategies dyn_flags
-               then no_strat_warning
-               else no_strat_warning $+$ deriv_strat_nenabled
-             )
-           _ -> pure ()
+       ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $
+           case mds of
+             Nothing -> addDiagnosticAt
+               (WarningWithFlag Opt_WarnMissingDerivingStrategies)
+               loc
+               (if xopt LangExt.DerivingStrategies dyn_flags
+                 then no_strat_warning
+                 else no_strat_warning $+$ deriv_strat_nenabled
+               )
+             _ -> pure ()
        }
   where
     no_strat_warning :: SDoc