Commit af9612bf authored by sgillespie's avatar sgillespie Committed by Ben Gamari

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
parent 2088d0be
......@@ -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)
......
......@@ -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))]
......
......@@ -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
......
......@@ -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
{-
************************************************************************
......
......@@ -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)
......
main :: IO ()
main = putStrLn "hello world"
main :: IO ()
main = putStrLn "hello world"
on the commandline: warning: unrecognised warning flag: -Wbar
main :: IO ()
main = putStrLn "hello world"
on the commandline: warning:
-XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS
on the commandline: warning: unrecognised warning flag: -Wbar
......@@ -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'])
......
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment