Commit 0079141c authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Use a proper datatype, rather than pairs, for flags

parent 95b68657
......@@ -11,7 +11,8 @@
module CmdLineParser (
processArgs, OptKind(..),
CmdLineP(..), getCmdLineState, putCmdLineState
CmdLineP(..), getCmdLineState, putCmdLineState,
Flag(..),
) where
#include "HsVersions.h"
......@@ -19,6 +20,10 @@ 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 OptKind m -- Suppose the flag is -f
= NoArg (m ()) -- -f all by itself
| HasArg (String -> m ()) -- -farg or -f arg
......@@ -33,7 +38,7 @@ data OptKind m -- Suppose the flag is -f
| AnySuffixPred (String -> Bool) (String -> m ())
processArgs :: Monad m
=> [(String, OptKind m)] -- cmdline parser spec
=> [Flag m] -- cmdline parser spec
-> [String] -- args
-> m (
[String], -- spare args
......@@ -94,12 +99,13 @@ processOneArg action rest arg args
AnySuffixPred _ f -> Right (f dash_arg, args)
findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a)
findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
findArg spec arg
= case [ (removeSpaces rest, k)
| (pat,k) <- spec,
Just rest <- [maybePrefixMatch pat arg],
arg_ok k rest arg ]
= case [ (removeSpaces rest, optKind)
| flag <- spec,
let optKind = flagOptKind flag,
Just rest <- [maybePrefixMatch (flagName flag) arg],
arg_ok optKind rest arg ]
of
[] -> Nothing
(one:_) -> Just one
......
......@@ -395,17 +395,17 @@ depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"
-- for compatibility with the old mkDependHS, we accept options of the form
-- -optdep-f -optdep.depend, etc.
dep_opts :: [(String, OptKind IO)]
dep_opts :: [Flag IO]
dep_opts =
[ ( "s", SepArg (consIORef v_Dep_suffixes) )
, ( "f", SepArg (writeIORef v_Dep_makefile) )
, ( "w", NoArg (writeIORef v_Dep_warnings False) )
[ Flag "s" (SepArg (consIORef v_Dep_suffixes))
, Flag "f" (SepArg (writeIORef v_Dep_makefile))
, Flag "w" (NoArg (writeIORef v_Dep_warnings False))
, ( "-include-prelude", NoArg (writeIORef v_Dep_include_pkg_deps True) )
, 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
, ( "-include-pkg-deps", NoArg (writeIORef v_Dep_include_pkg_deps True) )
, ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) )
, ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) )
, Flag "-include-pkg-deps" (NoArg (writeIORef v_Dep_include_pkg_deps True))
, Flag "-exclude-module=" (Prefix (consIORef v_Dep_exclude_mods . mkModuleName))
, Flag "x" (Prefix (consIORef v_Dep_exclude_mods . mkModuleName))
]
This diff is collapsed.
......@@ -367,36 +367,36 @@ type ModeM a = CmdLineP (CmdLineMode, String, [String]) a
-- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
-- so we collect the new ones and return them.
mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))]
mode_flags :: [Flag (CmdLineP (CmdLineMode, String, [String]))]
mode_flags =
[ ------- help / version ----------------------------------------------
( "?" , PassFlag (setMode ShowUsage))
, ( "-help" , PassFlag (setMode ShowUsage))
, ( "-print-libdir" , PassFlag (setMode PrintLibdir))
, ( "V" , PassFlag (setMode ShowVersion))
, ( "-version" , PassFlag (setMode ShowVersion))
, ( "-numeric-version" , PassFlag (setMode ShowNumVersion))
, ( "-info" , PassFlag (setMode ShowInfo))
, ( "-supported-languages", PassFlag (setMode ShowSupportedLanguages))
Flag "?" (PassFlag (setMode ShowUsage))
, Flag "-help" (PassFlag (setMode ShowUsage))
, Flag "-print-libdir" (PassFlag (setMode PrintLibdir))
, Flag "V" (PassFlag (setMode ShowVersion))
, Flag "-version" (PassFlag (setMode ShowVersion))
, Flag "-numeric-version" (PassFlag (setMode ShowNumVersion))
, Flag "-info" (PassFlag (setMode ShowInfo))
, Flag "-supported-languages" (PassFlag (setMode ShowSupportedLanguages))
------- interfaces ----------------------------------------------------
, ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f)
"--show-iface"))
, Flag "-show-iface" (HasArg (\f -> setMode (ShowInterface f)
"--show-iface"))
------- primary modes ------------------------------------------------
, ( "M" , PassFlag (setMode DoMkDependHS))
, ( "E" , PassFlag (setMode (StopBefore anyHsc)))
, ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f
addFlag "-fvia-C"))
, ( "S" , PassFlag (setMode (StopBefore As)))
, ( "-make" , PassFlag (setMode DoMake))
, ( "-interactive" , PassFlag (setMode DoInteractive))
, ( "e" , HasArg (\s -> updateMode (updateDoEval s) "-e"))
, Flag "M" (PassFlag (setMode DoMkDependHS))
, Flag "E" (PassFlag (setMode (StopBefore anyHsc)))
, Flag "C" (PassFlag (\f -> do setMode (StopBefore HCc) f
addFlag "-fvia-C"))
, Flag "S" (PassFlag (setMode (StopBefore As)))
, Flag "-make" (PassFlag (setMode DoMake))
, Flag "-interactive" (PassFlag (setMode DoInteractive))
, Flag "e" (HasArg (\s -> updateMode (updateDoEval s) "-e"))
-- -fno-code says to stop after Hsc but don't generate any code.
, ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f
addFlag "-fno-code"
addFlag "-no-recomp"))
, Flag "fno-code" (PassFlag (\f -> do setMode (StopBefore HCc) f
addFlag "-fno-code"
addFlag "-no-recomp"))
]
setMode :: CmdLineMode -> String -> ModeM ()
......
......@@ -133,7 +133,7 @@ parseStaticFlags args = do
initStaticOpts :: IO ()
initStaticOpts = writeIORef v_opt_C_ready True
static_flags :: [(String, OptKind IO)]
static_flags :: [Flag IO]
-- All the static flags should appear in this list. It describes how each
-- static flag should be processed. Two main purposes:
-- (a) if a command-line flag doesn't appear in the list, GHC can complain
......@@ -148,55 +148,55 @@ static_flags :: [(String, OptKind IO)]
-- flags further down the list with the same prefix.
static_flags = [
------- GHCi -------------------------------------------------------
( "ignore-dot-ghci", PassFlag addOpt )
, ( "read-dot-ghci" , NoArg (removeOpt "-ignore-dot-ghci") )
------- ways --------------------------------------------------------
, ( "prof" , NoArg (addWay WayProf) )
, ( "ticky" , NoArg (addWay WayTicky) )
, ( "parallel" , NoArg (addWay WayPar) )
, ( "gransim" , NoArg (addWay WayGran) )
, ( "smp" , NoArg (addWay WayThreaded) ) -- backwards compat.
, ( "debug" , NoArg (addWay WayDebug) )
, ( "ndp" , NoArg (addWay WayNDP) )
, ( "threaded" , NoArg (addWay WayThreaded) )
-- ToDo: user ways
------ Debugging ----------------------------------------------------
, ( "dppr-debug", PassFlag addOpt )
, ( "dsuppress-uniques", PassFlag addOpt )
, ( "dppr-user-length", AnySuffix addOpt )
, ( "dopt-fuel", AnySuffix addOpt )
, ( "dno-debug-output", PassFlag addOpt )
------- GHCi -------------------------------------------------------
Flag "ignore-dot-ghci" (PassFlag addOpt)
, Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci"))
------- 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))
-- 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)
-- rest of the debugging flags are dynamic
--------- Profiling --------------------------------------------------
, ( "auto-all" , NoArg (addOpt "-fauto-sccs-on-all-toplevs") )
, ( "auto" , NoArg (addOpt "-fauto-sccs-on-exported-toplevs") )
, ( "caf-all" , NoArg (addOpt "-fauto-sccs-on-individual-cafs") )
--------- Profiling --------------------------------------------------
, Flag "auto-all" (NoArg (addOpt "-fauto-sccs-on-all-toplevs"))
, Flag "auto" (NoArg (addOpt "-fauto-sccs-on-exported-toplevs"))
, Flag "caf-all" (NoArg (addOpt "-fauto-sccs-on-individual-cafs"))
-- "ignore-sccs" doesn't work (ToDo)
, ( "no-auto-all" , NoArg (removeOpt "-fauto-sccs-on-all-toplevs") )
, ( "no-auto" , NoArg (removeOpt "-fauto-sccs-on-exported-toplevs") )
, ( "no-caf-all" , NoArg (removeOpt "-fauto-sccs-on-individual-cafs") )
, Flag "no-auto-all" (NoArg (removeOpt "-fauto-sccs-on-all-toplevs"))
, Flag "no-auto" (NoArg (removeOpt "-fauto-sccs-on-exported-toplevs"))
, Flag "no-caf-all" (NoArg (removeOpt "-fauto-sccs-on-individual-cafs"))
----- Linker --------------------------------------------------------
, ( "static" , PassFlag addOpt )
, ( "dynamic" , NoArg (removeOpt "-static") )
, ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc
----- Linker --------------------------------------------------------
, Flag "static" (PassFlag addOpt)
, Flag "dynamic" (NoArg (removeOpt "-static"))
, Flag "rdynamic" (NoArg (return ())) -- ignored for compat w/ gcc
----- RTS opts ------------------------------------------------------
, ( "H" , HasArg (setHeapSize . fromIntegral . decodeSize) )
, ( "Rghc-timing" , NoArg (enableTimingStats) )
----- RTS opts ------------------------------------------------------
, Flag "H" (HasArg (setHeapSize . fromIntegral . decodeSize))
, Flag "Rghc-timing" (NoArg (enableTimingStats))
------ Compiler flags -----------------------------------------------
-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
, ( "fno-", PrefixPred (\s -> isStaticFlag ("f"++s))
(\s -> removeOpt ("-f"++s)) )
-- All other "-fno-<blah>" options cancel out "-f<blah>" on the hsc cmdline
, Flag "fno-"
(PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s)))
-- Pass all remaining "-f<blah>" options to hsc
, ( "f", AnySuffixPred (isStaticFlag) addOpt )
-- Pass all remaining "-f<blah>" options to hsc
, Flag "f" (AnySuffixPred (isStaticFlag) addOpt)
]
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