X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FCmdLineParser.hs;h=d237ad70e25efec18b002fc557bfc6fb191b3581;hb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa;hp=e34b8c08575b6c82f4c3370d03efd5fdd401c4f0;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index e34b8c0..d237ad7 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -21,17 +21,19 @@ import Util	( maybePrefixMatch, notNull, removeSpaces )
 import Panic	( assertPanic )
 #endif
 
-data OptKind m
-	= NoArg (m ())  -- flag with no argument
-	| HasArg    (String -> m ())    -- flag has an argument (maybe prefix)
-	| SepArg    (String -> m ())    -- flag has a separate argument
-	| Prefix    (String -> m ())    -- flag is a prefix only
-	| OptPrefix (String -> m ())    -- flag may be a prefix
-	| AnySuffix (String -> m ())    -- flag is a prefix, pass whole arg to fn
-	| PassFlag  (String -> m ())    -- flag with no arg, pass flag to fn
+data OptKind m		-- Suppose the flag is -f
+	= NoArg (m ())			-- -f all by itself
+	| HasArg    (String -> m ())    -- -farg or -f arg
+	| SepArg    (String -> m ())    -- -f arg
+	| Prefix    (String -> m ())    -- -farg 
+	| OptPrefix (String -> m ())    -- -f or -farg (i.e. the arg is optional)
+	| OptIntSuffix (Maybe Int -> m ())	-- -f or -f=n; pass n to fn
+	| IntSuffix (Int -> m ())		-- -f or -f=n; pass n to fn
+	| PassFlag  (String -> m ())    -- -f; pass "-f" fn
+	| AnySuffix (String -> m ())    -- -f or -farg; pass entire "-farg" to fn
 	| PrefixPred    (String -> Bool) (String -> m ())
 	| AnySuffixPred (String -> Bool) (String -> m ())
-
+ 
 processArgs :: Monad m
 	    => [(String, OptKind m)]	-- cmdline parser spec
 	    -> [String]			-- args
@@ -44,58 +46,54 @@ processArgs spec args = process spec args [] []
     process _spec [] spare errs =
       return (reverse spare, reverse errs)
     
-    process spec args@(('-':arg):args') spare errs =
+    process spec (dash_arg@('-':arg):args) spare errs =
       case findArg spec arg of
         Just (rest,action) -> 
-           case processOneArg action rest args of
-    	   Left err       -> process spec args' spare (err:errs)
-    	   Right (action,rest) -> do
-    		action >> process spec rest spare errs
-        Nothing -> 
-    	   process spec args' (('-':arg):spare) errs
+           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]
-  -> Either String (m (), [String])
-processOneArg action rest (dash_arg@('-':arg):args) =
-  case action of
+processOneArg :: OptKind m -> String -> String -> [String]
+	      -> Either String (m (), [String])
+processOneArg action rest arg args 
+  = let dash_arg = '-' : arg
+	rest_no_eq = dropEq rest
+    in case action of
 	NoArg  a -> ASSERT(null rest) Right (a, args)
 
-	HasArg f -> 
-		if rest /= "" 
-			then Right (f rest, args)
-			else case args of
-				[] -> missingArgErr dash_arg
-				(arg1:args1) -> Right (f arg1, args1)
+	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)
 
-	SepArg f -> 
-		case args of
+	SepArg f -> case args of
 			[] -> unknownFlagErr dash_arg
 			(arg1:args1) -> Right (f arg1, args1)
 
-	Prefix f -> 
-		if rest /= ""
-			then Right (f rest, args)
-			else unknownFlagErr dash_arg
+	Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)
+		 | otherwise  -> unknownFlagErr dash_arg
 	
-	PrefixPred p f -> 
-		if rest /= ""
-			then Right (f rest, args)
-			else unknownFlagErr dash_arg
+	PrefixPred p f | notNull rest_no_eq -> Right (f rest_no_eq, args)
+		       | otherwise          -> unknownFlagErr dash_arg
 	
-	OptPrefix f       -> Right (f rest, args)
+	PassFlag f  | notNull rest -> unknownFlagErr dash_arg
+		    | otherwise    -> Right (f dash_arg, args)
 
-	AnySuffix f       -> Right (f dash_arg, args)
+	OptIntSuffix f | null rest 		       -> Right (f Nothing,  args)
+		       | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)
+		       | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
 
-	AnySuffixPred p f -> Right (f dash_arg, args)
+	IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)
+		    | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
 
-	PassFlag f  -> 
-		if rest /= ""
-			then unknownFlagErr dash_arg
-			else Right (f dash_arg, args)
+	OptPrefix f       -> Right (f rest_no_eq, args)
+	AnySuffix f       -> Right (f dash_arg, args)
+	AnySuffixPred p f -> Right (f dash_arg, args)
 
 
 findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a)
@@ -112,12 +110,27 @@ arg_ok (NoArg _)            rest arg = null rest
 arg_ok (HasArg _)           rest arg = True
 arg_ok (SepArg _)           rest arg = null rest
 arg_ok (Prefix _)	    rest arg = notNull rest
-arg_ok (PrefixPred p _)     rest arg = notNull rest && p rest
+arg_ok (PrefixPred p _)     rest arg = notNull rest && p (dropEq rest)
+arg_ok (OptIntSuffix _)	    rest arg = True
+arg_ok (IntSuffix _)	    rest arg = True
 arg_ok (OptPrefix _)	    rest arg = True
 arg_ok (PassFlag _)         rest arg = null rest 
 arg_ok (AnySuffix _)        rest arg = True
 arg_ok (AnySuffixPred p _)  rest arg = p arg
 
+parseInt :: String -> Maybe Int
+-- Looks for "433" or "=342", with no trailing gubbins
+--   n or =n	  => Just n
+--   gibberish    => Nothing
+parseInt s = case reads s of
+		((n,""):_) -> Just n
+		other	   -> Nothing
+
+dropEq :: String -> String
+-- Discards a leading equals sign
+dropEq ('=' : s) = s
+dropEq s         = s
+
 unknownFlagErr :: String -> Either String a
 unknownFlagErr f = Left ("unrecognised flag: " ++ f)