summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIan Lynagh <igloo@earth.li>2008-06-14 13:38:48 +0000
committerIan Lynagh <igloo@earth.li>2008-06-14 13:38:48 +0000
commit0079141c61f673039ccd879cd75174b33eb40b8f (patch)
treec2a5acb06ae12ac98d05ce2291fc9cb0815b1c2e
parent95b686571a3dc625b6e331417be24747c8552132 (diff)
downloadhaskell-0079141c61f673039ccd879cd75174b33eb40b8f.tar.gz
Use a proper datatype, rather than pairs, for flags
-rw-r--r--compiler/main/CmdLineParser.hs20
-rw-r--r--compiler/main/DriverMkDepend.hs16
-rw-r--r--compiler/main/DynFlags.hs384
-rw-r--r--compiler/main/Main.hs44
-rw-r--r--compiler/main/StaticFlags.hs82
5 files changed, 279 insertions, 267 deletions
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 8ec2f6a3ef..710faf6a8a 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -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
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 052c138b26..a0ce1148ab 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -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))
]
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 2d24aac143..a0519165ff 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1008,7 +1008,7 @@ getStgToDo dflags
allFlags :: [String]
allFlags = map ('-':) $
- [ name | (name, optkind) <- dynamic_flags, ok optkind ] ++
+ [ flagName flag | flag <- dynamic_flags, ok (flagOptKind flag) ] ++
map ("fno-"++) flags ++
map ("f"++) flags ++
map ("X"++) xs ++
@@ -1018,240 +1018,246 @@ allFlags = map ('-':) $
flags = map fst fFlags
xs = map fst xFlags
-dynamic_flags :: [(String, OptKind DynP)]
+dynamic_flags :: [Flag DynP]
dynamic_flags = [
- ( "n" , NoArg (setDynFlag Opt_DryRun) )
- , ( "cpp" , NoArg (setDynFlag Opt_Cpp))
- , ( "F" , NoArg (setDynFlag Opt_Pp))
- , ( "#include" , HasArg (addCmdlineHCInclude) )
- , ( "v" , OptIntSuffix setVerbosity )
+ Flag "n" (NoArg (setDynFlag Opt_DryRun))
+ , Flag "cpp" (NoArg (setDynFlag Opt_Cpp))
+ , Flag "F" (NoArg (setDynFlag Opt_Pp))
+ , Flag "#include" (HasArg (addCmdlineHCInclude))
+ , Flag "v" (OptIntSuffix setVerbosity)
------- Specific phases --------------------------------------------
- , ( "pgmL" , HasArg (upd . setPgmL) )
- , ( "pgmP" , HasArg (upd . setPgmP) )
- , ( "pgmF" , HasArg (upd . setPgmF) )
- , ( "pgmc" , HasArg (upd . setPgmc) )
- , ( "pgmm" , HasArg (upd . setPgmm) )
- , ( "pgms" , HasArg (upd . setPgms) )
- , ( "pgma" , HasArg (upd . setPgma) )
- , ( "pgml" , HasArg (upd . setPgml) )
- , ( "pgmdll" , HasArg (upd . setPgmdll) )
- , ( "pgmwindres" , HasArg (upd . setPgmwindres) )
-
- , ( "optL" , HasArg (upd . addOptL) )
- , ( "optP" , HasArg (upd . addOptP) )
- , ( "optF" , HasArg (upd . addOptF) )
- , ( "optc" , HasArg (upd . addOptc) )
- , ( "optm" , HasArg (upd . addOptm) )
- , ( "opta" , HasArg (upd . addOpta) )
- , ( "optl" , HasArg (upd . addOptl) )
- , ( "optdep" , HasArg (upd . addOptdep) )
- , ( "optwindres" , HasArg (upd . addOptwindres) )
-
- , ( "split-objs" , NoArg (if can_split
- then setDynFlag Opt_SplitObjs
- else return ()) )
+ , Flag "pgmL" (HasArg (upd . setPgmL))
+ , Flag "pgmP" (HasArg (upd . setPgmP))
+ , Flag "pgmF" (HasArg (upd . setPgmF))
+ , Flag "pgmc" (HasArg (upd . setPgmc))
+ , Flag "pgmm" (HasArg (upd . setPgmm))
+ , Flag "pgms" (HasArg (upd . setPgms))
+ , Flag "pgma" (HasArg (upd . setPgma))
+ , Flag "pgml" (HasArg (upd . setPgml))
+ , Flag "pgmdll" (HasArg (upd . setPgmdll))
+ , Flag "pgmwindres" (HasArg (upd . setPgmwindres))
+
+ , Flag "optL" (HasArg (upd . addOptL))
+ , Flag "optP" (HasArg (upd . addOptP))
+ , Flag "optF" (HasArg (upd . addOptF))
+ , Flag "optc" (HasArg (upd . addOptc))
+ , Flag "optm" (HasArg (upd . addOptm))
+ , Flag "opta" (HasArg (upd . addOpta))
+ , Flag "optl" (HasArg (upd . addOptl))
+ , Flag "optdep" (HasArg (upd . addOptdep))
+ , Flag "optwindres" (HasArg (upd . addOptwindres))
+
+ , Flag "split-objs"
+ (NoArg (if can_split then setDynFlag Opt_SplitObjs else return ()))
-------- Linking ----------------------------------------------------
- , ( "c" , NoArg (upd $ \d -> d{ ghcLink=NoLink } ))
- , ( "no-link" , NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep.
- , ( "shared" , NoArg (upd $ \d -> d{ ghcLink=LinkDynLib } ))
- , ( "dynload" , HasArg (upd . parseDynLibLoaderMode))
+ , Flag "c" (NoArg (upd $ \d -> d{ ghcLink=NoLink } ))
+ , Flag "no-link" (NoArg (upd $ \d -> d{ ghcLink=NoLink } )) -- Dep.
+ , Flag "shared" (NoArg (upd $ \d -> d{ ghcLink=LinkDynLib } ))
+ , Flag "dynload" (HasArg (upd . parseDynLibLoaderMode))
------- Libraries ---------------------------------------------------
- , ( "L" , Prefix addLibraryPath )
- , ( "l" , AnySuffix (\s -> do upd (addOptl s)))
+ , Flag "L" (Prefix addLibraryPath )
+ , Flag "l" (AnySuffix (\s -> do upd (addOptl s)))
------- Frameworks --------------------------------------------------
-- -framework-path should really be -F ...
- , ( "framework-path" , HasArg addFrameworkPath )
- , ( "framework" , HasArg (upd . addCmdlineFramework) )
+ , Flag "framework-path" (HasArg addFrameworkPath )
+ , Flag "framework" (HasArg (upd . addCmdlineFramework))
------- Output Redirection ------------------------------------------
- , ( "odir" , HasArg (upd . setObjectDir))
- , ( "o" , SepArg (upd . setOutputFile . Just))
- , ( "ohi" , HasArg (upd . setOutputHi . Just ))
- , ( "osuf" , HasArg (upd . setObjectSuf))
- , ( "hcsuf" , HasArg (upd . setHcSuf))
- , ( "hisuf" , HasArg (upd . setHiSuf))
- , ( "hidir" , HasArg (upd . setHiDir))
- , ( "tmpdir" , HasArg (upd . setTmpDir))
- , ( "stubdir" , HasArg (upd . setStubDir))
- , ( "ddump-file-prefix", HasArg (upd . setDumpPrefixForce . Just))
+ , Flag "odir" (HasArg (upd . setObjectDir))
+ , Flag "o" (SepArg (upd . setOutputFile . Just))
+ , Flag "ohi" (HasArg (upd . setOutputHi . Just ))
+ , Flag "osuf" (HasArg (upd . setObjectSuf))
+ , Flag "hcsuf" (HasArg (upd . setHcSuf))
+ , Flag "hisuf" (HasArg (upd . setHiSuf))
+ , Flag "hidir" (HasArg (upd . setHiDir))
+ , Flag "tmpdir" (HasArg (upd . setTmpDir))
+ , Flag "stubdir" (HasArg (upd . setStubDir))
+ , Flag "ddump-file-prefix" (HasArg (upd . setDumpPrefixForce . Just))
------- Keeping temporary files -------------------------------------
-- These can be singular (think ghc -c) or plural (think ghc --make)
- , ( "keep-hc-file" , NoArg (setDynFlag Opt_KeepHcFiles))
- , ( "keep-hc-files" , NoArg (setDynFlag Opt_KeepHcFiles))
- , ( "keep-s-file" , NoArg (setDynFlag Opt_KeepSFiles))
- , ( "keep-s-files" , NoArg (setDynFlag Opt_KeepSFiles))
- , ( "keep-raw-s-file" , NoArg (setDynFlag Opt_KeepRawSFiles))
- , ( "keep-raw-s-files", NoArg (setDynFlag Opt_KeepRawSFiles))
+ , Flag "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles))
+ , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles))
+ , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles))
+ , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles))
+ , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles))
+ , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles))
-- This only makes sense as plural
- , ( "keep-tmp-files" , NoArg (setDynFlag Opt_KeepTmpFiles))
+ , Flag "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles))
------- Miscellaneous ----------------------------------------------
- , ( "no-hs-main" , NoArg (setDynFlag Opt_NoHsMain))
- , ( "main-is" , SepArg setMainIs )
- , ( "haddock" , NoArg (setDynFlag Opt_Haddock) )
- , ( "haddock-opts" , HasArg (upd . addHaddockOpts))
- , ( "hpcdir" , SepArg setOptHpcDir )
+ , Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain))
+ , Flag "main-is" (SepArg setMainIs )
+ , Flag "haddock" (NoArg (setDynFlag Opt_Haddock))
+ , Flag "haddock-opts" (HasArg (upd . addHaddockOpts))
+ , Flag "hpcdir" (SepArg setOptHpcDir)
------- recompilation checker (DEPRECATED, use -fforce-recomp) -----
- , ( "recomp" , NoArg (unSetDynFlag Opt_ForceRecomp) )
- , ( "no-recomp" , NoArg (setDynFlag Opt_ForceRecomp) )
+ , Flag "recomp" (NoArg (unSetDynFlag Opt_ForceRecomp))
+ , Flag "no-recomp" (NoArg (setDynFlag Opt_ForceRecomp))
------- Packages ----------------------------------------------------
- , ( "package-conf" , HasArg extraPkgConf_ )
- , ( "no-user-package-conf", NoArg (unSetDynFlag Opt_ReadUserPackageConf) )
- , ( "package-name" , HasArg (upd . setPackageName) )
- , ( "package" , HasArg exposePackage )
- , ( "hide-package" , HasArg hidePackage )
- , ( "hide-all-packages", NoArg (setDynFlag Opt_HideAllPackages) )
- , ( "ignore-package" , HasArg ignorePackage )
- , ( "syslib" , HasArg exposePackage ) -- for compatibility
+ , Flag "package-conf" (HasArg extraPkgConf_)
+ , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf))
+ , Flag "package-name" (HasArg (upd . setPackageName))
+ , Flag "package" (HasArg exposePackage)
+ , Flag "hide-package" (HasArg hidePackage)
+ , Flag "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages))
+ , Flag "ignore-package" (HasArg ignorePackage)
+ , Flag "syslib" (HasArg exposePackage) -- for compatibility
------ HsCpp opts ---------------------------------------------------
- , ( "D", AnySuffix (upd . addOptP) )
- , ( "U", AnySuffix (upd . addOptP) )
+ , Flag "D" (AnySuffix (upd . addOptP))
+ , Flag "U" (AnySuffix (upd . addOptP))
------- Include/Import Paths ----------------------------------------
- , ( "I" , Prefix addIncludePath)
- , ( "i" , OptPrefix addImportPath )
+ , Flag "I" (Prefix addIncludePath)
+ , Flag "i" (OptPrefix addImportPath )
------ Debugging ----------------------------------------------------
- , ( "dstg-stats", NoArg (setDynFlag Opt_StgStats))
-
- , ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm)
- , ( "ddump-cmmz", setDumpFlag Opt_D_dump_cmmz)
- , ( "ddump-cmmz-pretty", setDumpFlag Opt_D_dump_cmmz_pretty)
- , ( "ddump-cps-cmm", setDumpFlag Opt_D_dump_cps_cmm)
- , ( "ddump-cvt-cmm", setDumpFlag Opt_D_dump_cvt_cmm)
- , ( "ddump-asm", setDumpFlag Opt_D_dump_asm)
- , ( "ddump-asm-native", setDumpFlag Opt_D_dump_asm_native)
- , ( "ddump-asm-liveness", setDumpFlag Opt_D_dump_asm_liveness)
- , ( "ddump-asm-coalesce", setDumpFlag Opt_D_dump_asm_coalesce)
- , ( "ddump-asm-regalloc", setDumpFlag Opt_D_dump_asm_regalloc)
- , ( "ddump-asm-conflicts", setDumpFlag Opt_D_dump_asm_conflicts)
- , ( "ddump-asm-regalloc-stages",
- setDumpFlag Opt_D_dump_asm_regalloc_stages)
- , ( "ddump-asm-stats", setDumpFlag Opt_D_dump_asm_stats)
- , ( "ddump-cpranal", setDumpFlag Opt_D_dump_cpranal)
- , ( "ddump-deriv", setDumpFlag Opt_D_dump_deriv)
- , ( "ddump-ds", setDumpFlag Opt_D_dump_ds)
- , ( "ddump-flatC", setDumpFlag Opt_D_dump_flatC)
- , ( "ddump-foreign", setDumpFlag Opt_D_dump_foreign)
- , ( "ddump-inlinings", setDumpFlag Opt_D_dump_inlinings)
- , ( "ddump-rule-firings", setDumpFlag Opt_D_dump_rule_firings)
- , ( "ddump-occur-anal", setDumpFlag Opt_D_dump_occur_anal)
- , ( "ddump-parsed", setDumpFlag Opt_D_dump_parsed)
- , ( "ddump-rn", setDumpFlag Opt_D_dump_rn)
- , ( "ddump-simpl", setDumpFlag Opt_D_dump_simpl)
- , ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations)
- , ( "ddump-simpl-phases", OptPrefix setDumpSimplPhases)
- , ( "ddump-spec", setDumpFlag Opt_D_dump_spec)
- , ( "ddump-prep", setDumpFlag Opt_D_dump_prep)
- , ( "ddump-stg", setDumpFlag Opt_D_dump_stg)
- , ( "ddump-stranal", setDumpFlag Opt_D_dump_stranal)
- , ( "ddump-tc", setDumpFlag Opt_D_dump_tc)
- , ( "ddump-types", setDumpFlag Opt_D_dump_types)
- , ( "ddump-rules", setDumpFlag Opt_D_dump_rules)
- , ( "ddump-cse", setDumpFlag Opt_D_dump_cse)
- , ( "ddump-worker-wrapper", setDumpFlag Opt_D_dump_worker_wrapper)
- , ( "ddump-rn-trace", setDumpFlag Opt_D_dump_rn_trace)
- , ( "ddump-if-trace", setDumpFlag Opt_D_dump_if_trace)
- , ( "ddump-tc-trace", setDumpFlag Opt_D_dump_tc_trace)
- , ( "ddump-splices", setDumpFlag Opt_D_dump_splices)
- , ( "ddump-rn-stats", setDumpFlag Opt_D_dump_rn_stats)
- , ( "ddump-opt-cmm", setDumpFlag Opt_D_dump_opt_cmm)
- , ( "ddump-simpl-stats", setDumpFlag Opt_D_dump_simpl_stats)
- , ( "ddump-bcos", setDumpFlag Opt_D_dump_BCOs)
- , ( "dsource-stats", setDumpFlag Opt_D_source_stats)
- , ( "dverbose-core2core", NoArg setVerboseCore2Core)
- , ( "dverbose-stg2stg", setDumpFlag Opt_D_verbose_stg2stg)
- , ( "ddump-hi", setDumpFlag Opt_D_dump_hi)
- , ( "ddump-minimal-imports", setDumpFlag Opt_D_dump_minimal_imports)
- , ( "ddump-vect", setDumpFlag Opt_D_dump_vect)
- , ( "ddump-hpc", setDumpFlag Opt_D_dump_hpc)
- , ( "ddump-mod-cycles", setDumpFlag Opt_D_dump_mod_cycles)
- , ( "ddump-view-pattern-commoning", setDumpFlag Opt_D_dump_view_pattern_commoning)
- , ( "ddump-to-file", setDumpFlag Opt_DumpToFile)
- , ( "ddump-hi-diffs", setDumpFlag Opt_D_dump_hi_diffs)
-
- , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting))
- , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting))
- , ( "dcmm-lint", NoArg (setDynFlag Opt_DoCmmLinting))
- , ( "dasm-lint", NoArg (setDynFlag Opt_DoAsmLinting))
- , ( "dshow-passes", NoArg (do setDynFlag Opt_ForceRecomp
- setVerbosity (Just 2)) )
- , ( "dfaststring-stats", NoArg (setDynFlag Opt_D_faststring_stats))
+ , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats))
+
+ , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm)
+ , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz)
+ , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty)
+ , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm)
+ , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm)
+ , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm)
+ , Flag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native)
+ , Flag "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness)
+ , Flag "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce)
+ , Flag "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc)
+ , Flag "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts)
+ , Flag "ddump-asm-regalloc-stages"
+ (setDumpFlag Opt_D_dump_asm_regalloc_stages)
+ , Flag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats)
+ , Flag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal)
+ , Flag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv)
+ , Flag "ddump-ds" (setDumpFlag Opt_D_dump_ds)
+ , Flag "ddump-flatC" (setDumpFlag Opt_D_dump_flatC)
+ , Flag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign)
+ , Flag "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings)
+ , Flag "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings)
+ , Flag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal)
+ , Flag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed)
+ , Flag "ddump-rn" (setDumpFlag Opt_D_dump_rn)
+ , Flag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl)
+ , Flag "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations)
+ , Flag "ddump-simpl-phases" (OptPrefix setDumpSimplPhases)
+ , Flag "ddump-spec" (setDumpFlag Opt_D_dump_spec)
+ , Flag "ddump-prep" (setDumpFlag Opt_D_dump_prep)
+ , Flag "ddump-stg" (setDumpFlag Opt_D_dump_stg)
+ , Flag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal)
+ , Flag "ddump-tc" (setDumpFlag Opt_D_dump_tc)
+ , Flag "ddump-types" (setDumpFlag Opt_D_dump_types)
+ , Flag "ddump-rules" (setDumpFlag Opt_D_dump_rules)
+ , Flag "ddump-cse" (setDumpFlag Opt_D_dump_cse)
+ , Flag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper)
+ , Flag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace)
+ , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace)
+ , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace)
+ , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices)
+ , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats)
+ , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm)
+ , Flag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats)
+ , Flag "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs)
+ , Flag "dsource-stats" (setDumpFlag Opt_D_source_stats)
+ , Flag "dverbose-core2core" (NoArg setVerboseCore2Core)
+ , Flag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg)
+ , Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi)
+ , Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports)
+ , Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect)
+ , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_hpc)
+ , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles)
+ , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning)
+ , Flag "ddump-to-file" (setDumpFlag Opt_DumpToFile)
+ , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs)
+
+ , Flag "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting))
+ , Flag "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting))
+ , Flag "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting))
+ , Flag "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting))
+ , Flag "dshow-passes"
+ (NoArg (do setDynFlag Opt_ForceRecomp
+ setVerbosity (Just 2)))
+ , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats))
------ Machine dependant (-m<blah>) stuff ---------------------------
- , ( "monly-2-regs", NoArg (upd (\s -> s{stolen_x86_regs = 2}) ))
- , ( "monly-3-regs", NoArg (upd (\s -> s{stolen_x86_regs = 3}) ))
- , ( "monly-4-regs", NoArg (upd (\s -> s{stolen_x86_regs = 4}) ))
+ , Flag "monly-2-regs" (NoArg (upd (\s -> s{stolen_x86_regs = 2}) ))
+ , Flag "monly-3-regs" (NoArg (upd (\s -> s{stolen_x86_regs = 3}) ))
+ , Flag "monly-4-regs" (NoArg (upd (\s -> s{stolen_x86_regs = 4}) ))
------ Warning opts -------------------------------------------------
- , ( "W" , NoArg (mapM_ setDynFlag minusWOpts) )
- , ( "Werror", NoArg (setDynFlag Opt_WarnIsError) )
- , ( "Wwarn" , NoArg (unSetDynFlag Opt_WarnIsError) )
- , ( "Wall" , NoArg (mapM_ setDynFlag minusWallOpts) )
- , ( "Wnot" , NoArg (mapM_ unSetDynFlag minusWallOpts) ) -- DEPRECATED
- , ( "w" , NoArg (mapM_ unSetDynFlag minuswRemovesOpts) )
+ , Flag "W" (NoArg (mapM_ setDynFlag minusWOpts))
+ , Flag "Werror" (NoArg (setDynFlag Opt_WarnIsError))
+ , Flag "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError))
+ , Flag "Wall" (NoArg (mapM_ setDynFlag minusWallOpts))
+ , Flag "Wnot" (NoArg (mapM_ unSetDynFlag minusWallOpts)) -- DEPRECATED
+ , Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts))
------ Optimisation flags ------------------------------------------
- , ( "O" , NoArg (upd (setOptLevel 1)))
- , ( "Onot" , NoArg (upd (setOptLevel 0))) -- deprecated
- , ( "Odph" , NoArg (upd setDPHOpt))
- , ( "O" , OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1))))
+ , Flag "O" (NoArg (upd (setOptLevel 1)))
+ , Flag "Onot" (NoArg (upd (setOptLevel 0))) -- deprecated
+ , Flag "Odph" (NoArg (upd setDPHOpt))
+ , Flag "O" (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1))))
-- If the number is missing, use 1
- , ( "fsimplifier-phases", IntSuffix (\n ->
- upd (\dfs -> dfs{ simplPhases = n })) )
- , ( "fmax-simplifier-iterations", IntSuffix (\n ->
- upd (\dfs -> dfs{ maxSimplIterations = n })) )
-
- , ( "fspec-constr-threshold", IntSuffix (\n ->
- upd (\dfs -> dfs{ specConstrThreshold = Just n })))
- , ( "fno-spec-constr-threshold", NoArg (
- upd (\dfs -> dfs{ specConstrThreshold = Nothing })))
- , ( "fspec-constr-count", IntSuffix (\n ->
- upd (\dfs -> dfs{ specConstrCount = Just n })))
- , ( "fno-spec-constr-count", NoArg (
- upd (\dfs -> dfs{ specConstrCount = Nothing })))
- , ( "fliberate-case-threshold", IntSuffix (\n ->
- upd (\dfs -> dfs{ liberateCaseThreshold = Just n })))
- , ( "fno-liberate-case-threshold", NoArg (
- upd (\dfs -> dfs{ liberateCaseThreshold = Nothing })))
-
- , ( "frule-check", SepArg (\s -> upd (\dfs -> dfs{ ruleCheck = Just s })))
- , ( "fcontext-stack" , IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n })
+ , Flag "fsimplifier-phases"
+ (IntSuffix (\n -> upd (\dfs -> dfs{ simplPhases = n })))
+ , Flag "fmax-simplifier-iterations"
+ (IntSuffix (\n -> upd (\dfs -> dfs{ maxSimplIterations = n })))
+
+ , Flag "fspec-constr-threshold"
+ (IntSuffix (\n -> upd (\dfs -> dfs{ specConstrThreshold = Just n })))
+ , Flag "fno-spec-constr-threshold"
+ (NoArg (upd (\dfs -> dfs{ specConstrThreshold = Nothing })))
+ , Flag "fspec-constr-count"
+ (IntSuffix (\n -> upd (\dfs -> dfs{ specConstrCount = Just n })))
+ , Flag "fno-spec-constr-count"
+ (NoArg (upd (\dfs -> dfs{ specConstrCount = Nothing })))
+ , Flag "fliberate-case-threshold"
+ (IntSuffix (\n -> upd (\dfs -> dfs{ liberateCaseThreshold = Just n })))
+ , Flag "fno-liberate-case-threshold"
+ (NoArg (upd (\dfs -> dfs{ liberateCaseThreshold = Nothing })))
+
+ , Flag "frule-check"
+ (SepArg (\s -> upd (\dfs -> dfs{ ruleCheck = Just s })))
+ , Flag "fcontext-stack"
+ (IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n })
------ Compiler flags -----------------------------------------------
- , ( "fasm", NoArg (setObjTarget HscAsm) )
- , ( "fvia-c", NoArg (setObjTarget HscC) )
- , ( "fvia-C", NoArg (setObjTarget HscC) )
+ , Flag "fasm" (NoArg (setObjTarget HscAsm))
+ , Flag "fvia-c" (NoArg (setObjTarget HscC))
+ , Flag "fvia-C" (NoArg (setObjTarget HscC))
- , ( "fno-code", NoArg (setTarget HscNothing))
- , ( "fbyte-code", NoArg (setTarget HscInterpreted) )
- , ( "fobject-code", NoArg (setTarget defaultHscTarget) )
+ , Flag "fno-code" (NoArg (setTarget HscNothing))
+ , Flag "fbyte-code" (NoArg (setTarget HscInterpreted))
+ , Flag "fobject-code" (NoArg (setTarget defaultHscTarget))
- , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) )
- , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )
+ , Flag "fglasgow-exts" (NoArg (mapM_ setDynFlag glasgowExtsFlags))
+ , Flag "fno-glasgow-exts" (NoArg (mapM_ unSetDynFlag glasgowExtsFlags))
-- the rest of the -f* and -fno-* flags
- , ( "f", PrefixPred (isFlag fFlags)
- (\f -> setDynFlag (getFlag fFlags f)) )
- , ( "f", PrefixPred (isPrefFlag "no-" fFlags)
- (\f -> unSetDynFlag (getPrefFlag "no-" fFlags f)) )
+ , Flag "f"
+ (PrefixPred (isFlag fFlags)
+ (\f -> setDynFlag (getFlag fFlags f)))
+ , Flag "f"
+ (PrefixPred (isPrefFlag "no-" fFlags)
+ (\f -> unSetDynFlag (getPrefFlag "no-" fFlags f)))
-- the -X* and -XNo* flags
- , ( "X", PrefixPred (isFlag xFlags)
- (\f -> setDynFlag (getFlag xFlags f)) )
- , ( "X", PrefixPred (isPrefFlag "No" xFlags)
- (\f -> unSetDynFlag (getPrefFlag "No" xFlags f)) )
+ , Flag "X"
+ (PrefixPred (isFlag xFlags)
+ (\f -> setDynFlag (getFlag xFlags f)))
+ , Flag "X"
+ (PrefixPred (isPrefFlag "No" xFlags)
+ (\f -> unSetDynFlag (getPrefFlag "No" xFlags f)))
]
-- these -f<blah> flags can all be reversed with -fno-<blah>
diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs
index f0a6611cf7..57cf28ea4e 100644
--- a/compiler/main/Main.hs
+++ b/compiler/main/Main.hs
@@ -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 ()
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 6d826cb72b..dd5754c1ab 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -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 ()