X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FCmdLineParser.hs;h=67515e53a16b0419bda3999beb7743a82146aec7;hp=d68e6f78e29de2eb8546e9aa422925850cdb7aee;hb=d2f11ea842a25bebd51d6c0c730a756c1d987e25;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index d68e6f7..67515e5 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -9,129 +9,212 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details - module CmdLineParser ( - processArgs, OptKind(..), - CmdLineP(..), getCmdLineState, putCmdLineState + processArgs, OptKind(..), + CmdLineP(..), getCmdLineState, putCmdLineState, + Flag(..), + errorsToGhcException, + + EwM, addErr, addWarn, getArg, liftEwM, deprecate ) where #include "HsVersions.h" -import Util ( maybePrefixMatch, notNull, removeSpaces ) -#ifdef DEBUG -import Panic ( assertPanic ) -#endif - -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 ()) - +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 + } + +------------------------------- +data OptKind m -- Suppose the flag is -f + = 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 - => [(String, OptKind m)] -- cmdline parser spec - -> [String] -- args - -> m ( - [String], -- spare args - [String] -- errors - ) -processArgs spec args = process spec args [] [] + => [Flag m] -- cmdline parser spec + -> [Located String] -- args + -> m ( + [Located String], -- spare args + [Located String], -- errors + [Located String] -- warnings + ) +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 = - return (reverse spare, reverse errs) - - process spec (dash_arg@('-':arg):args) spare errs = + -- process :: [Located String] -> [Located String] -> EwM m [Located String] + process [] spare = return (reverse spare) + + process (locArg@(L _ ('-' : arg)) : args) spare = 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]) -processOneArg action rest arg args + 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 (EwM m (), [Located String]) +processOneArg opt_kind rest arg args = let dash_arg = '-' : arg - rest_no_eq = dropEq rest - in case action of - NoArg a -> ASSERT(null rest) Right (a, args) + rest_no_eq = dropEq rest + 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) + | otherwise -> case args of + [] -> missingArgErr dash_arg + (L _ 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 + [] -> unknownFlagErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) - SepArg f -> case args of - [] -> unknownFlagErr dash_arg - (arg1:args1) -> Right (f arg1, args1) + Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> unknownFlagErr dash_arg - Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> unknownFlagErr dash_arg - - PrefixPred p f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> unknownFlagErr dash_arg - - PassFlag f | notNull rest -> unknownFlagErr dash_arg - | otherwise -> Right (f dash_arg, args) + PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> unknownFlagErr dash_arg - 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) + PassFlag f | notNull rest -> unknownFlagErr dash_arg + | otherwise -> 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) + 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) - OptPrefix f -> Right (f rest_no_eq, args) - AnySuffix f -> Right (f dash_arg, args) - 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) + OptPrefix f -> Right (f rest_no_eq, args) + AnySuffix f -> Right (f dash_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) findArg spec arg - = case [ (removeSpaces rest, k) - | (pat,k) <- spec, - Just rest <- [maybePrefixMatch pat arg], - arg_ok k rest arg ] + = case [ (removeSpaces rest, optKind) + | flag <- spec, + let optKind = flagOptKind flag, + Just rest <- [stripPrefix (flagName flag) arg], + arg_ok optKind rest arg ] of - [] -> Nothing - (one:_) -> Just one - -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 (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 + [] -> Nothing + (one:_) -> Just one + +arg_ok :: OptKind t -> [Char] -> String -> Bool +arg_ok (NoArg _) rest _ = null rest +arg_ok (HasArg _) _ _ = True +arg_ok (SepArg _) rest _ = null rest +arg_ok (Prefix _) rest _ = notNull rest +arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest) +arg_ok (OptIntSuffix _) _ _ = True +arg_ok (IntSuffix _) _ _ = True +arg_ok (OptPrefix _) _ _ = True +arg_ok (PassFlag _) rest _ = null rest +arg_ok (AnySuffix _) _ _ = True +arg_ok (AnySuffixPred p _) _ arg = p arg parseInt :: String -> Maybe Int -- Looks for "433" or "=342", with no trailing gubbins --- n or =n => Just n +-- n or =n => Just n -- gibberish => Nothing parseInt s = case reads s of - ((n,""):_) -> Just n - other -> Nothing + ((n,""):_) -> Just n + _ -> Nothing dropEq :: String -> String -- Discards a leading equals sign @@ -144,16 +227,11 @@ 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) } +-- --------------------------------------------------------------------- +-- Utils -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' +errorsToGhcException :: [Located String] -> GhcException +errorsToGhcException errs = + let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ] + in UsageError (showSDoc $ withPprStyle cmdlineParserStyle errors) -getCmdLineState = CmdLineP $ \s -> (s,s) -putCmdLineState s = CmdLineP $ \_ -> ((),s)