Allow flags to be marked as deprecated

compiler/ghci/InteractiveUI.hs

@@ -38,6 +38,7 @@ import Name
 import SrcLoc
 
 -- Other random utilities
+import ErrUtils
 import Digraph
 import BasicTypes hiding (isTopLevel)
 import Panic      hiding (showException)
@@ -1487,7 +1488,8 @@ newDynFlags :: [String] -> GHCi ()
 newDynFlags minus_opts = do
       dflags <- getDynFlags
       let pkg_flags = packageFlags dflags
-      (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
+      (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags minus_opts
+      io $ handleFlagWarnings dflags' warns
 
       if (not (null leftovers))
 		then throwDyn (CmdLineError ("unrecognised flags: " ++ 

compiler/main/CmdLineParser.hs

@@ -12,7 +12,7 @@
 module CmdLineParser (
         processArgs, OptKind(..),
         CmdLineP(..), getCmdLineState, putCmdLineState,
-        Flag(..),
+        Flag(..), Deprecated(..),
   ) where
 
 #include "HsVersions.h"
@@ -20,9 +20,14 @@ module CmdLineParser (
 import Util
 import Panic
 
-data Flag m = Flag { flagName :: String,        -- flag, without the leading -
-                     flagOptKind :: (OptKind m) -- What to do if we see it
-                   }
+data Flag m = Flag
+    {
+        flagName :: String,           -- flag, without the leading -
+        flagOptKind :: (OptKind m),   -- what to do if we see it
+        flagDeprecated :: Deprecated  -- is the flag deprecated?
+    }
+
+data Deprecated = Supported | Deprecated String
 
 data OptKind m                      -- Suppose the flag is -f
  = NoArg (m ())                     -- -f all by itself
@@ -42,23 +47,29 @@ processArgs :: Monad m
             -> [String]              -- args
             -> m (
                   [String],  -- spare args
-                  [String]   -- errors
+                  [String],  -- errors
+                  [String]   -- warnings
                  )
-processArgs spec args = process spec args [] []
+processArgs spec args = process spec args [] [] []
   where
-    process _spec [] spare errs =
-      return (reverse spare, reverse errs)
+    process _spec [] spare errs warns =
+      return (reverse spare, reverse errs, reverse warns)
 
-    process spec (dash_arg@('-':arg):args) spare errs =
+    process spec (dash_arg@('-' : arg) : args) spare errs warns =
       case findArg spec arg of
-        Just (rest,action) ->
-           case processOneArg action rest arg args of
-             Left err            -> process spec args spare (err:errs)
-             Right (action,rest) -> action >> process spec rest spare errs
-        Nothing -> process spec args (dash_arg:spare) errs
+        Just (rest, action, deprecated) ->
+           let warns' = case deprecated of
+                        Deprecated warning ->
+                            (dash_arg ++ " is deprecated: " ++ warning) : warns
+                        Supported -> warns
+           in case processOneArg action rest arg args of
+              Left err            -> process spec args spare (err:errs) warns'
+              Right (action,rest) -> do action
+                                        process spec rest spare errs warns'
+        Nothing -> process spec args (dash_arg : spare) errs warns
 
-    process spec (arg:args) spare errs =
-      process spec args (arg:spare) errs
+    process spec (arg : args) spare errs warns =
+      process spec args (arg : spare) errs warns
 
 
 processOneArg :: OptKind m -> String -> String -> [String]
@@ -99,9 +110,9 @@ processOneArg action rest arg args
         AnySuffixPred _ f -> Right (f dash_arg, args)
 
 
-findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
+findArg :: [Flag m] -> String -> Maybe (String, OptKind m, Deprecated)
 findArg spec arg
-  = case [ (removeSpaces rest, optKind)
+  = case [ (removeSpaces rest, optKind, flagDeprecated flag)
          | flag <- spec,
            let optKind = flagOptKind flag,
            Just rest <- [maybePrefixMatch (flagName flag) arg],

compiler/main/DriverMkDepend.hs

@@ -398,14 +398,20 @@ depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
 dep_opts :: [Flag IO]
 dep_opts =
    [ Flag "s"                 (SepArg (consIORef v_Dep_suffixes))
+          Supported
    , Flag "f"                 (SepArg (writeIORef v_Dep_makefile))
+          Supported
    , Flag "w"                 (NoArg (writeIORef v_Dep_warnings False))
+          Supported
 
    , Flag "-include-prelude"  (NoArg (writeIORef v_Dep_include_pkg_deps True))
-        -- -include-prelude is the old name for -include-pkg-deps, kept around
-        -- for backward compatibility, but undocumented
+          (Deprecated "Use --include-pkg-deps instead")
 
    , Flag "-include-pkg-deps" (NoArg (writeIORef v_Dep_include_pkg_deps True))
+          Supported
    , Flag "-exclude-module="  (Prefix (consIORef v_Dep_exclude_mods . mkModuleName))
+          Supported
    , Flag "x"                 (Prefix (consIORef v_Dep_exclude_mods . mkModuleName))
+          Supported
    ]
+

compiler/main/DriverPipeline.hs

@@ -614,7 +614,8 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
 runPhase (Cpp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
   = do let dflags0 = hsc_dflags hsc_env
        src_opts <- getOptionsFromFile dflags0 input_fn
-       (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts)
+       (dflags, unhandled_flags, warns) <- parseDynamicFlags dflags0 (map unLoc src_opts)
+       handleFlagWarnings dflags warns
        checkProcessArgsResult unhandled_flags (basename <.> suff)
 
        if not (dopt Opt_Cpp dflags) then

compiler/main/ErrUtils.lhs

@@ -13,6 +13,7 @@ module ErrUtils (
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
 	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+    handleFlagWarnings,
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
@@ -174,7 +175,16 @@ printBagOfWarnings dflags bag_of_warns
 		EQ -> True
 		GT -> False
 
-
+handleFlagWarnings :: DynFlags -> [String] -> IO ()
+handleFlagWarnings _ [] = return ()
+handleFlagWarnings dflags warns
+ = do -- It would be nicer if warns :: [Message], but that has circular
+      -- import problems.
+      let warns' = map text warns
+      mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns'
+      when (dopt Opt_WarnIsError dflags) $
+          do errorMsg dflags $ text "\nFailing due to -Werror.\n"
+             exitWith (ExitFailure 1)
 
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val

compiler/main/GHC.hs

@@ -255,10 +255,7 @@ import FiniteMap
 import Panic
 import Digraph
 import Bag		( unitBag, listToBag )
-import ErrUtils		( Severity(..), showPass, fatalErrorMsg, debugTraceMsg,
-			  mkPlainErrMsg, printBagOfErrors, printBagOfWarnings,
-			  WarnMsg )
-import qualified ErrUtils
+import ErrUtils
 import Util
 import StringBuffer	( StringBuffer, hGetStringBuffer )
 import Outputable
@@ -1938,8 +1935,9 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 	let 
 	    local_opts = getOptions dflags buf src_fn
 	--
-	(dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts)
+	(dflags', _errs, warns) <- parseDynamicFlags dflags (map unLoc local_opts)
         -- XXX: shouldn't we be reporting the errors?
+        handleFlagWarnings dflags' warns
 
 	let
 	    needs_preprocessing

compiler/main/Main.hs

@@ -37,7 +37,7 @@ import DriverPhases	( Phase(..), isSourceFilename, anyHsc,
 import StaticFlags
 import DynFlags
 import BasicTypes	( failed )
-import ErrUtils		( putMsg )
+import ErrUtils
 import FastString
 import Outputable
 import Util
@@ -78,10 +78,10 @@ main =
         mbMinusB | null minusB_args = Nothing
                  | otherwise = Just (drop 2 (last minusB_args))
 
-  argv2 <- parseStaticFlags argv1
+  (argv2, staticFlagWarnings) <- parseStaticFlags argv1
 
   -- 2. Parse the "mode" flags (--make, --interactive etc.)
-  (cli_mode, argv3) <- parseModeFlags argv2
+  (cli_mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
 
   -- If all we want to do is to show the version number then do it
   -- now, before we start a GHC session etc.
@@ -129,7 +129,12 @@ main =
 
 	-- The rest of the arguments are "dynamic"
 	-- Leftover ones are presumably files
-  (dflags, fileish_args) <- GHC.parseDynamicFlags dflags1 argv3
+  (dflags, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags dflags1 argv3
+
+  let flagWarnings = staticFlagWarnings
+                  ++ modeFlagWarnings
+                  ++ dynamicFlagWarnings
+  handleFlagWarnings dflags flagWarnings
 
 	-- make sure we clean up after ourselves
   GHC.defaultCleanupHandler dflags $ do
@@ -355,13 +360,13 @@ isCompManagerMode _             = False
 -- -----------------------------------------------------------------------------
 -- Parsing the mode flag
 
-parseModeFlags :: [String] -> IO (CmdLineMode, [String])
+parseModeFlags :: [String] -> IO (CmdLineMode, [String], [String])
 parseModeFlags args = do
-  let ((leftover, errs), (mode, _, flags)) = 
+  let ((leftover, errs, warns), (mode, _, flags)) = 
 	 runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", []) 
   when (not (null errs)) $ do
     throwDyn (UsageError (unlines errs))
-  return (mode, flags ++ leftover)
+  return (mode, flags ++ leftover, warns)
 
 type ModeM = CmdLineP (CmdLineMode, String, [String])
   -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
@@ -371,32 +376,49 @@ mode_flags :: [Flag ModeM]
 mode_flags =
   [  ------- help / version ----------------------------------------------
     Flag "?"                    (PassFlag (setMode ShowUsage))
+         Supported
   , Flag "-help"                (PassFlag (setMode ShowUsage))
+         Supported
   , Flag "-print-libdir"        (PassFlag (setMode PrintLibdir))
+         Supported
   , Flag "V"                    (PassFlag (setMode ShowVersion))
+         Supported
   , Flag "-version"             (PassFlag (setMode ShowVersion))
+         Supported
   , Flag "-numeric-version"     (PassFlag (setMode ShowNumVersion))
+         Supported
   , Flag "-info"                (PassFlag (setMode ShowInfo))
+         Supported
   , Flag "-supported-languages" (PassFlag (setMode ShowSupportedLanguages))
+         Supported
 
       ------- interfaces ----------------------------------------------------
   , Flag "-show-iface"  (HasArg (\f -> setMode (ShowInterface f)
                                                "--show-iface"))
+         Supported
 
       ------- primary modes ------------------------------------------------
   , Flag "M"            (PassFlag (setMode DoMkDependHS))
+         Supported
   , Flag "E"            (PassFlag (setMode (StopBefore anyHsc)))
+         Supported
   , Flag "C"            (PassFlag (\f -> do setMode (StopBefore HCc) f
                                             addFlag "-fvia-C"))
+         Supported
   , Flag "S"            (PassFlag (setMode (StopBefore As)))
+         Supported
   , Flag "-make"        (PassFlag (setMode DoMake))
+         Supported
   , Flag "-interactive" (PassFlag (setMode DoInteractive))
+         Supported
   , Flag "e"            (HasArg   (\s -> updateMode (updateDoEval s) "-e"))
+         Supported
 
        -- -fno-code says to stop after Hsc but don't generate any code.
   , Flag "fno-code"     (PassFlag (\f -> do setMode (StopBefore HCc) f
                                             addFlag "-fno-code"
                                             addFlag "-no-recomp"))
+         Supported
   ]
 
 setMode :: CmdLineMode -> String -> ModeM ()

compiler/main/StaticFlags.hs

@@ -93,12 +93,12 @@ import Data.List
 -----------------------------------------------------------------------------
 -- Static flags
 
-parseStaticFlags :: [String] -> IO [String]
+parseStaticFlags :: [String] -> IO ([String], [String])
 parseStaticFlags args = do
   ready <- readIORef v_opt_C_ready
   when ready $ throwDyn (ProgramError "Too late for parseStaticFlags: call it before newSession")
 
-  (leftover, errs) <- processArgs static_flags args
+  (leftover, errs, warns1) <- processArgs static_flags args
   when (not (null errs)) $ throwDyn (UsageError (unlines errs))
 
     -- deal with the way flags: the way (eg. prof) gives rise to
@@ -109,7 +109,7 @@ parseStaticFlags args = do
   let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
 		  | otherwise = []
 
-  (more_leftover, errs) <- processArgs static_flags (unreg_flags ++ way_flags)
+  (more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags)
 
     -- see sanity code in staticOpts
   writeIORef v_opt_C_ready True
@@ -128,7 +128,8 @@ parseStaticFlags args = do
                   | otherwise                = []
 
   when (not (null errs)) $ ghcError (UsageError (unlines errs))
-  return (excess_prec++cg_flags++more_leftover++leftover)
+  return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
+          warns1 ++ warns2)
 
 initStaticOpts :: IO ()
 initStaticOpts = writeIORef v_opt_C_ready True
@@ -149,54 +150,65 @@ static_flags :: [Flag IO]
 
 static_flags = [
         ------- GHCi -------------------------------------------------------
-    Flag "ignore-dot-ghci" (PassFlag addOpt)
-  , Flag "read-dot-ghci"   (NoArg (removeOpt "-ignore-dot-ghci"))
+    Flag "ignore-dot-ghci" (PassFlag addOpt) Supported
+  , Flag "read-dot-ghci"   (NoArg (removeOpt "-ignore-dot-ghci")) Supported
 
         ------- ways --------------------------------------------------------
-  , Flag "prof"           (NoArg (addWay WayProf))
-  , Flag "ticky"          (NoArg (addWay WayTicky))
-  , Flag "parallel"       (NoArg (addWay WayPar))
-  , Flag "gransim"        (NoArg (addWay WayGran))
-  , Flag "smp"            (NoArg (addWay WayThreaded)) -- backwards compat.
-  , Flag "debug"          (NoArg (addWay WayDebug))
-  , Flag "ndp"            (NoArg (addWay WayNDP))
-  , Flag "threaded"       (NoArg (addWay WayThreaded))
+  , Flag "prof"           (NoArg (addWay WayProf)) Supported
+  , Flag "ticky"          (NoArg (addWay WayTicky)) Supported
+  , Flag "parallel"       (NoArg (addWay WayPar)) Supported
+  , Flag "gransim"        (NoArg (addWay WayGran)) Supported
+  , Flag "smp"            (NoArg (addWay WayThreaded))
+         (Deprecated "Use -threaded instead")
+  , Flag "debug"          (NoArg (addWay WayDebug)) Supported
+  , Flag "ndp"            (NoArg (addWay WayNDP)) Supported
+  , Flag "threaded"       (NoArg (addWay WayThreaded)) Supported
         -- ToDo: user ways
 
         ------ Debugging ----------------------------------------------------
-  , Flag "dppr-debug"        (PassFlag addOpt)
-  , Flag "dsuppress-uniques" (PassFlag addOpt)
-  , Flag "dppr-user-length"  (AnySuffix addOpt)
-  , Flag "dopt-fuel"         (AnySuffix addOpt)
-  , Flag "dno-debug-output"  (PassFlag addOpt)
+  , Flag "dppr-debug"        (PassFlag addOpt) Supported
+  , Flag "dsuppress-uniques" (PassFlag addOpt) Supported
+  , Flag "dppr-user-length"  (AnySuffix addOpt) Supported
+  , Flag "dopt-fuel"         (AnySuffix addOpt) Supported
+  , Flag "dno-debug-output"  (PassFlag addOpt) Supported
       -- rest of the debugging flags are dynamic
 
         --------- Profiling --------------------------------------------------
   , Flag "auto-all"       (NoArg (addOpt "-fauto-sccs-on-all-toplevs"))
+         Supported
   , Flag "auto"           (NoArg (addOpt "-fauto-sccs-on-exported-toplevs"))
+         Supported
   , Flag "caf-all"        (NoArg (addOpt "-fauto-sccs-on-individual-cafs"))
+         Supported
          -- "ignore-sccs"  doesn't work  (ToDo)
 
   , Flag "no-auto-all"    (NoArg (removeOpt "-fauto-sccs-on-all-toplevs"))
+         Supported
   , Flag "no-auto"        (NoArg (removeOpt "-fauto-sccs-on-exported-toplevs"))
+         Supported
   , Flag "no-caf-all"     (NoArg (removeOpt "-fauto-sccs-on-individual-cafs"))
+         Supported
 
         ----- Linker --------------------------------------------------------
-  , Flag "static"         (PassFlag addOpt)
-  , Flag "dynamic"        (NoArg (removeOpt "-static"))
-  , Flag "rdynamic"       (NoArg (return ())) -- ignored for compat w/ gcc
+  , Flag "static"         (PassFlag addOpt) Supported
+  , Flag "dynamic"        (NoArg (removeOpt "-static")) Supported
+    -- ignored for compat w/ gcc:
+  , Flag "rdynamic"       (NoArg (return ())) Supported
 
         ----- RTS opts ------------------------------------------------------
   , Flag "H"              (HasArg (setHeapSize . fromIntegral . decodeSize))
-  , Flag "Rghc-timing"    (NoArg  (enableTimingStats))
+         Supported
+  , Flag "Rghc-timing"    (NoArg  (enableTimingStats)) Supported
 
         ------ Compiler flags -----------------------------------------------
         -- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
   , Flag "fno-"
          (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
+         Supported
 
         -- Pass all remaining "-f<blah>" options to hsc
   , Flag "f"                      (AnySuffixPred (isStaticFlag) addOpt)
+         Supported
   ]
 
 addOpt :: String -> IO ()