{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}

-------------------------------------------------------------------------------
--
-- | Command-line parser
--
-- This is an abstract command-line parser used by DynFlags.
--
-- (c) The University of Glasgow 2005
--
-------------------------------------------------------------------------------

module GHC.Driver.CmdLine
    (
      processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..),
      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag,
      errorsToGhcException,

      Err(..), Warn, warnsToMessages,

      EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM
    ) where

import GHC.Prelude

import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Data.Bag
import GHC.Types.SrcLoc
import GHC.Types.Error
import GHC.Utils.Error
import GHC.Driver.Errors.Types
import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage
import GHC.Utils.Outputable (text)

import Data.Function
import Data.List (sortBy, intercalate, stripPrefix)
import Data.Word

import GHC.ResponseFile
import Control.Exception (IOException, catch)
import Control.Monad (ap)
import Control.Monad.IO.Class

--------------------------------------------------------
--         The Flag and OptKind types
--------------------------------------------------------

data Flag m = Flag
    {   forall (m :: * -> *). Flag m -> String
flagName    :: String,     -- Flag, without the leading "-"
        forall (m :: * -> *). Flag m -> OptKind m
flagOptKind :: OptKind m,  -- What to do if we see it
        forall (m :: * -> *). Flag m -> GhcFlagMode
flagGhcMode :: GhcFlagMode    -- Which modes this flag affects
    }

defFlag :: String -> OptKind m -> Flag m
defFlag :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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 :: forall (m :: * -> *). 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

hoistFlag :: forall m n. (forall a. m a -> n a) -> Flag m -> Flag n
hoistFlag :: forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> Flag m -> Flag n
hoistFlag forall a. m a -> n a
f (Flag String
a OptKind m
b GhcFlagMode
c) = String -> OptKind n -> GhcFlagMode -> Flag n
forall (m :: * -> *). String -> OptKind m -> GhcFlagMode -> Flag m
Flag String
a (OptKind m -> OptKind n
go OptKind m
b) GhcFlagMode
c
  where
      go :: OptKind m -> OptKind n
go (NoArg EwM m ()
k)  = EwM n () -> OptKind n
forall (m :: * -> *). EwM m () -> OptKind m
NoArg (EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 EwM m ()
k)
      go (HasArg String -> EwM m ()
k) = (String -> EwM n ()) -> OptKind n
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
HasArg (\String
s -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (String -> EwM m ()
k String
s))
      go (SepArg String -> EwM m ()
k) = (String -> EwM n ()) -> OptKind n
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
SepArg (\String
s -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (String -> EwM m ()
k String
s))
      go (Prefix String -> EwM m ()
k) = (String -> EwM n ()) -> OptKind n
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
Prefix (\String
s -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (String -> EwM m ()
k String
s))
      go (OptPrefix String -> EwM m ()
k) = (String -> EwM n ()) -> OptKind n
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
OptPrefix (\String
s -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (String -> EwM m ()
k String
s))
      go (OptIntSuffix Maybe Int -> EwM m ()
k) = (Maybe Int -> EwM n ()) -> OptKind n
forall (m :: * -> *). (Maybe Int -> EwM m ()) -> OptKind m
OptIntSuffix (\Maybe Int
n -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (Maybe Int -> EwM m ()
k Maybe Int
n))
      go (IntSuffix Int -> EwM m ()
k) = (Int -> EwM n ()) -> OptKind n
forall (m :: * -> *). (Int -> EwM m ()) -> OptKind m
IntSuffix (\Int
n -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (Int -> EwM m ()
k Int
n))
      go (Word64Suffix Word64 -> EwM m ()
k) = (Word64 -> EwM n ()) -> OptKind n
forall (m :: * -> *). (Word64 -> EwM m ()) -> OptKind m
Word64Suffix (\Word64
s -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (Word64 -> EwM m ()
k Word64
s))
      go (FloatSuffix Float -> EwM m ()
k) = (Float -> EwM n ()) -> OptKind n
forall (m :: * -> *). (Float -> EwM m ()) -> OptKind m
FloatSuffix (\Float
s -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (Float -> EwM m ()
k Float
s))
      go (PassFlag String -> EwM m ()
k) = (String -> EwM n ()) -> OptKind n
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
PassFlag (\String
s -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (String -> EwM m ()
k String
s))
      go (AnySuffix String -> EwM m ()
k) = (String -> EwM n ()) -> OptKind n
forall (m :: * -> *). (String -> EwM m ()) -> OptKind m
AnySuffix (\String
s -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (String -> EwM m ()
k String
s))

      go2 :: EwM m a -> EwM n a
      go2 :: forall a. EwM m a -> EwM n a
