Commit 0cb74388 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Refactor the command-line argument parsing (again)

This change allows the client of CmdLineParser a bit more flexibility,
by giving him an arbitrary computation (not just a deprecation
message) for each flag.  

There are several clients, so there are lots of boilerplate changes.

Immediate motivation: if RTS is not profiled, we want to make 
Template Haskell illegal.  That wasn't with the old setup.
parent 4ac17e1a
......@@ -12,8 +12,10 @@
module CmdLineParser (
processArgs, OptKind(..),
CmdLineP(..), getCmdLineState, putCmdLineState,
Flag(..), Deprecated(..),
errorsToGhcException
Flag(..),
errorsToGhcException,
EwM, addErr, addWarn, getArg, liftEwM, deprecate
) where
#include "HsVersions.h"
......@@ -21,33 +23,98 @@ module CmdLineParser (
import Util
import Outputable
import Panic
import Bag
import SrcLoc
import Data.List
--------------------------------------------------------
-- The Flag and OptKind types
--------------------------------------------------------
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?
{ flagName :: String, -- Flag, without the leading "-"
flagOptKind :: OptKind m -- What to do if we see it
}
data Deprecated = Supported
| Deprecated String
| DeprecatedFullText String
-------------------------------
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 ())
= NoArg (EwM m ()) -- -f all by itself
| HasArg (String -> EwM m ()) -- -farg or -f arg
| SepArg (String -> EwM m ()) -- -f arg
| Prefix (String -> EwM m ()) -- -farg
| OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional)
| OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn
| IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn
| PassFlag (String -> EwM m ()) -- -f; pass "-f" fn
| AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn
| PrefixPred (String -> Bool) (String -> EwM m ())
| AnySuffixPred (String -> Bool) (String -> EwM m ())
--------------------------------------------------------
-- The EwM monad
--------------------------------------------------------
type Err = Located String
type Warn = Located String
type Errs = Bag Err
type Warns = Bag Warn
-- EwM (short for "errors and warnings monad") is a
-- monad transformer for m that adds an (err, warn) state
newtype EwM m a = EwM { unEwM :: Located String -- Current arg
-> Errs -> Warns
-> m (Errs, Warns, a) }
instance Monad m => Monad (EwM m) where
(EwM f) >>= k = EwM (\l e w -> do { (e', w', r) <- f l e w
; unEwM (k r) l e' w' })
return v = EwM (\_ e w -> return (e, w, v))
setArg :: Located String -> EwM m a -> EwM m a
setArg l (EwM f) = EwM (\_ es ws -> f l es ws)
addErr :: Monad m => String -> EwM m ()
addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ()))
addWarn :: Monad m => String -> EwM m ()
addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ()))
where
w = "Warning: " ++ msg
deprecate :: Monad m => String -> EwM m ()
deprecate s
= do { arg <- getArg
; addWarn (arg ++ " is deprecated: " ++ s) }
getArg :: Monad m => EwM m String
getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))
liftEwM :: Monad m => m a -> EwM m a
liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
-- -----------------------------------------------------------------------------
-- A state monad for use in the command-line parser
-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
instance Monad (CmdLineP s) where
return a = CmdLineP $ \s -> (a, s)
m >>= k = CmdLineP $ \s -> let
(a, s') = runCmdLine m s
in runCmdLine (k a) s'
getCmdLineState :: CmdLineP s s
getCmdLineState = CmdLineP $ \s -> (s,s)
putCmdLineState :: s -> CmdLineP s ()
putCmdLineState s = CmdLineP $ \_ -> ((),s)
--------------------------------------------------------
-- Processing arguments
--------------------------------------------------------
processArgs :: Monad m
=> [Flag m] -- cmdline parser spec
......@@ -57,36 +124,34 @@ processArgs :: Monad m
[Located String], -- errors
[Located String] -- warnings
)
processArgs spec args = process spec args [] [] []
processArgs spec args
= do { (errs, warns, spare) <- unEwM (process args [])
(panic "processArgs: no arg yet")
emptyBag emptyBag
; return (spare, bagToList errs, bagToList warns) }
where
process _spec [] spare errs warns =
return (reverse spare, reverse errs, reverse warns)
-- process :: [Located String] -> [Located String] -> EwM m [Located String]
process [] spare = return (reverse spare)
process spec (locArg@(L loc dash_arg@('-' : arg)) : args) spare errs warns =
process (locArg@(L _ ('-' : arg)) : args) spare =
case findArg spec arg of
Just (rest, action, deprecated) ->
let warns' = case deprecated of
Deprecated warning ->
L loc ("Warning: " ++ dash_arg ++ " is deprecated: " ++ warning) : warns
DeprecatedFullText warning ->
L loc ("Warning: " ++ 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
Just (rest, opt_kind) ->
case processOneArg opt_kind rest arg args of
Left err -> do { setArg locArg $ addErr err
; process args spare }
Right (action,rest) -> do { setArg locArg $ action
; process rest spare }
Nothing -> process args (locArg : spare)
process (arg : args) spare = process args (arg : spare)
processOneArg :: OptKind m -> String -> String -> [Located String]
-> Either String (m (), [Located String])
processOneArg action rest arg args
-> Either String (EwM m (), [Located String])
processOneArg opt_kind rest arg args
= let dash_arg = '-' : arg
rest_no_eq = dropEq rest
in case action of
in case opt_kind of
NoArg a -> ASSERT(null rest) Right (a, args)
HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)
......@@ -119,9 +184,9 @@ processOneArg action rest arg args
AnySuffixPred _ f -> Right (f dash_arg, args)
findArg :: [Flag m] -> String -> Maybe (String, OptKind m, Deprecated)
findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
findArg spec arg
= case [ (removeSpaces rest, optKind, flagDeprecated flag)
= case [ (removeSpaces rest, optKind)
| flag <- spec,
let optKind = flagOptKind flag,
Just rest <- [stripPrefix (flagName flag) arg],
......@@ -162,22 +227,6 @@ unknownFlagErr f = Left ("unrecognised flag: " ++ f)
missingArgErr :: String -> Either String a
missingArgErr f = Left ("missing argument for flag: " ++ f)
-- -----------------------------------------------------------------------------
-- A state monad for use in the command-line parser
newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
instance Monad (CmdLineP s) where
return a = CmdLineP $ \s -> (a, s)
m >>= k = CmdLineP $ \s -> let
(a, s') = runCmdLine m s
in runCmdLine (k a) s'
getCmdLineState :: CmdLineP s s
getCmdLineState = CmdLineP $ \s -> (s,s)
putCmdLineState :: s -> CmdLineP s ()
putCmdLineState s = CmdLineP $ \_ -> ((),s)
-- ---------------------------------------------------------------------
-- Utils
......
This diff is collapsed.
......@@ -1026,6 +1026,11 @@ hscParseThing parser dflags str
compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
compileExpr hsc_env srcspan ds_expr
| rtsIsProfiled
= panic "You can't call compileExpr in a profiled compiler"
-- Otherwise you get a seg-fault when you run it
| otherwise
= do { let { dflags = hsc_dflags hsc_env ;
lint_on = dopt Opt_DoCoreLinting dflags }
......
......@@ -13,7 +13,9 @@ module StaticFlagParser (parseStaticFlags) where
#include "HsVersions.h"
import StaticFlags
import qualified StaticFlags as SF
import StaticFlags ( v_opt_C_ready, getWayFlags, tablesNextToCode, WayName(..)
, opt_SimplExcessPrecision )
import CmdLineParser
import Config
import SrcLoc
......@@ -101,61 +103,60 @@ static_flags :: [Flag IO]
static_flags = [
------- GHCi -------------------------------------------------------
Flag "ignore-dot-ghci" (PassFlag addOpt) Supported
, Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) Supported
Flag "ignore-dot-ghci" (PassFlag addOpt)
, Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci"))
------- ways --------------------------------------------------------
, Flag "prof" (NoArg (addWay WayProf)) Supported
, Flag "eventlog" (NoArg (addWay WayEventLog)) 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
, Flag "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug)) Supported
, Flag "prof" (NoArg (addWay WayProf))
, Flag "eventlog" (NoArg (addWay WayEventLog))
, Flag "parallel" (NoArg (addWay WayPar))
, Flag "gransim" (NoArg (addWay WayGran))
, Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead"))
, Flag "debug" (NoArg (addWay WayDebug))
, Flag "ndp" (NoArg (addWay WayNDP))
, Flag "threaded" (NoArg (addWay WayThreaded))
, Flag "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug))
-- -ticky enables ticky-ticky code generation, and also implies -debug which
-- is required to get the RTS ticky support.
------ Debugging ----------------------------------------------------
, Flag "dppr-debug" (PassFlag addOpt) Supported
, Flag "dsuppress-uniques" (PassFlag addOpt) Supported
, Flag "dsuppress-coercions" (PassFlag addOpt) Supported
, Flag "dppr-user-length" (AnySuffix addOpt) Supported
, Flag "dopt-fuel" (AnySuffix addOpt) Supported
, Flag "dno-debug-output" (PassFlag addOpt) Supported
, Flag "dstub-dead-values" (PassFlag addOpt) Supported
, Flag "dppr-debug" (PassFlag addOpt)
, Flag "dsuppress-uniques" (PassFlag addOpt)
, Flag "dsuppress-coercions" (PassFlag addOpt)
, Flag "dppr-user-length" (AnySuffix addOpt)
, Flag "dopt-fuel" (AnySuffix addOpt)
, Flag "dno-debug-output" (PassFlag addOpt)
, Flag "dstub-dead-values" (PassFlag addOpt)
-- rest of the debugging flags are dynamic
----- Linker --------------------------------------------------------
, Flag "static" (PassFlag addOpt) Supported
, Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) Supported
, Flag "static" (PassFlag addOpt)
, Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn))
-- ignored for compat w/ gcc:
, Flag "rdynamic" (NoArg (return ())) Supported
, Flag "rdynamic" (NoArg (return ()))
----- RTS opts ------------------------------------------------------
, Flag "H" (HasArg (setHeapSize . fromIntegral . decodeSize))
Supported
, Flag "Rghc-timing" (NoArg (enableTimingStats)) Supported
, Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s)))))
, Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats))
------ Compiler flags -----------------------------------------------
-- -fPIC requires extra checking: only the NCG supports it.
-- See also DynFlags.parseDynamicFlags.
, Flag "fPIC" (PassFlag setPIC) Supported
, Flag "fPIC" (PassFlag setPIC)
-- 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
, Flag "f" (AnySuffixPred isStaticFlag addOpt)
]
setPIC :: String -> IO ()
setPIC :: String -> StaticP ()
setPIC | cGhcWithNativeCodeGen == "YES" || cGhcUnregisterised == "YES"
= addOpt
| otherwise
......@@ -217,6 +218,18 @@ decodeSize str
n = readRational m
pred c = isDigit c || c == '.'
type StaticP = EwM IO
addOpt :: String -> StaticP ()
addOpt = liftEwM . SF.addOpt
addWay :: WayName -> StaticP ()
addWay = liftEwM . SF.addWay
removeOpt :: String -> StaticP ()
removeOpt = liftEwM . SF.removeOpt
-----------------------------------------------------------------------------
-- RTS Hooks
......
......@@ -497,24 +497,15 @@ mode_flags :: [Flag ModeM]
mode_flags =
[ ------- help / version ----------------------------------------------
Flag "?" (PassFlag (setMode showGhcUsageMode))
Supported
, Flag "-help" (PassFlag (setMode showGhcUsageMode))
Supported
, Flag "V" (PassFlag (setMode showVersionMode))
Supported
, Flag "-version" (PassFlag (setMode showVersionMode))
Supported
, Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))
Supported
, Flag "-info" (PassFlag (setMode showInfoMode))
Supported
, Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
Supported
, Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
Supported
] ++
[ Flag k' (PassFlag (setMode mode))
Supported
| (k, v) <- compilerInfo,
let k' = "-print-" ++ map (replaceSpace . toLower) k
replaceSpace ' ' = '-'
......@@ -526,33 +517,23 @@ mode_flags =
------- interfaces ----------------------------------------------------
[ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
"--show-iface"))
Supported
------- primary modes ------------------------------------------------
, Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
addFlag "-no-link" f))
Supported
, Flag "M" (PassFlag (setMode doMkDependHSMode))
Supported
, Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
Supported
, Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
addFlag "-fvia-C" f))
Supported
, Flag "S" (PassFlag (setMode (stopBeforeMode As)))
Supported
, Flag "-make" (PassFlag (setMode doMakeMode))
Supported
, Flag "-interactive" (PassFlag (setMode doInteractiveMode))
Supported
, Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))
Supported
, Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
Supported
]
setMode :: Mode -> String -> ModeM ()
setMode newMode newFlag = do
setMode :: Mode -> String -> EwM ModeM ()
setMode newMode newFlag = liftEwM $ do
(mModeFlag, errs, flags') <- getCmdLineState
let (modeFlag', errs') =
case mModeFlag of
......@@ -595,8 +576,8 @@ flagMismatchErr :: String -> String -> String
flagMismatchErr oldFlag newFlag
= "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
addFlag :: String -> String -> ModeM ()
addFlag s flag = do
addFlag :: String -> String -> EwM ModeM ()
addFlag s flag = liftEwM $ do
(m, e, flags') <- getCmdLineState
putCmdLineState (m, e, mkGeneralLocated loc s : flags')
where loc = "addFlag by " ++ flag ++ " on the commandline"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment