Make -w less aggressive (Trac #12056)

Previously -w combined with -Wunrecognised-warning-flags would not
report unrecognized flags.

Reviewers: austin, bgamari, dfeuer

Reviewed By: bgamari

Subscribers: dfeuer, rwbarton, thomie

GHC Trac Issues: #12056

Differential Revision: https://phabricator.haskell.org/D3581

compiler/main/CmdLineParser.hs

@@ -17,7 +17,10 @@ module CmdLineParser
       Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
       errorsToGhcException,
 
-      EwM, runEwM, addErr, addWarn, getArg, getCurLoc, liftEwM, deprecate
+      Err(..), Warn(..), WarnReason(..),
+
+      EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM,
+      deprecate
     ) where
 
 #include "HsVersions.h"
@@ -27,6 +30,7 @@ import Outputable
 import Panic
 import Bag
 import SrcLoc
+import Json
 
 import Data.Function
 import Data.List
@@ -81,8 +85,30 @@ data OptKind m                             -- Suppose the flag is -f
 --         The EwM monad
 --------------------------------------------------------
 
-type Err   = Located String
-type Warn  = Located String
+-- | Used when filtering warnings: if a reason is given
+-- it can be filtered out when displaying.
+data WarnReason
+  = NoReason
+  | ReasonDeprecatedFlag
+  | ReasonUnrecognisedFlag
+  deriving (Eq, Show)
+
+instance Outputable WarnReason where
+  ppr = text . show
+
+instance ToJson WarnReason where
+  json NoReason = JSNull
+  json reason   = JSString $ show reason
+
+-- | A command-line error message
+newtype Err  = Err { errMsg :: Located String }
+
+-- | A command-line warning message and the reason it arose
+data Warn = Warn
+  {   warnReason :: WarnReason,
+      warnMsg    :: Located String
+  }
+
 type Errs  = Bag Err
 type Warns = Bag Warn
 
@@ -110,15 +136,19 @@ setArg :: Located String -> EwM m () -> EwM m ()
 setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
 
 addErr :: Monad m => String -> EwM m ()
-addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ()))
+addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))
 
 addWarn :: Monad m => String -> EwM m ()
-addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc msg, ()))
+addWarn = addFlagWarn NoReason
+
+addFlagWarn :: Monad m => WarnReason -> String -> EwM m ()
+addFlagWarn reason msg = EwM $
+  (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ()))
 
 deprecate :: Monad m => String -> EwM m ()
 deprecate s = do
     arg <- getArg
-    addWarn (arg ++ " is deprecated: " ++ s)
+    addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s)
 
 getArg :: Monad m => EwM m String
 getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
@@ -164,8 +194,8 @@ processArgs :: Monad m
             => [Flag m]               -- cmdline parser spec
             -> [Located String]       -- args
             -> m ( [Located String],  -- spare args
-                   [Located String],  -- errors
-                   [Located String] ) -- warnings
+                   [Err],  -- errors
+                   [Warn] ) -- warnings
 processArgs spec args = do
     (errs, warns, spare) <- runEwM action
     return (spare, bagToList errs, bagToList warns)

compiler/main/DynFlags.hs

@@ -171,7 +171,8 @@ import {-# SOURCE #-} PrelNames ( mAIN )
 import {-# SOURCE #-} Packages (PackageState, emptyPackageState)
 import DriverPhases     ( Phase(..), phaseInputExt )
 import Config
-import CmdLineParser
+import CmdLineParser hiding (WarnReason(..))
+import qualified CmdLineParser as Cmd
 import Constants
 import Panic
 import qualified PprColour as Col
@@ -2347,7 +2348,7 @@ updOptLevel n dfs
 -- Throws a 'UsageError' if errors occurred during parsing (such as unknown
 -- flags or missing arguments).
 parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String]
-                         -> m (DynFlags, [Located String], [Located String])
+                         -> m (DynFlags, [Located String], [Warn])
                             -- ^ Updated 'DynFlags', left-over arguments, and
                             -- list of warnings.
 parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True
@@ -2357,7 +2358,7 @@ parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True
 -- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).
 -- Used to parse flags set in a modules pragma.
 parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String]