go2 (EwM Located String -> Errs -> Warns -> m (Errs, Warns, a)
g) = (Located String -> Errs -> Warns -> n (Errs, Warns, a)) -> EwM n a
forall (m :: * -> *) a.
(Located String -> Errs -> Warns -> m (Errs, Warns, a)) -> EwM m a
EwM ((Located String -> Errs -> Warns -> n (Errs, Warns, a))
 -> EwM n a)
-> (Located String -> Errs -> Warns -> n (Errs, Warns, a))
-> EwM n a
forall a b. (a -> b) -> a -> b
$ \Located String
loc Errs
es Warns
ws -> m (Errs, Warns, a) -> n (Errs, Warns, a)
forall a. m a -> n a
f (Located String -> Errs -> Warns -> m (Errs, Warns, a)
g Located String
loc Errs
es Warns
ws)

-- | 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
    | Word64Suffix (Word64 -> 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
--------------------------------------------------------

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

-- | A command-line warning message and the reason it arose
--
-- This used to be own type, but now it's just @'MsgEnvelope' 'DriverMessage'@.
type Warn = Located DriverMessage

type Errs  = Bag Err
type Warns = [Warn]

-- EwM ("errors and warnings monad") is a monad
-- transformer for m that adds an (err, warn) state
newtype EwM m a = EwM { forall (m :: * -> *) a.
EwM m a -> Located String -> Errs -> Warns -> m (Errs, Warns, a)
unEwM :: Located String -- Current parse arg
                              -> Errs -> Warns
                              -> m (Errs, Warns, a) }
  deriving ((forall a b. (a -> b) -> EwM m a -> EwM m b)
-> (forall a b. a -> EwM m b -> EwM m a) -> Functor (EwM m)
forall a b. a -> EwM m b -> EwM m a
forall a b. (a -> b) -> EwM m a -> EwM m b
forall (m :: * -> *) a b. Functor m => a -> EwM m b -> EwM m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> EwM m a -> EwM m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> EwM m a -> EwM m b
fmap :: forall a b. (a -> b) -> EwM m a -> EwM m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> EwM m b -> EwM m a
<$ :: forall a b. a -> EwM m b -> EwM m a
Functor)

instance Monad m => Applicative (EwM m) where
    pure :: forall a. 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
e, Warns
w, a
v))
    <*> :: forall a b. 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) >>= :: forall a b. 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 (e', w', r) <- Located String -> Errs -> Warns -> m (Errs, Warns, a)
f Located String
l Errs
e Warns
w
                                      unEwM (k r) l e' w')
instance MonadIO m => MonadIO (EwM m) where
    liftIO :: forall a. IO a -> EwM m a
liftIO = m a -> EwM m a
forall (m :: * -> *) a. Monad m => m a -> EwM m a
liftEwM (m a -> EwM m a) -> (IO a -> m a) -> IO a -> EwM m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

runEwM :: EwM m a -> m (Errs, Warns, a)
runEwM :: forall (m :: * -> *) a. 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. HasCallStack => String -> a
panic String
"processArgs: no arg yet") Errs
forall a. Bag a
emptyBag Warns
forall a. Monoid a => a
mempty

