Allow flags to be marked as deprecated

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index a49109a..994c0e1 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -38,6 +38,7 @@ import Name
 import SrcLoc
 
 -- Other random utilities
+import ErrUtils
 import Digraph
 import BasicTypes hiding (isTopLevel)
 import Panic      hiding (showException)
@@ -1487,7 +1488,8 @@ newDynFlags :: [String] -> GHCi ()
 newDynFlags minus_opts = do
       dflags <- getDynFlags
       let pkg_flags = packageFlags dflags
-      (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
+      (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags minus_opts
+      io $ handleFlagWarnings dflags' warns
 
       if (not (null leftovers))
                then throwDyn (CmdLineError ("unrecognised flags: " ++ 

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

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

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 7c515fe..318dac5 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -614,7 +614,8 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
 runPhase (Cpp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
   = do let dflags0 = hsc_dflags hsc_env
        src_opts <- getOptionsFromFile dflags0 input_fn
-       (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts)
+       (dflags, unhandled_flags, warns) <- parseDynamicFlags dflags0 (map unLoc src_opts)
+       handleFlagWarnings dflags warns
        checkProcessArgsResult unhandled_flags (basename <.> suff)
 
        if not (dopt Opt_Cpp dflags) then

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

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

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

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

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