-                       -> m (DynFlags, [Located String], [Located String])
+                       -> m (DynFlags, [Located String], [Warn])
                           -- ^ Updated 'DynFlags', left-over arguments, and
                           -- list of warnings.
 parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False
@@ -2372,14 +2373,14 @@ parseDynamicFlagsFull :: MonadIO m
                   -> Bool                          -- ^ are the arguments from the command line?
                   -> DynFlags                      -- ^ current dynamic flags
                   -> [Located String]              -- ^ arguments to parse
-                  -> m (DynFlags, [Located String], [Located String])
+                  -> m (DynFlags, [Located String], [Warn])
 parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
   let ((leftover, errs, warns), dflags1)
           = runCmdLine (processArgs activeFlags args) dflags0
 
   -- See Note [Handling errors when parsing commandline flags]
-  unless (null errs) $ liftIO $ throwGhcExceptionIO $
-      errorsToGhcException . map (showPpr dflags0 . getLoc &&& unLoc) $ errs
+  unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $
+    map ((showPpr dflags0 . getLoc &&& unLoc) . errMsg) $ errs
 
   -- check for disabled flags in safe haskell
   let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
@@ -2426,7 +2427,9 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
 
   liftIO $ setUnsafeGlobalDynFlags dflags7
 
-  return (dflags7, leftover, consistency_warnings ++ sh_warns ++ warns)
+  let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns)
+
+  return (dflags7, leftover, warns' ++ warns)
 
 setLogAction :: DynFlags -> IO DynFlags
 setLogAction dflags = do
@@ -2592,8 +2595,8 @@ dynamic_flags_deps = [
   , make_ord_flag defFlag "F"        (NoArg (setGeneralFlag Opt_Pp))
   , (Deprecated, defFlag "#include"
       (HasArg (\_s ->
-         addWarn ("-#include and INCLUDE pragmas are " ++
-                  "deprecated: They no longer have any effect"))))
+         deprecate ("-#include and INCLUDE pragmas are " ++
+                    "deprecated: They no longer have any effect"))))
   , make_ord_flag defFlag "v"        (OptIntSuffix setVerbosity)
 
   , make_ord_flag defGhcFlag "j"     (OptIntSuffix
@@ -3265,11 +3268,11 @@ dynamic_flags_deps = [
 
   , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjTarget HscAsm))
   , make_ord_flag defGhcFlag "fvia-c"           (NoArg
-         (addWarn $ "The -fvia-c flag does nothing; " ++
-                    "it will be removed in a future GHC release"))
+         (deprecate $ "The -fvia-c flag does nothing; " ++
+                      "it will be removed in a future GHC release"))
   , make_ord_flag defGhcFlag "fvia-C"           (NoArg
-         (addWarn $ "The -fvia-C flag does nothing; " ++
-                    "it will be removed in a future GHC release"))
+         (deprecate $ "The -fvia-C flag does nothing; " ++
+                      "it will be removed in a future GHC release"))
   , make_ord_flag defGhcFlag "fllvm"            (NoArg (setObjTarget HscLlvm))
 
   , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->
@@ -3343,7 +3346,8 @@ unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action)
     action :: String -> EwM (CmdLineP DynFlags) ()
     action flag = do
       f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState
-      when f $ addWarn $ "unrecognised warning flag: -" ++ prefix ++ flag
+      when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $
+        "unrecognised warning flag: -" ++ prefix ++ flag
 
 -- See Note [Supporting CLI completion]
 package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]

compiler/main/GHC.hs

@@ -316,7 +316,8 @@ import TidyPgm
 import DriverPhases     ( Phase(..), isHaskellSrcFilename )
 import Finder
 import HscTypes
