{-# 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
    {   Flag m -> String
flagName    :: String,     -- Flag, without the leading "-"
        Flag m -> OptKind m
flagOptKind :: OptKind m,  -- What to do if we see it
        Flag m -> GhcFlagMode
flagGhcMode :: GhcFlagMode    -- Which modes this flag affects
    }

defFlag :: String -> OptKind m -> Flag m
defFlag :: String -> OptKind m -> Flag m
defFlag String
name OptKind m
optKind = String -> OptKind m -> GhcFlagMode -> Flag m
forall (m :: * -> *). String -> OptKind m -> GhcFlagMode -> Flag m
Flag String
name OptKind m
optKind GhcFlagMode
AllModes

defGhcFlag :: String -> OptKind m -> Flag m
defGhcFlag :: String -> OptKind m -> Flag m
defGhcFlag String
name OptKind m
optKind = String -> OptKind m -> GhcFlagMode -> Flag m
forall (m :: * -> *). String -> OptKind m -> GhcFlagMode -> Flag m
Flag String
name OptKind m
optKind GhcFlagMode
OnlyGhc

defGhciFlag :: String -> OptKind m -> Flag m
defGhciFlag :: String -> OptKind m -> Flag m
defGhciFlag String
name OptKind m
optKind = String -> OptKind m -> GhcFlagMode -> Flag m
forall (m :: * -> *). String -> OptKind m -> GhcFlagMode -> Flag m
Flag String
name OptKind m
optKind GhcFlagMode
OnlyGhci

defHiddenFlag :: String -> OptKind m -> Flag m
defHiddenFlag :: String -> OptKind m -> Flag m
defHiddenFlag String
name OptKind m
optKind = String -> OptKind m -> GhcFlagMode -> Flag m
forall (m :: * -> *). String -> OptKind m -> GhcFlagMode -> Flag m
Flag String
name OptKind m
optKind GhcFlagMode
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 (WarnReason -> WarnReason -> Bool
(WarnReason -> WarnReason -> Bool)
-> (WarnReason -> WarnReason -> Bool) -> Eq WarnReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WarnReason -> WarnReason -> Bool
$c/= :: WarnReason -> WarnReason -> Bool
== :: WarnReason -> WarnReason -> Bool
$c== :: WarnReason -> WarnReason -> Bool
Eq, Int -> WarnReason -> ShowS
[WarnReason] -> ShowS
WarnReason -> String
(Int -> WarnReason -> ShowS)
-> (WarnReason -> String)
-> ([WarnReason] -> ShowS)
-> Show WarnReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WarnReason] -> ShowS
$cshowList :: [WarnReason] -> ShowS
show :: WarnReason -> String
$cshow :: WarnReason -> String
showsPrec :: Int -> WarnReason -> ShowS
$cshowsPrec :: Int -> WarnReason -> ShowS
Show)

instance Outputable WarnReason where
  ppr :: WarnReason -> SDoc
ppr = String -> SDoc
text (String -> SDoc) -> (WarnReason -> String) -> WarnReason -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarnReason -> String
forall a. Show a => a -> String
show

instance ToJson WarnReason where
  json :: WarnReason -> JsonDoc
json WarnReason
NoReason = JsonDoc
JSNull
  json WarnReason
reason   = String -> JsonDoc
JSString (String -> JsonDoc) -> String -> JsonDoc
forall a b. (a -> b) -> a -> b
$ WarnReason -> String
forall a. Show a => a -> String
show WarnReason
reason

-- | A command-line error message
newtype Err  = Err { Err -> Located String
errMsg :: Located String }

