Make -fcontext-stack into a dynamic flag

  This allows you to put -fcontext-stack into an options pragma,
  as requested by Trac #829
  
  While I was at it, I added OptIntPrefix to the forms allowed
  in CmdLineParser.

3 files changed, 65 insertions, 53 deletions

diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index e34b8c0857..dfe3125bd1 100644
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -21,14 +21,15 @@ 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
+	| 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 ())
 
@@ -44,58 +45,50 @@ 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
+    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 -> Right (f rest, 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 -> Right (f rest, args)
+		 | otherwise  -> unknownFlagErr dash_arg
 	
-	PrefixPred p f -> 
-		if rest /= ""
-			then Right (f rest, args)
-			else unknownFlagErr dash_arg
+	PrefixPred p f | notNull rest -> Right (f rest, 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 | Just n <- parseInt rest -> Right (f n, args)
+		       | otherwise -> Left ("malformed integer argument in " ++ dash_arg)
 
+	OptPrefix f       -> Right (f rest, args)
+	AnySuffix f       -> Right (f dash_arg, args)
 	AnySuffixPred p f -> Right (f dash_arg, args)
 
-	PassFlag f  -> 
-		if rest /= ""
-			then unknownFlagErr dash_arg
-			else Right (f dash_arg, args)
 
 
 findArg :: [(String,OptKind a)] -> String -> Maybe (String,OptKind a)
@@ -113,11 +106,28 @@ 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 (OptIntSuffix _)	    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 (Maybe Int)
+-- Looks for "433" or "=342", with no trailing gubbins
+--   empty string => Just Nothing
+--   n or =n	  => Just (Just n)
+--   gibberish    => Nothing
+parseInt s 
+  | null s    = Just Nothing
+  | otherwise = case reads (dropEq s) of
+		  ((n,""):_) -> Just (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)
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index bc6a0af300..2a46d0ea38 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -61,8 +61,10 @@ import {-# SOURCE #-} Packages (PackageState)
 import DriverPhases	( Phase(..), phaseInputExt )
 import Config
 import CmdLineParser
+import Constants	( mAX_CONTEXT_REDUCTION_DEPTH )
 import Panic		( panic, GhcException(..) )
-import Util		( notNull, splitLongestPrefix, split, normalisePath )
+import Util		( notNull, splitLongestPrefix, normalisePath )
+import Maybes		( fromJust, orElse )
 import SrcLoc           ( SrcSpan )
 
 import DATA_IOREF	( readIORef )
@@ -71,7 +73,6 @@ import Monad		( when )
 #ifdef mingw32_TARGET_OS
 import Data.List	( isPrefixOf )
 #endif
-import Maybe		( fromJust )
 import Char		( isDigit, isUpper )
 import Outputable
 import System.IO        ( hPutStrLn, stderr )
@@ -214,6 +215,8 @@ data DynFlags = DynFlags {
   importPaths		:: [FilePath],
   mainModIs		:: Module,
   mainFunIs		:: Maybe String,
+  ctxtStkDepth	        :: Int,		-- Typechecker context stack depth
+
   thisPackage		:: PackageId,
 
   -- ways
@@ -349,6 +352,8 @@ defaultDynFlags =
 	importPaths		= ["."],
 	mainModIs		= mAIN,
 	mainFunIs		= Nothing,
+	ctxtStkDepth		= mAX_CONTEXT_REDUCTION_DEPTH,
+
 	thisPackage		= mainPackageId,
 	
 	wayNames		= panic "ways",
@@ -800,7 +805,7 @@ dynamic_flags = [
   ,  ( "cpp"		, NoArg  (setDynFlag Opt_Cpp))
   ,  ( "F"		, NoArg  (setDynFlag Opt_Pp))
   ,  ( "#include"	, HasArg (addCmdlineHCInclude) )
-  ,  ( "v"		, OptPrefix (setVerbosity) )
+  ,  ( "v"		, OptIntSuffix setVerbosity )
 
         ------- Specific phases  --------------------------------------------
   ,  ( "pgmL"           , HasArg (upd . setPgmL) )  
@@ -929,7 +934,7 @@ dynamic_flags = [
   ,  ( "dstg-lint",        	 NoArg (setDynFlag Opt_DoStgLinting))
   ,  ( "dcmm-lint",		 NoArg (setDynFlag Opt_DoCmmLinting))
   ,  ( "dshow-passes",           NoArg (do unSetDynFlag Opt_RecompChecking
-				           setVerbosity "2") )
+				           setVerbosity (Just 2)) )
   ,  ( "dfaststring-stats",	 NoArg (setDynFlag Opt_D_faststring_stats))
 
 	------ Machine dependant (-m<blah>) stuff ---------------------------
@@ -970,6 +975,9 @@ dynamic_flags = [
   ,  ( "fglasgow-exts",    NoArg (mapM_ setDynFlag   glasgowExtsFlags) )
   ,  ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )
 
+  ,  ( "fcontext-stack"	, OptIntSuffix $ \mb_n -> upd $ \dfs -> 
+			  dfs{ ctxtStkDepth = mb_n `orElse` 3 })
+
 	-- the rest of the -f* and -fno-* flags
   ,  ( "fno-", 		PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
   ,  ( "f",		PrefixPred (\f -> isFFlag f) (\f -> setDynFlag (getFFlag f)) )
@@ -1064,10 +1072,8 @@ setDumpFlag dump_flag
 	-- Whenver we -ddump, switch off the recompilation checker,
 	-- else you don't see the dump!
 
-setVerbosity "" = upd (\dfs -> dfs{ verbosity = 3 })
-setVerbosity n 
-  | all isDigit n = upd (\dfs -> dfs{ verbosity = read n })
-  | otherwise     = throwDyn (UsageError "can't parse verbosity flag (-v<n>)")
+setVerbosity :: Maybe Int -> DynP ()
+setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })
 
 addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes =  a : cmdlineHcIncludes s})
 
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 3e9737fe5b..b49323b27a 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -29,7 +29,6 @@ module StaticFlags (
 
 	-- language opts
 	opt_DictsStrict,
-        opt_MaxContextReductionDepth,
 	opt_IrrefutableTuples,
 	opt_Parallel,
 	opt_RuntimeTypes,
@@ -78,7 +77,6 @@ import FastString	( FastString, mkFastString )
 import Util
 import Maybes		( firstJust )
 import Panic		( GhcException(..), ghcError )
-import Constants	( mAX_CONTEXT_REDUCTION_DEPTH )
 
 import EXCEPTION	( throwDyn )
 import DATA_IOREF
@@ -253,7 +251,6 @@ opt_DoTickyProfiling		= lookUp  FSLIT("-fticky-ticky")
 -- language opts
 opt_DictsStrict			= lookUp  FSLIT("-fdicts-strict")
 opt_IrrefutableTuples		= lookUp  FSLIT("-firrefutable-tuples")
-opt_MaxContextReductionDepth	= lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
 opt_Parallel			= lookUp  FSLIT("-fparallel")
 opt_Flatten			= lookUp  FSLIT("-fflatten")
 
@@ -337,7 +334,6 @@ isStaticFlag f =
 	"fPIC"
 	]
   || any (flip prefixMatch f) [
-	"fcontext-stack",
 	"fliberate-case-threshold",
 	"fmax-worker-args",
 	"fhistory-size",