-import DynFlags
+import CmdLineParser
+import DynFlags hiding (WarnReason(..))
 import SysTools
 import Annotations
 import Module
@@ -654,7 +655,7 @@ getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
 
 parseDynamicFlags :: MonadIO m =>
                      DynFlags -> [Located String]
-                  -> m (DynFlags, [Located String], [Located String])
+                  -> m (DynFlags, [Located String], [Warn])
 parseDynamicFlags = parseDynamicFlagsCmdLine
 
 -- | Checks the set of new DynFlags for possibly erroneous option
@@ -664,7 +665,7 @@ checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
 checkNewDynFlags dflags = do
   -- See Note [DynFlags consistency]
   let (dflags', warnings) = makeDynFlagsConsistent dflags
-  liftIO $ handleFlagWarnings dflags warnings
+  liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)
   return dflags'
 
 checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags

compiler/main/HscTypes.hs

@@ -177,7 +177,8 @@ import PrelNames        ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule
                         , eqTyConName )
 import TysWiredIn
 import Packages hiding  ( Version(..) )
-import DynFlags
+import CmdLineParser
+import DynFlags hiding  ( WarnReason(..) )
 import DriverPhases     ( Phase, HscSource(..), isHsBootOrSig, hscSourceString )
 import BasicTypes
 import IfaceSyn
@@ -200,7 +201,7 @@ import UniqDSet
 import GHC.Serialized   ( Serialized )
 
 import Foreign
-import Control.Monad    ( guard, liftM, when, ap )
+import Control.Monad    ( guard, liftM, ap )
 import Data.Foldable    ( foldl' )
 import Data.IORef
 import Data.Time
@@ -325,15 +326,25 @@ printOrThrowWarnings dflags warns
   | otherwise
   = printBagOfErrors dflags warns
 
-handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
-handleFlagWarnings dflags warns
- = when (wopt Opt_WarnDeprecatedFlags dflags) $ do
-        -- It would be nicer if warns :: [Located MsgDoc], but that
-        -- has circular import problems.
-      let bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
-                          | L loc warn <- warns ]
-
-      printOrThrowWarnings dflags bag
+handleFlagWarnings :: DynFlags -> [Warn] -> IO ()
+handleFlagWarnings dflags warns = do
+  let warns' = filter (shouldPrintWarning dflags . warnReason)  warns
+
+      -- It would be nicer if warns :: [Located MsgDoc], but that
+      -- has circular import problems.
+      bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
+                      | Warn _ (L loc warn) <- warns' ]
+
+  printOrThrowWarnings dflags bag
+
+-- Given a warn reason, check to see if it's associated -W opt is enabled
+shouldPrintWarning :: DynFlags -> WarnReason -> Bool
+shouldPrintWarning dflags ReasonDeprecatedFlag
+  = wopt Opt_WarnDeprecatedFlags dflags
+shouldPrintWarning dflags ReasonUnrecognisedFlag
+  = wopt Opt_WarnUnrecognisedWarningFlags dflags
+shouldPrintWarning _ _
+  = True
 
 {-
 ************************************************************************

ghc/Main.hs

@@ -46,7 +46,7 @@ import HscTypes
 import Packages         ( pprPackages, pprPackagesSimple )
 import DriverPhases
 import BasicTypes       ( failed )
-import DynFlags
+import DynFlags hiding (WarnReason(..))
 import ErrUtils
 import FastString
 import Outputable
@@ -149,7 +149,7 @@ main = do
                 Right postLoadMode ->
                     main' postLoadMode dflags argv3 flagWarnings
 
-main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String]
+main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
       -> Ghc ()
 main' postLoadMode dflags0 args flagWarnings = do
   -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
@@ -543,7 +543,7 @@ isCompManagerMode _             = False
 parseModeFlags :: [Located String]
                -> IO (Mode,
                       [Located String],
-                      [Located String])
+                      [Warn])
 parseModeFlags args = do
   let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
           runCmdLine (processArgs mode_flags args)
