{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
module GHC.Driver.CmdLine
(
processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..),
Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag,
errorsToGhcException,
Err(..), Warn(..), WarnReason(..),
EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM
) where
import GHC.Prelude
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.Bag
import GHC.Types.SrcLoc
import GHC.Utils.Json
import GHC.Types.Error ( DiagnosticReason(..) )
import Data.Function
import Data.List (sortBy, intercalate, stripPrefix)
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 (WordSuffix Word -> EwM m ()
k) = (Word -> EwM n ()) -> OptKind n
forall (m :: * -> *). (Word -> EwM m ()) -> OptKind m
WordSuffix (\Word
s -> EwM m () -> EwM n ()
forall a. EwM m a -> EwM n a
go2 (Word -> EwM m ()
k Word
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 ())
| WordSuffix (Word -> EwM m ())
| FloatSuffix (Float -> EwM m ())
| PassFlag (String -> EwM m ())
| AnySuffix (String -> EwM m ())
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
$c== :: WarnReason -> WarnReason -> Bool
== :: WarnReason -> WarnReason -> Bool
$c/= :: WarnReason -> WarnReason -> Bool
/= :: 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
$cshowsPrec :: Int -> WarnReason -> ShowS
showsPrec :: Int -> WarnReason -> ShowS
$cshow :: WarnReason -> String
show :: WarnReason -> String
$cshowList :: [WarnReason] -> ShowS
showList :: [WarnReason] -> ShowS
Show)
instance Outputable WarnReason where
ppr :: WarnReason -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
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
newtype Err = Err { Err -> Located String
errMsg :: Located String }
data Warn = Warn
{ Warn -> DiagnosticReason
warnReason :: DiagnosticReason,
Warn -> Located String
warnMsg :: Located String
}
type Errs = Bag Err
type Warns = Bag 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 (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')
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. Bag a
emptyBag
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 = DiagnosticReason -> String -> EwM m ()
forall (m :: * -> *).
Monad m =>
DiagnosticReason -> String -> EwM m ()
addFlagWarn DiagnosticReason
WarningWithoutFlag
addFlagWarn :: Monad m => DiagnosticReason -> String -> EwM m ()
addFlagWarn :: forall (m :: * -> *).
Monad m =>
DiagnosticReason -> String -> EwM m ()
addFlagWarn DiagnosticReason
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es, Warns
ws Warns -> Warn -> Warns
forall a. Bag a -> a -> Bag a
`snocBag` DiagnosticReason -> Located String -> Warn
Warn DiagnosticReason
reason (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc String
msg), ()))
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 { a
r <- m a
action; (Errs, Warns, a) -> m (Errs, Warns, a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Errs
es, Warns
ws, a
r) })
processArgs :: Monad m
=> [Flag m]
-> [Located String]
-> (FilePath -> EwM m [Located String])
-> m ( [Located String],
[Err],
[Warn] )
processArgs :: forall (m :: * -> *).
Monad m =>
[Flag m]
-> [Located String]
-> (String -> EwM m [Located String])
-> m ([Located String], [Err], [Warn])
processArgs [Flag m]
spec [Located String]
args String -> EwM m [Located String]
handleRespFile = 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 a. a -> m a
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]
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
[Located String]
resp_args <- String -> EwM m [Located String]
handleRespFile String
resp_file
[Located String] -> [Located String] -> EwM m [Located String]
process ([Located String]
resp_args [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++ [Located String]
args) [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 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 -> 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 -> 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 -> 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)
WordSuffix Word -> EwM m ()
f | Just Word
n <- String -> Maybe Word
parseWord String
rest_no_eq -> (EwM m (), [Located String])
-> Either String (EwM m (), [Located String])
forall a b. b -> Either a b
Right (Word -> EwM m ()
f Word
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 -> 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 :: 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))
[ (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 :: 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 (WordSuffix Word -> 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
parseWord :: String -> Maybe Word
parseWord :: String -> Maybe Word
parseWord String
s = case ReadS Word
forall a. Read a => ReadS a
reads String
s of
((Word
n,String
""):[(Word, String)]
_) -> Word -> Maybe Word
forall a. a -> Maybe a
Just Word
n
[(Word, String)]
_ -> Maybe Word
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 :: ShowS
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 -> ShowS
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 -> ShowS
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
Either IOException String
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 Either IOException String
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e | (String
l, String
e) <- [(String, String)]
errs ]