setArg :: Located String -> EwM m () -> EwM m ()
setArg :: forall (m :: * -> *). 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 :: forall (m :: * -> *). Monad m => 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 a. a -> m a
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 :: forall (m :: * -> *). Monad m => String -> EwM m ()
addWarn String
msg = DriverMessage -> EwM m ()
forall (m :: * -> *). Monad m => DriverMessage -> EwM m ()
addFlagWarn (DriverMessage -> EwM m ()) -> DriverMessage -> EwM m ()
forall a b. (a -> b) -> a -> b
$ UnknownDiagnostic (DiagnosticOpts DriverMessage) -> DriverMessage
DriverUnknownMessage (UnknownDiagnostic (DiagnosticOpts DriverMessage) -> DriverMessage)
-> UnknownDiagnostic (DiagnosticOpts DriverMessage)
-> DriverMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage
-> UnknownDiagnostic (DiagnosticOpts DriverMessage)
forall a b.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> UnknownDiagnostic b
mkSimpleUnknownDiagnostic (DiagnosticMessage
 -> UnknownDiagnostic (DiagnosticOpts DriverMessage))
-> DiagnosticMessage
-> UnknownDiagnostic (DiagnosticOpts DriverMessage)
forall a b. (a -> b) -> a -> b
$
  DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
WarningWithoutFlag [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
msg

addFlagWarn :: Monad m => DriverMessage -> EwM m ()
addFlagWarn :: forall (m :: * -> *). Monad m => DriverMessage -> EwM m ()
addFlagWarn DriverMessage
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
  (\(L SrcSpan
loc String
_) Errs
es Warns
ws -> (Errs, Warns, ()) -> m (Errs, Warns, ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es, SrcSpan -> DriverMessage -> GenLocated SrcSpan DriverMessage
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc DriverMessage
msg GenLocated SrcSpan DriverMessage -> Warns -> Warns
forall a. a -> [a] -> [a]
: Warns
ws, ()))

getArg :: Monad m => EwM m String
getArg :: forall (m :: * -> *). Monad m => 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es, Warns
ws, String
arg))

getCurLoc :: Monad m => EwM m SrcSpan
getCurLoc :: forall (m :: * -> *). Monad m => 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es, Warns
ws, SrcSpan
loc))

liftEwM :: Monad m => m a -> EwM m a
liftEwM :: forall (m :: * -> *) a. Monad m => 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 { r <- m a
action; return (es, ws, r) })

warnsToMessages :: DiagOpts -> [Warn] -> Messages DriverMessage
warnsToMessages :: DiagOpts -> Warns -> Messages DriverMessage
warnsToMessages DiagOpts
diag_opts = (GenLocated SrcSpan DriverMessage
 -> Messages DriverMessage -> Messages DriverMessage)
-> Messages DriverMessage -> Warns -> Messages DriverMessage
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
  (\(L SrcSpan
loc DriverMessage
w) Messages DriverMessage
ws -> MsgEnvelope DriverMessage
-> Messages DriverMessage -> Messages DriverMessage
forall e. MsgEnvelope e -> Messages e -> Messages e
addMessage (DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
loc DriverMessage
w) Messages DriverMessage
ws)
  Messages DriverMessage
forall e. Messages e
emptyMessages

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

processArgs :: Monad m
            => [Flag m]               -- ^ cmdline parser spec
            -> [Located String]       -- ^ args
            -> (FilePath -> EwM m [Located String]) -- ^ response file handler
            -> m ( [Located String],  -- spare args
                   [Err],  -- errors
                   Warns ) -- warnings
processArgs :: forall (m :: * -> *).
Monad m =>
[Flag m]
-> [Located String]
-> (String -> EwM m [Located String])
-> m ([Located String], [Err], Warns)
processArgs [Flag m]
spec [Located String]
args String -> EwM m [Located String]
handleRespFile = do
    (errs, warns, 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
    return (spare, bagToList errs, 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 a. a -> EwM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Located String] -> [Located String]
forall a. [a] -> [a]
reverse [Located String]
spare)

    process (L SrcSpan
_ (Char
'@' : String
resp_file) : [Located String]
args) [Located String]
spare = do
        resp_args <- String -> EwM m [Located String]
handleRespFile String
resp_file
        process (resp_args ++ args) 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 a b. EwM m a -> EwM m b -> EwM m b
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 a b. EwM m a -> EwM m b -> EwM m b
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 :: 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
  = let dash_arg :: String