@@ -554,7 +554,7 @@ parseModeFlags args = do
 
   -- See Note [Handling errors when parsing commandline flags]
   unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
-      map (("on the commandline", )) $ map unLoc errs1 ++ errs2
+      map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2
 
   return (mode, flags' ++ leftover, warns)
 

testsuite/tests/driver/T12056a.hs

+main :: IO ()
+main = putStrLn "hello world"

testsuite/tests/driver/T12056b.hs

+main :: IO ()
+main = putStrLn "hello world"

testsuite/tests/driver/T12056b.stderr

+
+on the commandline: warning: unrecognised warning flag: -Wbar

testsuite/tests/driver/T12056c.hs

+main :: IO ()
+main = putStrLn "hello world"

testsuite/tests/driver/T12056c.stderr

+
+on the commandline: warning:
+    -XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS
+
+on the commandline: warning: unrecognised warning flag: -Wbar

testsuite/tests/driver/all.T

@@ -252,6 +252,11 @@ test('T11763', normal, compile_and_run, ['-fno-version-macros'])
 
 test('T10320', [], run_command, ['$MAKE -s --no-print-directory T10320'])
 
+test('T12056a', normal, compile, ['-w -Wfoo -Wbar'])
+test('T12056b', normal, compile, ['-w -XOverlappingInstances -Wfoo -Wunrecognised-warning-flags -Wbar'])
+test('T12056c', normal, compile,
+     ['-w -Wdeprecated-flags -XOverlappingInstances -Wfoo -Wunrecognised-warning-flags -Wbar'])
+
 test('T12135', [expect_broken(12135)], run_command,
      ['$MAKE -s --no-print-directory T12135'])
 

testsuite/tests/safeHaskell/check/pkg01/Makefile

@@ -25,7 +25,7 @@ mkPackageDatabase.%:
 # we get a warning if dynlibs are enabled by default that:
 #     Warning: -rtsopts and -with-rtsopts have no effect with -shared.
 # so we filter the flag out
-	pdb.$*/setup configure -v0 --dist pdb.$*/dist --prefix='$(HERE)/pdb.$*/install' --with-compiler='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS)) -fpackage-trust -trust base -trust bytestring' --with-hc-pkg='$(GHC_PKG)' --package-db='pdb.$*/local.db' $(VANILLA) $(PROF) $(DYN)
+	pdb.$*/setup configure -v0 --dist pdb.$*/dist --prefix='$(HERE)/pdb.$*/install' --with-compiler='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS)) -trust base -trust bytestring' --with-hc-pkg='$(GHC_PKG)' --package-db='pdb.$*/local.db' $(VANILLA) $(PROF) $(DYN)
 	pdb.$*/setup build     -v0 --dist pdb.$*/dist
 	pdb.$*/setup copy      -v0 --dist pdb.$*/dist
 	pdb.$*/setup register  -v0 --dist pdb.$*/dist --inplace

utils/ghctags/Main.hs

@@ -12,6 +12,7 @@ import HscTypes         ( msHsFilePath )
 import Name             ( getOccString )
 --import ErrUtils         ( printBagOfErrors )
 import Panic            ( panic )
+import CmdLineParser    (warnMsg)
 import DynFlags         ( defaultFatalMessager, defaultFlushOut )
 import Bag
 import Exception
@@ -114,7 +115,7 @@ main = do
                                           (map noLoc ghcArgs)
       unless (null unrec) $
         liftIO $ putStrLn $ "Unrecognised options:\n" ++ show (map unLoc unrec)
-      liftIO $ mapM_ putStrLn (map unLoc warns)
+      liftIO $ mapM_ putStrLn (map (unLoc . warnMsg) warns)
       let dflags2 = pflags { hscTarget = HscNothing } -- don't generate anything
       -- liftIO $ print ("pkgDB", case (pkgDatabase dflags2) of Nothing -> 0
       --                                                        Just m -> sizeUFM m)