{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
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 ()
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
data Flag m = Flag
{ forall (m :: * -> *). Flag m -> String
flagName :: String,
forall (m :: * -> *). Flag m -> OptKind m
flagOptKind :: OptKind m,
forall (m :: * -> *). Flag m -> GhcFlagMode
flagGhcMode :: GhcFlagMode
}
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)
data GhcFlagMode
= OnlyGhc
| OnlyGhci
| AllModes
| HiddenFlag
data OptKind m
= NoArg (EwM m ())
| HasArg (String -> EwM m ())
| SepArg (String -> EwM m ())
| Prefix (String -> EwM m ())
| OptPrefix (String -> EwM m ())
| OptIntSuffix (Maybe Int -> EwM m ())
| IntSuffix (Int -> EwM m ())
| Word64Suffix (Word64 -> EwM m ())
| FloatSuffix (Float -> EwM m ())
| PassFlag (String -> EwM m ())
| AnySuffix (String -> EwM m ())
newtype Err = Err { Err -> Located String
errMsg :: Located String }
type Warn = Located DriverMessage
type Errs = Bag Err
type Warns = [Warn]
newtype EwM m a = EwM { forall (m :: * -> *) a.
EwM m a -> Located String -> Errs -> Warns -> m (Errs, Warns, a)
unEwM :: Located String
-> 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
processArgs :: Monad m
=> [Flag m]
-> [Located String]
-> (FilePath -> EwM m [Located String])
-> m ( [Located String],
[Err],
Warns )
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]
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)
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)
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))
[ (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
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
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
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)
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)
errorsToGhcException :: [(String,
String)]
-> 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 ]