dash_arg = Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
: String
arg
        rest_no_eq :: String
rest_no_eq = String -> String
dropEq String
rest
    in case OptKind m
opt_kind of
        NoArg  EwM m ()
a -> Bool
-> ((EwM m (), [Located String])
    -> Either String (EwM m (), [Located String]))
-> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a. HasCallStack => Bool -> a -> a
assert (String -> Bool
forall a. [a] -> 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 (EwM m ()
a, [Located String]
args)

        HasArg String -> EwM m ()
f | String -> Bool
forall (f :: * -> *) a. Foldable f => f 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 (f :: * -> *) a. Foldable f => f 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 (f :: * -> *) a. Foldable f => f 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 a. [a] -> 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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dash_arg)

        Word64Suffix Word64 -> EwM m ()
f | Just Word64
n <- String -> Maybe Word64
parseWord64 String
rest_no_eq -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (Word64 -> EwM m ()
f Word64
n, [Located String]
args)
                     | Bool
otherwise -> String -> Either String (EwM m (), [Located String])
forall a b. a -> Either a b
Left (String
"malformed natural argument in " String -> String -> String
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 -> String -> String
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 :: forall (m :: * -> *).
[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 a. [a] -> 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
           [ (String -> String
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 :: forall (t :: * -> *). OptKind t -> String -> String -> Bool
arg_ok (NoArg           EwM t ()
_)  String
rest String
_   = String -> Bool
forall a. [a] -> 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 a. [a] -> 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 (Word64Suffix    Word64 -> 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 a. [a] -> 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

parseWord64 :: String -> Maybe Word64
parseWord64 :: String -> Maybe Word64
parseWord64 String
s = case ReadS Word64
forall a. Read a => ReadS a
reads String
s of
                 ((Word64
n,String
""):[(Word64, String)]
_) -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
n
                 [(Word64, String)]
_          -> Maybe Word64
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 :: String -> String
dropEq (Char
'=' : String
s) = String
s
dropEq String
s         = String
s

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

missingArgErr :: String -> Either String a
missingArgErr :: forall a. 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f)

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

-- | Parse a response file into arguments.
parseResponseFile :: MonadIO m => FilePath -> EwM m [Located String]
parseResponseFile :: forall (m :: * -> *). MonadIO m => String -> EwM m [Located String]
parseResponseFile String
path = do
  res <- IO (Either IOException String) -> EwM m (Either IOException String)
forall a. IO a -> EwM m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException String)
 -> EwM m (Either IOException String))
-> IO (Either IOException String)
-> EwM m (Either IOException String)
forall a b. (a -> b) -> a -> b
$ (String -> Either IOException String)
-> IO String -> IO (Either IOException String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Either IOException String
forall a b. b -> Either a b
Right (String -> IO String
readFile String
path) IO (Either IOException String)
-> (IOException -> IO (Either IOException String))
-> IO (Either IOException String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
    \(IOException
e :: IOException) -> Either IOException String -> IO (Either IOException String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IOException -> Either IOException String
forall a b. a -> Either a b
Left IOException
e)
  case res of
    Left IOException
_err -> String -> EwM m ()
forall (m :: * -> *). Monad m => String -> EwM m ()
addErr String
"Could not open response file" EwM m () -> EwM m [Located String] -> EwM m [Located String]
forall a b. EwM m a -> EwM m b -> EwM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Located String] -> EwM m [Located String]
forall a. a -> EwM m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Right String
resp_file -> [Located String] -> EwM m [Located String]
forall a. a -> EwM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Located String] -> EwM m [Located String])
-> [Located String] -> EwM m [Located String]
forall a b. (a -> b) -> a -> b
$ (String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Located String
forall e. String -> e -> Located e
mkGeneralLocated String
path) (String -> [String]
unescapeArgs String
resp_file)

-- See Note [Handling errors when parsing command-line 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 -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e | (String
l, String
e) <- [(String, String)]
errs ]

{- Note [Handling errors when parsing command-line 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).
-}