summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/CmdLineParser.hs46
-rw-r--r--compiler/main/DynFlags.hs32
-rw-r--r--compiler/main/GHC.hs7
-rw-r--r--compiler/main/HscTypes.hs33
-rw-r--r--ghc/Main.hs8
-rw-r--r--testsuite/tests/driver/T12056a.hs2
-rw-r--r--testsuite/tests/driver/T12056a.stderr0
-rw-r--r--testsuite/tests/driver/T12056b.hs2
-rw-r--r--testsuite/tests/driver/T12056b.stderr2
-rw-r--r--testsuite/tests/driver/T12056c.hs2
-rw-r--r--testsuite/tests/driver/T12056c.stderr5
-rw-r--r--testsuite/tests/driver/all.T5
-rw-r--r--testsuite/tests/safeHaskell/check/pkg01/Makefile2
-rw-r--r--utils/ghctags/Main.hs3
14 files changed, 107 insertions, 42 deletions
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 6d6edcadf9..e6ecd17bdf 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/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)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 8a4f1c3e1d..366406e989 100644
--- a/compiler/main/DynFlags.hs
+++ b/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))]
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index ce779ca5fc..d58f3e9299 100644
--- a/compiler/main/GHC.hs
+++ b/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
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index c9e4f89158..369a19082a 100644
--- a/compiler/main/HscTypes.hs
+++ b/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
{-
************************************************************************
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 0a4e17aa7d..a75aba3e97 100644
--- a/ghc/Main.hs
+++ b/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)
diff --git a/testsuite/tests/driver/T12056a.hs b/testsuite/tests/driver/T12056a.hs
new file mode 100644
index 0000000000..c81fb82437
--- /dev/null
+++ b/testsuite/tests/driver/T12056a.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "hello world"
diff --git a/testsuite/tests/driver/T12056a.stderr b/testsuite/tests/driver/T12056a.stderr
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testsuite/tests/driver/T12056a.stderr
diff --git a/testsuite/tests/driver/T12056b.hs b/testsuite/tests/driver/T12056b.hs
new file mode 100644
index 0000000000..c81fb82437
--- /dev/null
+++ b/testsuite/tests/driver/T12056b.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "hello world"
diff --git a/testsuite/tests/driver/T12056b.stderr b/testsuite/tests/driver/T12056b.stderr
new file mode 100644
index 0000000000..e1e870a828
--- /dev/null
+++ b/testsuite/tests/driver/T12056b.stderr
@@ -0,0 +1,2 @@
+
+on the commandline: warning: unrecognised warning flag: -Wbar
diff --git a/testsuite/tests/driver/T12056c.hs b/testsuite/tests/driver/T12056c.hs
new file mode 100644
index 0000000000..c81fb82437
--- /dev/null
+++ b/testsuite/tests/driver/T12056c.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "hello world"
diff --git a/testsuite/tests/driver/T12056c.stderr b/testsuite/tests/driver/T12056c.stderr
new file mode 100644
index 0000000000..0f96367dc2
--- /dev/null
+++ b/testsuite/tests/driver/T12056c.stderr
@@ -0,0 +1,5 @@
+
+on the commandline: warning:
+ -XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS
+
+on the commandline: warning: unrecognised warning flag: -Wbar
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index ddea9ccda8..19dcc0a950 100644
--- a/testsuite/tests/driver/all.T
+++ b/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'])
diff --git a/testsuite/tests/safeHaskell/check/pkg01/Makefile b/testsuite/tests/safeHaskell/check/pkg01/Makefile
index 5d4fd73266..1c9d8eb596 100644
--- a/testsuite/tests/safeHaskell/check/pkg01/Makefile
+++ b/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
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index 269e040d36..4842a0cbfb 100644
--- a/utils/ghctags/Main.hs
+++ b/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)
View Lorry Controller Status