diff options
Diffstat (limited to 'compiler/main/CmdLineParser.hs')
| -rw-r--r-- | compiler/main/CmdLineParser.hs | 339 |
1 files changed, 0 insertions, 339 deletions
diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs deleted file mode 100644 index d2cc56f033..0000000000 --- a/compiler/main/CmdLineParser.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} - -------------------------------------------------------------------------------- --- --- | Command-line parser --- --- This is an abstract command-line parser used by DynFlags. --- --- (c) The University of Glasgow 2005 --- -------------------------------------------------------------------------------- - -module CmdLineParser - ( - processArgs, OptKind(..), GhcFlagMode(..), - CmdLineP(..), getCmdLineState, putCmdLineState, - Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, - errorsToGhcException, - - Err(..), Warn(..), WarnReason(..), - - EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, - deprecate - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Util -import Outputable -import Panic -import Bag -import SrcLoc -import Json - -import Data.Function -import Data.List - -import Control.Monad (liftM, ap) - --------------------------------------------------------- --- 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 - flagGhcMode :: GhcFlagMode -- Which modes this flag affects - } - -defFlag :: String -> OptKind m -> Flag m -defFlag name optKind = Flag name optKind AllModes - -defGhcFlag :: String -> OptKind m -> Flag m -defGhcFlag name optKind = Flag name optKind OnlyGhc - -defGhciFlag :: String -> OptKind m -> Flag m -defGhciFlag name optKind = Flag name optKind OnlyGhci - -defHiddenFlag :: String -> OptKind m -> Flag m -defHiddenFlag name optKind = Flag name optKind HiddenFlag - --- | GHC flag modes describing when a flag has an effect. -data GhcFlagMode - = OnlyGhc -- ^ The flag only affects the non-interactive GHC - | OnlyGhci -- ^ The flag only affects the interactive GHC - | AllModes -- ^ The flag affects multiple ghc modes - | HiddenFlag -- ^ This flag should not be seen in cli completion - -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 - | FloatSuffix (Float -> 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 - - --------------------------------------------------------- --- The EwM monad --------------------------------------------------------- - --- | Used when filtering warnings: if a reason is given --- it can be filtered out when displaying. -data WarnReason - = NoReason - | ReasonDeprecatedFlag - | ReasonUnrecognisedFlag - deriving (Eq, Show) - -instance Outputable WarnReason where - ppr = text . show - -instance ToJson WarnReason where - json NoReason = JSNull - json reason = JSString $ show reason - --- | A command-line error message -newtype Err = Err { errMsg :: Located String } - --- | A command-line warning message and the reason it arose -data Warn = Warn - { warnReason :: WarnReason, - warnMsg :: Located String - } - -type Errs = Bag Err -type Warns = Bag Warn - --- EwM ("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 parse arg - -> Errs -> Warns - -> m (Errs, Warns, a) } - -instance Monad m => Functor (EwM m) where - fmap = liftM - -instance Monad m => Applicative (EwM m) where - pure v = EwM (\_ e w -> return (e, w, v)) - (<*>) = ap - -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') - -runEwM :: EwM m a -> m (Errs, Warns, a) -runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag - -setArg :: Located String -> EwM m () -> EwM m () -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` Err (L loc e), ws, ())) - -addWarn :: Monad m => String -> EwM m () -addWarn = addFlagWarn NoReason - -addFlagWarn :: Monad m => WarnReason -> String -> EwM m () -addFlagWarn reason msg = EwM $ - (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) - -deprecate :: Monad m => String -> EwM m () -deprecate s = do - arg <- getArg - addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s) - -getArg :: Monad m => EwM m String -getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) - -getCurLoc :: Monad m => EwM m SrcSpan -getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) - -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) } - deriving (Functor) - -instance Applicative (CmdLineP s) where - pure a = CmdLineP $ \s -> (a, s) - (<*>) = ap - -instance Monad (CmdLineP s) where - 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 - -> [Located String] -- args - -> m ( [Located String], -- spare args - [Err], -- errors - [Warn] ) -- warnings -processArgs spec args = do - (errs, warns, spare) <- runEwM action - return (spare, bagToList errs, bagToList warns) - where - action = process args [] - - -- 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, opt_kind) -> - case processOneArg opt_kind rest arg args of - Left err -> - let b = process args spare - in (setArg locArg $ addErr err) >> b - - Right (action,rest) -> - let b = process rest spare - in (setArg locArg $ action) >> b - - 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 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) - - -- See #9776 - SepArg f -> case args of - [] -> missingArgErr dash_arg - (L _ arg1:args1) -> Right (f arg1, args1) - - -- See #12625 - Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> missingArgErr dash_arg - - PassFlag f | notNull rest -> unknownFlagErr dash_arg - | otherwise -> 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) - - IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) - | otherwise -> Left ("malformed integer argument in " ++ dash_arg) - - FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) - | otherwise -> Left ("malformed float argument in " ++ dash_arg) - - OptPrefix f -> Right (f rest_no_eq, args) - AnySuffix f -> Right (f dash_arg, args) - -findArg :: [Flag m] -> String -> Maybe (String, OptKind m) -findArg spec arg = - case sortBy (compare `on` (length . fst)) -- prefer longest matching flag - [ (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 :: OptKind t -> [Char] -> String -> Bool -arg_ok (NoArg _) rest _ = null rest -arg_ok (HasArg _) _ _ = True -arg_ok (SepArg _) rest _ = null rest -arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t - -- to improve error message (#12625) -arg_ok (OptIntSuffix _) _ _ = True -arg_ok (IntSuffix _) _ _ = True -arg_ok (FloatSuffix _) _ _ = True -arg_ok (OptPrefix _) _ _ = True -arg_ok (PassFlag _) rest _ = null rest -arg_ok (AnySuffix _) _ _ = True - --- | Parse an Int --- --- Looks for "433" or "=342", with no trailing gubbins --- * n or =n => Just n --- * gibberish => Nothing -parseInt :: String -> Maybe Int -parseInt s = case reads s of - ((n,""):_) -> Just n - _ -> Nothing - -parseFloat :: String -> Maybe Float -parseFloat s = case reads s of - ((n,""):_) -> Just n - _ -> Nothing - --- | Discards a leading equals sign -dropEq :: String -> String -dropEq ('=' : s) = s -dropEq s = s - -unknownFlagErr :: String -> Either String a -unknownFlagErr f = Left ("unrecognised flag: " ++ f) - -missingArgErr :: String -> Either String a -missingArgErr f = Left ("missing argument for flag: " ++ f) - --------------------------------------------------------- --- Utils --------------------------------------------------------- - - --- See Note [Handling errors when parsing flags] -errorsToGhcException :: [(String, -- Location - String)] -- Error - -> GhcException -errorsToGhcException errs = - UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] - -{- Note [Handling errors when parsing commandline flags] - -Parsing of static and mode flags happens before any session is started, i.e., -before the first call to 'GHC.withGhc'. Therefore, to report errors for -invalid usage of these two types of flags, we can not call any function that -needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags -is not set either). So we always print "on the commandline" as the location, -which is true except for Api users, which is probably ok. - -When reporting errors for invalid usage of dynamic flags we /can/ make use of -DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. - -Before, we called unsafeGlobalDynFlags when an invalid (combination of) -flag(s) was given on the commandline, resulting in panics (#9963). --} |