X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FCmdLineParser.hs;h=dfe756bfee3bd8bf98dfd9626e83049da7dd1ff3;hb=0a5613f40b0e32cf59966e6b56b807cdbe80aa7b;hp=c7ad66e922b620b32682b92c6c80e5a64e3d2487;hpb=296e47fa8a5b16d34abe7d1dc5322308b936b3e8;p=ghc-hetmet.git

diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index c7ad66e..dfe756b 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -11,15 +11,28 @@
 
 module CmdLineParser (
         processArgs, OptKind(..),
-        CmdLineP(..), getCmdLineState, putCmdLineState
+        CmdLineP(..), getCmdLineState, putCmdLineState,
+        Flag(..), Deprecated(..),
+        errorsToGhcException
   ) where
 
--- XXX This define is a bit of a hack, and should be done more nicely
-#define FAST_STRING_NOT_NEEDED 1
 #include "HsVersions.h"
 
 import Util
+import Outputable
 import Panic
+import SrcLoc
+
+import Data.List
+
+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
@@ -35,31 +48,37 @@ data OptKind m                      -- Suppose the flag is -f
  | AnySuffixPred (String -> Bool) (String -> m ())
 
 processArgs :: Monad m
-            => [(String, OptKind m)] -- cmdline parser spec
-            -> [String]              -- args
+            => [Flag m] -- cmdline parser spec
+            -> [Located String]      -- args
             -> m (
-                  [String],  -- spare args
-                  [String]   -- errors
+                  [Located String],  -- spare args
+                  [Located String],  -- errors
+                  [Located 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 (locArg@(L loc 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
-
-    process spec (arg:args) spare errs =
-      process spec args (arg:spare) errs
-
-
-processOneArg :: OptKind m -> String -> String -> [String]
-              -> Either String (m (), [String])
+        Just (rest, action, deprecated) ->
+           let warns' = case deprecated of
+                        Deprecated warning ->
+                            L loc ("Warning: " ++ dash_arg ++ " is deprecated: " ++ warning) : warns
+                        Supported -> warns
+           in case processOneArg action rest arg args of
+              Left err            -> process spec args spare (L loc err : errs) warns'
+              Right (action,rest) -> do action
+                                        process spec rest spare errs warns'
+        Nothing -> process spec args (locArg : spare) errs warns
+
+    process spec (arg : args) spare errs warns =
+      process spec args (arg : spare) errs warns
+
+
+processOneArg :: OptKind m -> String -> String -> [Located String]
+              -> Either String (m (), [Located String])
 processOneArg action rest arg args
   = let dash_arg = '-' : arg
         rest_no_eq = dropEq rest
@@ -69,11 +88,11 @@ processOneArg action rest arg args
         HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
                  | otherwise    -> case args of
                                     [] -> missingArgErr dash_arg
-                                    (arg1:args1) -> Right (f arg1, args1)
+                                    (L _ arg1:args1) -> Right (f arg1, args1)
 
         SepArg f -> case args of
                         [] -> unknownFlagErr dash_arg
-                        (arg1:args1) -> Right (f arg1, args1)
+                        (L _ arg1:args1) -> Right (f arg1, args1)
 
         Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
                  | otherwise  -> unknownFlagErr dash_arg
@@ -96,12 +115,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, Deprecated)
 findArg spec arg
-  = case [ (removeSpaces rest, k)
-         | (pat,k)   <- spec,
-           Just rest <- [maybePrefixMatch pat arg],
-           arg_ok k rest arg ]
+  = case [ (removeSpaces rest, optKind, flagDeprecated flag)
+         | flag <- spec,
+           let optKind = flagOptKind flag,
+           Just rest <- [stripPrefix (flagName flag) arg],
+           arg_ok optKind rest arg ]
     of
         []      -> Nothing
         (one:_) -> Just one
@@ -153,3 +173,12 @@ getCmdLineState :: CmdLineP s s
 getCmdLineState   = CmdLineP $ \s -> (s,s)
 putCmdLineState :: s -> CmdLineP s ()
 putCmdLineState s = CmdLineP $ \_ -> ((),s)
+
+-- ---------------------------------------------------------------------
+-- Utils
+
+errorsToGhcException :: [Located String] -> GhcException
+errorsToGhcException errs =
+   let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
+   in UsageError (showSDoc errors)
+