Commit a7f88c2f authored by Ian Lynagh's avatar Ian Lynagh

Allow flags to be marked as deprecated

parent f586a36d
......@@ -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: " ++
......
......@@ -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],
......
......@@ -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
]
......@@ -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
......
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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 ()
......
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