diff options
Diffstat (limited to 'compiler/GHC/Driver/CmdLine.hs')
| -rw-r--r-- | compiler/GHC/Driver/CmdLine.hs | 339 |
1 files changed, 339 insertions, 0 deletions
diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs new file mode 100644 index 0000000000..9b71e3d3fb --- /dev/null +++ b/compiler/GHC/Driver/CmdLine.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +------------------------------------------------------------------------------- +-- +-- | Command-line parser +-- +-- This is an abstract command-line parser used by DynFlags. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.CmdLine + ( + 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). +-} |