-- | A command-line warning message and the reason it arose
data Warn = Warn
  {   Warn -> WarnReason
warnReason :: WarnReason,
      Warn -> Located String
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 { EwM m a -> Located String -> Errs -> Warns -> m (Errs, Warns, a)
unEwM :: Located String -- Current parse arg
                              -> Errs -> Warns
                              -> m (Errs, Warns, a) }

instance Monad m => Functor (EwM m) where
    fmap :: (a -> b) -> EwM m a -> EwM m b
fmap = (a -> b) -> EwM m a -> EwM m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Monad m => Applicative (EwM m) where
    pure :: a -> EwM m a
pure a
v = (Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
forall (m :: * -> *) a.
(Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
EwM (\Located String
_ Errs
e Warns
w -> (Errs, Warns, a) -> m (Errs, Warns, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
e, Warns
w, a
v))
    <*> :: EwM m (a -> b) -> EwM m a -> EwM m b
(<*>) = EwM m (a -> b) -> EwM m a -> EwM m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (EwM m) where
    (EwM Located String -> Errs -> Warns -> m (Errs, Warns, a)
f) >>= :: EwM m a -> (a -> EwM m b) -> EwM m b
>>= a -> EwM m b
k = (Located String -> Errs -> Warns -> m (Errs, Warns, b)) -> EwM m b
forall (m :: * -> *) a.
(Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
EwM (\Located String
l Errs
e Warns
w -> do (Errs
e', Warns
w', a
r) <- Located String -> Errs -> Warns -> m (Errs, Warns, a)
f Located String
l Errs
e Warns
w
                                      EwM m b -> Located String -> Errs -> Warns -> m (Errs, Warns, b)
forall (m :: * -> *) a.
EwM m a -> Located String -> Errs -> Warns -> m (Errs, Warns, a)
unEwM (a -> EwM m b
k a
r) Located String
l Errs
e' Warns
w')

runEwM :: EwM m a -> m (Errs, Warns, a)
runEwM :: EwM m a -> m (Errs, Warns, a)
runEwM EwM m a
action = EwM m a -> Located String -> Errs -> Warns -> m (Errs, Warns, a)
forall (m :: * -> *) a.
EwM m a -> Located String -> Errs -> Warns -> m (Errs, Warns, a)
unEwM EwM m a
action (String -> Located String
forall a. String -> a
panic String
"processArgs: no arg yet") Errs
forall a. Bag a
emptyBag Warns
forall a. Bag a
emptyBag

setArg :: Located String -> EwM m () -> EwM m ()
setArg :: Located String -> EwM m () -> EwM m ()
setArg Located String
l (EwM Located String -> Errs -> Warns -> m (Errs, Warns, ())
f) = (Located String -> Errs -> Warns -> m (Errs, Warns, ()))
-> EwM m ()
forall (m :: * -> *) a.
(Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
EwM (\Located String
_ Errs
es Warns
ws -> Located String -> Errs -> Warns -> m (Errs, Warns, ())
f Located String
l Errs
es Warns
ws)

addErr :: Monad m => String -> EwM m ()
addErr :: String -> EwM m ()
addErr String
e = (Located String -> Errs -> Warns -> m (Errs, Warns, ()))
-> EwM m ()
forall (m :: * -> *) a.
(Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
EwM (\(L SrcSpan
loc String
_) Errs
es Warns
ws -> (Errs, Warns, ()) -> m (Errs, Warns, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es Errs -> Err -> Errs
forall a. Bag a -> a -> Bag a
`snocBag` Located String -> Err
Err (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc String
e), Warns
ws, ()))

addWarn :: Monad m => String -> EwM m ()
addWarn :: String -> EwM m ()
addWarn = WarnReason -> String -> EwM m ()
forall (m :: * -> *). Monad m => WarnReason -> String -> EwM m ()
addFlagWarn WarnReason
NoReason

addFlagWarn :: Monad m => WarnReason -> String -> EwM m ()
addFlagWarn :: WarnReason -> String -> EwM m ()
addFlagWarn WarnReason
reason String
msg = (Located String -> Errs -> Warns -> m (Errs, Warns, ()))
-> EwM m ()
forall (m :: * -> *) a.
(Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
EwM ((Located String -> Errs -> Warns -> m (Errs, Warns, ()))
 -> EwM m ())
-> (Located String -> Errs -> Warns -> m (Errs, Warns, ()))
-> EwM m ()
forall a b. (a -> b) -> a -> b
$
  (\(L SrcSpan
loc String
_) Errs
es Warns
ws -> (Errs, Warns, ()) -> m (Errs, Warns, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es, Warns
ws Warns -> Warn -> Warns
forall a. Bag a -> a -> Bag a
`snocBag` WarnReason -> Located String -> Warn
Warn WarnReason
reason (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc String
msg), ()))

deprecate :: Monad m => String -> EwM m ()
deprecate :: String -> EwM m ()
deprecate String
s = do
    String
arg <- EwM m String
forall (m :: * -> *). Monad m => EwM m String
getArg
    WarnReason -> String -> EwM m ()
forall (m :: * -> *). Monad m => WarnReason -> String -> EwM m ()
addFlagWarn WarnReason
ReasonDeprecatedFlag (String
arg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is deprecated: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s)

getArg :: Monad m => EwM m String
getArg :: EwM m String
getArg = (Located String -> Errs -> Warns -> m (Errs, Warns, String))
-> EwM m String
forall (m :: * -> *) a.
(Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
EwM (\(L SrcSpan
_ String
arg) Errs
es Warns
ws -> (Errs, Warns, String) -> m (Errs, Warns, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es, Warns
ws, String
arg))

getCurLoc :: Monad m => EwM m SrcSpan
getCurLoc :: EwM m SrcSpan
getCurLoc = (Located String -> Errs -> Warns -> m (Errs, Warns, SrcSpan))
-> EwM m SrcSpan
forall (m :: * -> *) a.
(Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
EwM (\(L SrcSpan
loc String
_) Errs
es Warns
ws -> (Errs, Warns, SrcSpan) -> m (Errs, Warns, SrcSpan)
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es, Warns
ws, SrcSpan
loc))

liftEwM :: Monad m => m a -> EwM m a
liftEwM :: m a -> EwM m a
liftEwM m a
action = (Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
forall (m :: * -> *) a.
(Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
EwM (\Located String
_ Errs
es Warns
ws -> do { a
r <- m a
action; (Errs, Warns, a) -> m (Errs, Warns, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es, Warns
ws, a
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 { CmdLineP s a -> s -> (a, s)
runCmdLine :: s -> (a, s) }
    deriving (a -> CmdLineP s b -> CmdLineP s a
(a -> b) -> CmdLineP s a -> CmdLineP s b
(forall a b. (a -> b) -> CmdLineP s a -> CmdLineP s b)
-> (forall a b. a -> CmdLineP s b -> CmdLineP s a)
-> Functor (CmdLineP s)
forall a b. a -> CmdLineP s b -> CmdLineP s a
forall a b. (a -> b) -> CmdLineP s a -> CmdLineP s b
forall s a b. a -> CmdLineP s b -> CmdLineP s a
forall s a b. (a -> b) -> CmdLineP s a -> CmdLineP s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CmdLineP s b -> CmdLineP s a
$c<$ :: forall s a b. a -> CmdLineP s b -> CmdLineP s a
fmap :: (a -> b) -> CmdLineP s a -> CmdLineP s b
$cfmap :: forall s a b. (a -> b) -> CmdLineP s a -> CmdLineP s b
Functor)

instance Applicative (CmdLineP s) where
    pure :: a -> CmdLineP s a
pure a
a = (s -> (a, s)) -> CmdLineP s a
forall s a. (s -> (a, s)) -> CmdLineP s a
CmdLineP ((s -> (a, s)) -> CmdLineP s a) -> (s -> (a, s)) -> CmdLineP s a
forall a b. (a -> b) -> a -> b
$ \s
s -> (a
a, s
s)
    <*> :: CmdLineP s (a -> b) -> CmdLineP s a -> CmdLineP s b
(<*>) = CmdLineP s (a -> b) -> CmdLineP s a -> CmdLineP s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (CmdLineP s) where
    CmdLineP s a
m >>= :: CmdLineP s a -> (a -> CmdLineP s b) -> CmdLineP s b
>>= a -> CmdLineP s b
k = (s -> (b, s)) -> CmdLineP s b
forall s a. (s -> (a, s)) -> CmdLineP s a
CmdLineP ((s -> (b, s)) -> CmdLineP s b) -> (s -> (b, s)) -> CmdLineP s b
forall a b. (a -> b) -> a -> b
$ \s
s ->
                  let (a
a, s
s') = CmdLineP s a -> s -> (a, s)
forall s a. CmdLineP s a -> s -> (a, s)
runCmdLine CmdLineP s a
m s
s
                  in CmdLineP s b -> s -> (b, s)
forall s a. CmdLineP s a -> s -> (a, s)
runCmdLine (a -> CmdLineP s b
k a
a) s
s'


getCmdLineState :: CmdLineP s s
getCmdLineState :: CmdLineP s s
getCmdLineState   = (s -> (s, s)) -> CmdLineP s s
forall s a. (s -> (a, s)) -> CmdLineP s a
CmdLineP ((s -> (s, s)) -> CmdLineP s s) -> (s -> (s, s)) -> CmdLineP s s
forall a b. (a -> b) -> a -> b
$ \s
s -> (s
s,s
s)
putCmdLineState :: s -> CmdLineP s ()
putCmdLineState :: s -> CmdLineP s ()
putCmdLineState s
s = (s -> ((), s)) -> CmdLineP s ()
forall s a. (s -> (a, s)) -> CmdLineP s a
CmdLineP ((s -> ((), s)) -> CmdLineP s ())
-> (s -> ((), s)) -> CmdLineP s ()
forall a b. (a -> b) -> a -> b
$ \s
_ -> ((),s
s)


--------------------------------------------------------
--         Processing arguments
--------------------------------------------------------

processArgs :: Monad m
            => [Flag m]               -- cmdline parser spec
            -> [Located String]       -- args
            -> m ( [Located String],  -- spare args
                   [Err],  -- errors
                   [Warn] ) -- warnings
processArgs :: [Flag m] -> [Located String] -> m ([Located String], [Err], [Warn])
processArgs [Flag m]
spec [Located String]
args = do
    (Errs
errs, Warns
warns, [Located String]
spare) <- EwM m [Located String] -> m (Errs, Warns, [Located String])
forall (m :: * -> *) a. EwM m a -> m (Errs, Warns, a)
runEwM EwM m [Located String]
action
    ([Located String], [Err], [Warn])
-> m ([Located String], [Err], [Warn])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Located String]
spare, Errs -> [Err]
forall a. Bag a -> [a]
bagToList Errs
errs, Warns -> [Warn]
forall a. Bag a -> [a]
bagToList Warns
warns)
  where
    action :: EwM m [Located String]
action = [Located String] -> [Located String] -> EwM m [Located String]
process [Located String]
args []

    -- process :: [Located String] -> [Located String] -> EwM m [Located String]
    process :: [Located String] -> [Located String] -> EwM m [Located String]
process [] [Located String]
spare = [Located String] -> EwM m [Located String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Located String] -> [Located String]
forall a. [a] -> [a]
reverse [Located String]
spare)

    process (locArg :: Located String
locArg@(L SrcSpan
_ (Char
'-' : String
arg)) : [Located String]
args) [Located String]
spare =
        case [Flag m] -> String -> Maybe (String, OptKind m)
forall (m :: * -> *).
[Flag m] -> String -> Maybe (String, OptKind m)
findArg [Flag m]
spec String
arg of
            Just (String
rest, OptKind m
opt_kind) ->
                case OptKind m
-> String
-> String
-> [Located String]
-> Either String (EwM m (), [Located String])
forall (m :: * -> *).
OptKind m
-> String
-> String
-> [Located String]
-> Either String (EwM m (), [Located String])
processOneArg OptKind m
opt_kind String
rest String
arg [Located String]
args of
                    Left String
err ->
                        let b :: EwM m [Located String]
b = [Located String] -> [Located String] -> EwM m [Located String]
process [Located String]
args [Located String]
spare
                        in (Located String -> EwM m () -> EwM m ()
forall (m :: * -> *). Located String -> EwM m () -> EwM m ()
setArg Located String
locArg (EwM m () -> EwM m ()) -> EwM m () -> EwM m ()
forall a b. (a -> b) -> a -> b
$ String -> EwM m ()
forall (m :: * -> *). Monad m => String -> EwM m ()
addErr String
err) EwM m () -> EwM m [Located String] -> EwM m [Located String]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EwM m [Located String]
b

                    Right (EwM m ()
action,[Located String]
rest) ->
                        let b :: EwM m [Located String]
b = [Located String] -> [Located String] -> EwM m [Located String]
process [Located String]
rest [Located String]
spare
                        in (Located String -> EwM m () -> EwM m ()
forall (m :: * -> *). Located String -> EwM m () -> EwM m ()
setArg Located String
locArg (EwM m () -> EwM m ()) -> EwM m () -> EwM m ()
forall a b. (a -> b) -> a -> b
$ EwM m ()
action) EwM m () -> EwM m [Located String] -> EwM m [Located String]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EwM m [Located String]
b

            Maybe (String, OptKind m)
Nothing -> [Located String] -> [Located String] -> EwM m [Located String]
process [Located String]
args (Located String
locArg Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
: [Located String]
spare)

    process (Located String
arg : [Located String]
args) [Located String]
spare = [Located String] -> [Located String] -> EwM m [Located String]
process [Located String]
args (Located String
arg Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
: [Located String]
spare)


processOneArg :: OptKind m -> String -> String -> [Located String]
              -> Either String (EwM m (), [Located String])
processOneArg :: OptKind m
-> String
-> String
-> [Located String]
-> Either String (EwM m (), [Located String])
processOneArg OptKind m
opt_kind String
rest String
arg [Located String]
args
  = let dash_arg :: String
dash_arg = Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: String
arg
        rest_no_eq :: String
rest_no_eq = ShowS
dropEq String
rest
    in case OptKind m
opt_kind of
        NoArg  EwM m ()
a -> ASSERT(null rest) Right (a, args)

        HasArg String -> EwM m ()
f | String -> Bool
forall a. [a] -> Bool
notNull String
rest_no_eq -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (String -> EwM m ()
f String
rest_no_eq, [Located String]
args)
                 | Bool
otherwise -> case [Located String]
args of
                                    []               -> String -> Either String (EwM m (), [Located String])
forall a. String -> Either String a
missingArgErr String
dash_arg
                                    (L SrcSpan
_ String
arg1:[Located String]
args1) -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (String -> EwM m ()
f String
arg1, [Located String]
args1)

        -- See #9776
        SepArg String -> EwM m ()
f -> case [Located String]
args of
                        []               -> String -> Either String (EwM m (), [Located String])
forall a. String -> Either String a
missingArgErr String
dash_arg
                        (L SrcSpan
_ String
arg1:[Located String]
args1) -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (String -> EwM m ()
f String
arg1, [Located String]
args1)

        -- See #12625
        Prefix String -> EwM m ()
f | String -> Bool
forall a. [a] -> Bool
notNull String
rest_no_eq -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (String -> EwM m ()
f String
rest_no_eq, [Located String]
args)
                 | Bool
otherwise          -> String -> Either String (EwM m (), [Located String])
forall a. String -> Either String a
missingArgErr  String
dash_arg

        PassFlag String -> EwM m ()
f  | String -> Bool
forall a. [a] -> Bool
notNull String
rest -> String -> Either String (EwM m (), [Located String])
forall a. String -> Either String a
unknownFlagErr String
dash_arg
                    | Bool
otherwise    -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (String -> EwM m ()
f String
dash_arg, [Located String]
args)

        OptIntSuffix Maybe Int -> EwM m ()
f | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest                     -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (Maybe Int -> EwM m ()
f Maybe Int
forall a. Maybe a
Nothing,  [Located String]
args)
                       | Just Int
n <- String -> Maybe Int
parseInt String
rest_no_eq -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (Maybe Int -> EwM m ()
f (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n), [Located String]
args)
                       | Bool
otherwise -> String -> Either String (EwM m (), [Located String])
forall a b. a -> Either a b
Left (String
"malformed integer argument in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dash_arg)

        IntSuffix Int -> EwM m ()
f | Just Int
n <- String -> Maybe Int
parseInt String
rest_no_eq -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (Int -> EwM m ()
f Int
n, [Located String]
args)
                    | Bool
otherwise -> String -> Either String (EwM m (), [Located String])
forall a b. a -> Either a b
Left (String
"malformed integer argument in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dash_arg)

        FloatSuffix Float -> EwM m ()
f | Just Float
n <- String -> Maybe Float
parseFloat String
rest_no_eq -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (Float -> EwM m ()
f Float
n, [Located String]
args)
                      | Bool
otherwise -> String -> Either String (EwM m (), [Located String])
forall a b. a -> Either a b
Left (String
"malformed float argument in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dash_arg)

        OptPrefix String -> EwM m ()
f       -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (String -> EwM m ()
f String
rest_no_eq, [Located String]
args)
        AnySuffix String -> EwM m ()
f       -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (String -> EwM m ()
f String
dash_arg, [Located String]
args)

findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
findArg :: [Flag m] -> String -> Maybe (String, OptKind m)
findArg [Flag m]
spec String
arg =
    case ((String, OptKind m) -> (String, OptKind m) -> Ordering)
-> [(String, OptKind m)] -> [(String, OptKind m)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((String, OptKind m) -> Int)
-> (String, OptKind m)
-> (String, OptKind m)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, OptKind m) -> String) -> (String, OptKind m) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, OptKind m) -> String
forall a b. (a, b) -> a
fst)) -- prefer longest matching flag
           [ (ShowS
removeSpaces String
rest, OptKind m
optKind)
           | Flag m
flag <- [Flag m]
spec,
             let optKind :: OptKind m
optKind  = Flag m -> OptKind m
forall (m :: * -> *). Flag m -> OptKind m
flagOptKind Flag m
flag,
             Just String
rest <- [String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (Flag m -> String
forall (m :: * -> *). Flag m -> String
flagName Flag m
flag) String
arg],
             OptKind m -> String -> String -> Bool
forall (t :: * -> *). OptKind t -> String -> String -> Bool
arg_ok OptKind m
optKind String
rest String
arg ]
    of
        []      -> Maybe (String, OptKind m)
forall a. Maybe a
Nothing
        ((String, OptKind m)
one:[(String, OptKind m)]
_) -> (String, OptKind m) -> Maybe (String, OptKind m)
forall a. a -> Maybe a
Just (String, OptKind m)
one

arg_ok :: OptKind t -> [Char] -> String -> Bool
arg_ok :: OptKind t -> String -> String -> Bool
arg_ok (NoArg           EwM t ()
_)  String
rest String
_   = String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest
arg_ok (HasArg          String -> EwM t ()
_)  String
_    String
_   = Bool
True
arg_ok (SepArg          String -> EwM t ()
_)  String
rest String
_   = String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest
arg_ok (Prefix          String -> EwM t ()
_)  String
_    String
_   = Bool
True -- Missing argument checked for in processOneArg t
                                            -- to improve error message (#12625)
arg_ok (OptIntSuffix    Maybe Int -> EwM t ()
_)  String
_    String
_   = Bool
True
arg_ok (IntSuffix       Int -> EwM t ()
_)  String
_    String
_   = Bool
True
arg_ok (FloatSuffix     Float -> EwM t ()
_)  String
_    String
_   = Bool
True
arg_ok (OptPrefix       String -> EwM t ()
_)  String
_    String
_   = Bool
True
arg_ok (PassFlag        String -> EwM t ()
_)  String
rest String
_   = String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest
arg_ok (AnySuffix       String -> EwM t ()
_)  String
_    String
_   = Bool
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 :: String -> Maybe Int
parseInt String
s = case ReadS Int
forall a. Read a => ReadS a
reads String
s of
                 ((Int
n,String
""):[(Int, String)]
_) -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
                 [(Int, String)]
_          -> Maybe Int
forall a. Maybe a
Nothing

parseFloat :: String -> Maybe Float
parseFloat :: String -> Maybe Float
parseFloat String
s = case ReadS Float
forall a. Read a => ReadS a
reads String
s of
                   ((Float
n,String
""):[(Float, String)]
_) -> Float -> Maybe Float
forall a. a -> Maybe a
Just Float
n
                   [(Float, String)]
_          -> Maybe Float
forall a. Maybe a
Nothing

-- | Discards a leading equals sign
dropEq :: String -> String
dropEq :: ShowS
dropEq (Char
'=' : String
s) = String
s
dropEq String
s         = String
s

unknownFlagErr :: String -> Either String a
unknownFlagErr :: String -> Either String a
unknownFlagErr String
f = String -> Either String a
forall a b. a -> Either a b
Left (String
"unrecognised flag: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f)

missingArgErr :: String -> Either String a
missingArgErr :: String -> Either String a
missingArgErr String
f = String -> Either String a
forall a b. a -> Either a b
Left (String
"missing argument for flag: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f)

--------------------------------------------------------
-- Utils
--------------------------------------------------------


-- See Note [Handling errors when parsing flags]
errorsToGhcException :: [(String,    -- Location
                          String)]   -- Error
                     -> GhcException
errorsToGhcException :: [(String, String)] -> GhcException
errorsToGhcException [(String, String)]
errs =
    String -> GhcException
UsageError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e | (String
l, String
e) <- [(String, String)]
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).
-}