Use a proper datatype, rather than pairs, for flags

diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 8ec2f6a..710faf6 100644 (file)
--- 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 052c138..a0ce114 100644 (file)
--- 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 2d24aac..a051916 100644 (file)
--- 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 f0a6611..57cf28e 100644 (file)
--- 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 6d826cb..dd5754c 100644 (file)
--- 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 ()