{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, CPP #-}
#if __GLASGOW_HASKELL__ > 720
{-# LANGUAGE Safe #-}
#endif
module System.Console.ParseArgs (
Arg(..),
Argtype(..),
ArgsComplete(..),
ArgsDash(..),
APCData(..),
ArgsParseControl(..),
DataArg,
argDataRequired, argDataOptional, argDataDefaulted,
Args(..),
parseArgs, parseArgsIO,
gotArg, ArgType(..),
getArgString, getArgFile, getArgStdio,
getArgInteger, getArgInt,
getArgDouble, getArgFloat,
ArgFileOpener(..),
ParseArgsException(..),
baseName, parseError, usageError,
System.IO.IOMode(ReadMode, WriteMode, AppendMode))
where
import Control.Exception
import Control.Monad
import Control.Monad.ST
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Data.Typeable
import System.Environment
import System.IO
data (Ord a) => Arg a =
Arg { forall a. Ord a => Arg a -> a
argIndex :: a
, forall a. Ord a => Arg a -> Maybe Char
argAbbr :: Maybe Char
, forall a. Ord a => Arg a -> Maybe [Char]
argName :: Maybe String
, forall a. Ord a => Arg a -> Maybe DataArg
argData :: Maybe DataArg
, forall a. Ord a => Arg a -> [Char]
argDesc :: String
}
data Argtype = ArgtypeString (Maybe String)
| ArgtypeInteger (Maybe Integer)
| ArgtypeInt (Maybe Int)
| ArgtypeDouble (Maybe Double)
| ArgtypeFloat (Maybe Float)
data DataArg = DataArg { DataArg -> [Char]
dataArgName :: String
, DataArg -> Argtype
dataArgArgtype :: Argtype
, DataArg -> Bool
dataArgOptional :: Bool
}
argDataRequired :: String
-> (Maybe a -> Argtype)
-> Maybe DataArg
argDataRequired :: forall a. [Char] -> (Maybe a -> Argtype) -> Maybe DataArg
argDataRequired [Char]
s Maybe a -> Argtype
c = DataArg -> Maybe DataArg
forall a. a -> Maybe a
Just (DataArg :: [Char] -> Argtype -> Bool -> DataArg
DataArg { dataArgName :: [Char]
dataArgName = [Char]
s,
dataArgArgtype :: Argtype
dataArgArgtype = Maybe a -> Argtype
c Maybe a
forall a. Maybe a
Nothing,
dataArgOptional :: Bool
dataArgOptional = Bool
False })
argDataOptional :: String
-> (Maybe a -> Argtype)
-> Maybe DataArg
argDataOptional :: forall a. [Char] -> (Maybe a -> Argtype) -> Maybe DataArg
argDataOptional [Char]
s Maybe a -> Argtype
c = DataArg -> Maybe DataArg
forall a. a -> Maybe a
Just (DataArg :: [Char] -> Argtype -> Bool -> DataArg
DataArg { dataArgName :: [Char]
dataArgName = [Char]
s,
dataArgArgtype :: Argtype
dataArgArgtype = Maybe a -> Argtype
c Maybe a
forall a. Maybe a
Nothing,
dataArgOptional :: Bool
dataArgOptional = Bool
True })
argDataDefaulted :: String
-> (Maybe a -> Argtype)
-> a
-> Maybe DataArg
argDataDefaulted :: forall a. [Char] -> (Maybe a -> Argtype) -> a -> Maybe DataArg
argDataDefaulted [Char]
s Maybe a -> Argtype
c a
d = DataArg -> Maybe DataArg
forall a. a -> Maybe a
Just (DataArg :: [Char] -> Argtype -> Bool -> DataArg
DataArg { dataArgName :: [Char]
dataArgName = [Char]
s,
dataArgArgtype :: Argtype
dataArgArgtype = Maybe a -> Argtype
c (a -> Maybe a
forall a. a -> Maybe a
Just a
d),
dataArgOptional :: Bool
dataArgOptional = Bool
True })
data Argval = ArgvalFlag
| ArgvalString String
| ArgvalInteger Integer
| ArgvalInt Int
| ArgvalDouble Double
| ArgvalFloat Float
newtype ArgRecord a = ArgRecord (Map.Map a Argval)
data (Ord a) => Args a =
Args { forall a. Ord a => Args a -> ArgRecord a
__args :: ArgRecord a
, forall a. Ord a => Args a -> [Char]
argsProgName :: String
, forall a. Ord a => Args a -> [Char]
argsUsage :: String
, forall a. Ord a => Args a -> [[Char]]
argsRest :: [ String ]
}
data ParseArgsException = ParseArgsException String String
deriving (ParseArgsException -> ParseArgsException -> Bool
(ParseArgsException -> ParseArgsException -> Bool)
-> (ParseArgsException -> ParseArgsException -> Bool)
-> Eq ParseArgsException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseArgsException -> ParseArgsException -> Bool
$c/= :: ParseArgsException -> ParseArgsException -> Bool
== :: ParseArgsException -> ParseArgsException -> Bool
$c== :: ParseArgsException -> ParseArgsException -> Bool
Eq, Typeable)
instance Exception ParseArgsException
instance Show ParseArgsException where
show :: ParseArgsException -> [Char]
show (ParseArgsException [Char]
usage [Char]
msg) = [Char]
msg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
usage
arg_posn :: (Ord a) =>
Arg a
-> Bool
arg_posn :: forall a. Ord a => Arg a -> Bool
arg_posn (Arg { argAbbr :: forall a. Ord a => Arg a -> Maybe Char
argAbbr = Maybe Char
Nothing,
argName :: forall a. Ord a => Arg a -> Maybe [Char]
argName = Maybe [Char]
Nothing }) = Bool
True
arg_posn Arg a
_ = Bool
False
arg_flag :: (Ord a) =>
Arg a
-> Bool
arg_flag :: forall a. Ord a => Arg a -> Bool
arg_flag Arg a
a = Bool -> Bool
not (Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_posn Arg a
a)
arg_optional :: (Ord a) =>
Arg a
-> Bool
arg_optional :: forall a. Ord a => Arg a -> Bool
arg_optional (Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Just (DataArg { dataArgOptional :: DataArg -> Bool
dataArgOptional = Bool
b }) }) = Bool
b
arg_optional Arg a
_ = Bool
True
arg_required :: (Ord a) =>
Arg a
-> Bool
arg_required :: forall a. Ord a => Arg a -> Bool
arg_required Arg a
a = Bool -> Bool
not (Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional Arg a
a)
arg_default_value :: (Ord a)
=> Arg a
-> Maybe Argval
arg_default_value :: forall a. Ord a => Arg a -> Maybe Argval
arg_default_value arg :: Arg a
arg@(Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Just
(DataArg { dataArgArgtype :: DataArg -> Argtype
dataArgArgtype = Argtype
da }) }) |
Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional Arg a
arg =
Argtype -> Maybe Argval
defval Argtype
da
where
defval :: Argtype -> Maybe Argval
defval (ArgtypeString (Just [Char]
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just ([Char] -> Argval
ArgvalString [Char]
v)
defval (ArgtypeInteger (Just Integer
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just (Integer -> Argval
ArgvalInteger Integer
v)
defval (ArgtypeInt (Just Int
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just (Int -> Argval
ArgvalInt Int
v)
defval (ArgtypeDouble (Just Double
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just (Double -> Argval
ArgvalDouble Double
v)
defval (ArgtypeFloat (Just Float
v)) = Argval -> Maybe Argval
forall a. a -> Maybe a
Just (Float -> Argval
ArgvalFloat Float
v)
defval Argtype
_ = Maybe Argval
forall a. Maybe a
Nothing
arg_default_value Arg a
_ = Maybe Argval
forall a. Maybe a
Nothing
perhaps :: Bool -> String -> String
perhaps :: Bool -> ShowS
perhaps Bool
b [Char]
s = if Bool
b then [Char]
s else [Char]
""
arg_string :: (Ord a) =>
Arg a
-> String
arg_string :: forall a. Ord a => Arg a -> [Char]
arg_string a :: Arg a
a@(Arg { argAbbr :: forall a. Ord a => Arg a -> Maybe Char
argAbbr = Maybe Char
abbr,
argName :: forall a. Ord a => Arg a -> Maybe [Char]
argName = Maybe [Char]
name,
argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Maybe DataArg
arg }) =
(ShowS
optionally [Char]
"[") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
((Char -> [Char]) -> Maybe Char -> [Char]
forall {a}. (a -> [Char]) -> Maybe a -> [Char]
sometimes Char -> [Char]
flag_abbr Maybe Char
abbr) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
(Bool -> ShowS
perhaps ((Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust Maybe Char
abbr) Bool -> Bool -> Bool
&& (Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [Char]
name)) [Char]
",") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
(ShowS -> Maybe [Char] -> [Char]
forall {a}. (a -> [Char]) -> Maybe a -> [Char]
sometimes ShowS
flag_name Maybe [Char]
name) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
(Bool -> ShowS
perhaps ((Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_flag Arg a
a) Bool -> Bool -> Bool
&& (Maybe DataArg -> Bool
forall a. Maybe a -> Bool
isJust Maybe DataArg
arg)) [Char]
" ") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
((DataArg -> [Char]) -> Maybe DataArg -> [Char]
forall {a}. (a -> [Char]) -> Maybe a -> [Char]
sometimes DataArg -> [Char]
data_arg Maybe DataArg
arg) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
(ShowS
optionally [Char]
"]")
where
sometimes :: (a -> [Char]) -> Maybe a -> [Char]
sometimes = [Char] -> (a -> [Char]) -> Maybe a -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
""
optionally :: ShowS
optionally [Char]
s = Bool -> ShowS
perhaps (Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional Arg a
a) [Char]
s
flag_name :: ShowS
flag_name [Char]
s = [Char]
"--" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s
flag_abbr :: Char -> [Char]
flag_abbr Char
c = [ Char
'-', Char
c ]
data_arg :: DataArg -> [Char]
data_arg (DataArg {dataArgName :: DataArg -> [Char]
dataArgName = [Char]
s}) = [Char]
"<" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
">"
filter_keys :: [ (Maybe a, b) ]
-> [ (a, b) ]
filter_keys :: forall a b. [(Maybe a, b)] -> [(a, b)]
filter_keys [(Maybe a, b)]
l =
((Maybe a, b) -> [(a, b)] -> [(a, b)])
-> [(a, b)] -> [(Maybe a, b)] -> [(a, b)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe a, b) -> [(a, b)] -> [(a, b)]
forall {a} {b}. (Maybe a, b) -> [(a, b)] -> [(a, b)]
check_key [] [(Maybe a, b)]
l
where
check_key :: (Maybe a, b) -> [(a, b)] -> [(a, b)]
check_key (Maybe a
Nothing, b
_) [(a, b)]
rest = [(a, b)]
rest
check_key (Just a
k, b
v) [(a, b)]
rest = (a
k, b
v) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
rest
argdesc_error :: String
-> a
argdesc_error :: forall a. [Char] -> a
argdesc_error [Char]
msg =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error: argument description: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg)
keymap_from_list :: (Ord k, Show k) =>
[ (k, a) ]
-> Map.Map k a
keymap_from_list :: forall k a. (Ord k, Show k) => [(k, a)] -> Map k a
keymap_from_list [(k, a)]
l =
(Map k a -> (k, a) -> Map k a) -> Map k a -> [(k, a)] -> Map k a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map k a -> (k, a) -> Map k a
forall {a} {a}. (Ord a, Show a) => Map a a -> (a, a) -> Map a a
add_entry Map k a
forall k a. Map k a
Map.empty [(k, a)]
l
where
add_entry :: Map a a -> (a, a) -> Map a a
add_entry Map a a
m (a
k, a
a) =
case a -> Map a a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member a
k Map a a
m of
Bool
False -> a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
k a
a Map a a
m
Bool
True -> [Char] -> Map a a
forall a. [Char] -> a
argdesc_error ([Char]
"duplicate argument description name " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
(a -> [Char]
forall a. Show a => a -> [Char]
show a
k))
make_keymap :: (Ord k, Show k) =>
(Arg a -> Maybe k)
-> [Arg a]
-> Map.Map k (Arg a)
make_keymap :: forall k a.
(Ord k, Show k) =>
(Arg a -> Maybe k) -> [Arg a] -> Map k (Arg a)
make_keymap Arg a -> Maybe k
f_field [Arg a]
ads =
([(k, Arg a)] -> Map k (Arg a)
forall k a. (Ord k, Show k) => [(k, a)] -> Map k a
keymap_from_list ([(k, Arg a)] -> Map k (Arg a))
-> ([Arg a] -> [(k, Arg a)]) -> [Arg a] -> Map k (Arg a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[(Maybe k, Arg a)] -> [(k, Arg a)]
forall a b. [(Maybe a, b)] -> [(a, b)]
filter_keys ([(Maybe k, Arg a)] -> [(k, Arg a)])
-> ([Arg a] -> [(Maybe k, Arg a)]) -> [Arg a] -> [(k, Arg a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Arg a -> (Maybe k, Arg a)) -> [Arg a] -> [(Maybe k, Arg a)]
forall a b. (a -> b) -> [a] -> [b]
map (\Arg a
arg -> (Arg a -> Maybe k
f_field Arg a
arg, Arg a
arg))) [Arg a]
ads
data ArgsComplete = ArgsComplete
| ArgsTrailing String
| ArgsInterspersed
data ArgsDash = ArgsHardDash
| ArgsSoftDash
deriving ArgsDash -> ArgsDash -> Bool
(ArgsDash -> ArgsDash -> Bool)
-> (ArgsDash -> ArgsDash -> Bool) -> Eq ArgsDash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArgsDash -> ArgsDash -> Bool
$c/= :: ArgsDash -> ArgsDash -> Bool
== :: ArgsDash -> ArgsDash -> Bool
$c== :: ArgsDash -> ArgsDash -> Bool
Eq
data ArgsParseControl = ArgsParseControl {
ArgsParseControl -> ArgsComplete
apcComplete :: ArgsComplete,
ArgsParseControl -> ArgsDash
apcDash :: ArgsDash }
class APCData a where
getAPCData :: a -> ArgsParseControl
instance APCData ArgsParseControl where
getAPCData :: ArgsParseControl -> ArgsParseControl
getAPCData ArgsParseControl
a = ArgsParseControl
a
instance APCData ArgsComplete where
getAPCData :: ArgsComplete -> ArgsParseControl
getAPCData ArgsComplete
a = ArgsComplete -> ArgsDash -> ArgsParseControl
ArgsParseControl ArgsComplete
a ArgsDash
ArgsHardDash
exhaust :: (s -> [e] -> ([e], s))
-> s
-> [e]
-> s
exhaust :: forall s e. (s -> [e] -> ([e], s)) -> s -> [e] -> s
exhaust s -> [e] -> ([e], s)
_ s
s [] = s
s
exhaust s -> [e] -> ([e], s)
f s
s [e]
l =
let ([e]
l', s
s') = s -> [e] -> ([e], s)
f s
s [e]
l
in (s -> [e] -> ([e], s)) -> s -> [e] -> s
forall s e. (s -> [e] -> ([e], s)) -> s -> [e] -> s
exhaust s -> [e] -> ([e], s)
f s
s' [e]
l'
parseError :: String
-> String
-> a
parseError :: forall a. [Char] -> [Char] -> a
parseError [Char]
usage [Char]
msg =
ParseArgsException -> a
forall a e. Exception e => e -> a
throw ([Char] -> [Char] -> ParseArgsException
ParseArgsException [Char]
usage [Char]
msg)
parseArgs :: (Show a, Ord a, APCData b) =>
b
-> [ Arg a ]
-> String
-> [ String ]
-> Args a
parseArgs :: forall a b.
(Show a, Ord a, APCData b) =>
b -> [Arg a] -> [Char] -> [[Char]] -> Args a
parseArgs b
apcData [Arg a]
argd [Char]
pathname [[Char]]
argv =
(forall s. ST s (Args a)) -> Args a
forall a. (forall s. ST s a) -> a
runST (do
ST s ()
forall s. ST s ()
check_argd
let ([Arg a]
flag_args, [Arg a]
posn_args) = (Arg a -> Bool) -> [Arg a] -> ([Arg a], [Arg a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_flag [Arg a]
argd
let name_hash :: Map [Char] (Arg a)
name_hash = (Arg a -> Maybe [Char]) -> [Arg a] -> Map [Char] (Arg a)
forall k a.
(Ord k, Show k) =>
(Arg a -> Maybe k) -> [Arg a] -> Map k (Arg a)
make_keymap Arg a -> Maybe [Char]
forall a. Ord a => Arg a -> Maybe [Char]
argName [Arg a]
flag_args
let abbr_hash :: Map Char (Arg a)
abbr_hash = (Arg a -> Maybe Char) -> [Arg a] -> Map Char (Arg a)
forall k a.
(Ord k, Show k) =>
(Arg a -> Maybe k) -> [Arg a] -> Map k (Arg a)
make_keymap Arg a -> Maybe Char
forall a. Ord a => Arg a -> Maybe Char
argAbbr [Arg a]
flag_args
let prog_name :: [Char]
prog_name = ShowS
baseName [Char]
pathname
let usage :: [Char]
usage = ShowS
make_usage_string [Char]
prog_name
let (Map a Argval
am, [Arg a]
_, [[Char]]
rest) = ((Map a Argval, [Arg a], [[Char]])
-> [[Char]] -> ([[Char]], (Map a Argval, [Arg a], [[Char]])))
-> (Map a Argval, [Arg a], [[Char]])
-> [[Char]]
-> (Map a Argval, [Arg a], [[Char]])
forall s e. (s -> [e] -> ([e], s)) -> s -> [e] -> s
exhaust ([Char]
-> Map [Char] (Arg a)
-> Map Char (Arg a)
-> (Map a Argval, [Arg a], [[Char]])
-> [[Char]]
-> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall {a}.
Ord a =>
[Char]
-> Map [Char] (Arg a)
-> Map Char (Arg a)
-> (Map a Argval, [Arg a], [[Char]])
-> [[Char]]
-> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
parse [Char]
usage Map [Char] (Arg a)
name_hash Map Char (Arg a)
abbr_hash)
(Map a Argval
forall k a. Map k a
Map.empty, [Arg a]
posn_args, [])
[[Char]]
argv
let required_args :: [Arg a]
required_args = (Arg a -> Bool) -> [Arg a] -> [Arg a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Arg a -> Bool) -> Arg a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional) [Arg a]
argd
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Arg a -> Bool) -> [Arg a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Map a Argval -> Arg a -> Bool
forall {a} {a}. Ord a => [Char] -> Map a a -> Arg a -> Bool
check_present [Char]
usage Map a Argval
am) [Arg a]
required_args))
([Char] -> ST s ()
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error")
let am' :: Map a Argval
am' = (Map a Argval -> Arg a -> Map a Argval)
-> Map a Argval -> [Arg a] -> Map a Argval
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map a Argval -> Arg a -> Map a Argval
forall {k}. Ord k => Map k Argval -> Arg k -> Map k Argval
supply_defaults Map a Argval
am [Arg a]
argd
Args a -> ST s (Args a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Args :: forall a. ArgRecord a -> [Char] -> [Char] -> [[Char]] -> Args a
Args { __args :: ArgRecord a
__args = Map a Argval -> ArgRecord a
forall a. Map a Argval -> ArgRecord a
ArgRecord Map a Argval
am',
argsProgName :: [Char]
argsProgName = [Char]
prog_name,
argsUsage :: [Char]
argsUsage = [Char]
usage,
argsRest :: [[Char]]
argsRest = [[Char]]
rest }))
where
supply_defaults :: Map k Argval -> Arg k -> Map k Argval
supply_defaults Map k Argval
am ad :: Arg k
ad@(Arg { argIndex :: forall a. Ord a => Arg a -> a
argIndex = k
k }) =
case k -> Map k Argval -> Maybe Argval
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k Argval
am of
Just Argval
_ -> Map k Argval
am
Maybe Argval
Nothing -> case Arg k -> Maybe Argval
forall a. Ord a => Arg a -> Maybe Argval
arg_default_value Arg k
ad of
Just Argval
v -> k -> Argval -> Map k Argval -> Map k Argval
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k Argval
v Map k Argval
am
Maybe Argval
Nothing -> Map k Argval
am
check_present :: [Char] -> Map a a -> Arg a -> Bool
check_present [Char]
usage Map a a
am ad :: Arg a
ad@(Arg { argIndex :: forall a. Ord a => Arg a -> a
argIndex = a
k }) =
case a -> Map a a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
k Map a a
am of
Just a
_ -> Bool
True
Maybe a
Nothing -> [Char] -> [Char] -> Bool
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
"missing required argument " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
(Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
arg_string Arg a
ad))
check_argd :: ST s ()
check_argd :: forall s. ST s ()
check_argd = do
let ([Arg a]
_, [Arg a]
posns) = (Arg a -> Bool) -> [Arg a] -> ([Arg a], [Arg a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_flag [Arg a]
argd
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Arg a -> Bool) -> [Arg a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_posn [Arg a]
posns)
([Char] -> ST s ()
forall a. [Char] -> a
argdesc_error [Char]
"argument description mixes flags and positionals")
Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((Arg a -> Bool) -> [Arg a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_nullary [Arg a]
argd))
([Char] -> ST s ()
forall a. [Char] -> a
argdesc_error [Char]
"bogus 'nothing' argument")
() -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
arg_nullary :: Arg a -> Bool
arg_nullary (Arg { argName :: forall a. Ord a => Arg a -> Maybe [Char]
argName = Maybe [Char]
Nothing,
argAbbr :: forall a. Ord a => Arg a -> Maybe Char
argAbbr = Maybe Char
Nothing,
argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Maybe DataArg
Nothing }) = Bool
True
arg_nullary Arg a
_ = Bool
False
make_usage_string :: ShowS
make_usage_string [Char]
prog_name =
[Char]
summary_line [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
arg_lines
where
flag_args :: [Arg a]
flag_args = (Arg a -> Bool) -> [Arg a] -> [Arg a]
forall a. (a -> Bool) -> [a] -> [a]
filter Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_flag [Arg a]
argd
posn_args :: [Arg a]
posn_args = (Arg a -> Bool) -> [Arg a] -> [Arg a]
forall a. (a -> Bool) -> [a] -> [a]
filter Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_posn [Arg a]
argd
n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Arg a -> Int) -> [Arg a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> (Arg a -> [Char]) -> Arg a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
arg_string) [Arg a]
argd)
summary_line :: [Char]
summary_line =
[Char]
"usage: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
prog_name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
Bool -> ShowS
perhaps
(Bool -> Bool
not ([Arg a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Arg a]
flag_args))
[Char]
" [options]" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
Bool -> ShowS
perhaps
(Bool -> Bool
not ([Arg a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Arg a]
posn_args))
([Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((Arg a -> [Char]) -> [Arg a] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
arg_string [Arg a]
posn_args)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
(case ArgsParseControl -> ArgsComplete
apcComplete (ArgsParseControl -> ArgsComplete)
-> ArgsParseControl -> ArgsComplete
forall a b. (a -> b) -> a -> b
$ b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
ArgsComplete
ArgsComplete -> [Char]
""
ArgsTrailing [Char]
s -> [Char]
" [--] [" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" ...]"
ArgsComplete
ArgsInterspersed -> [Char]
" ... [--] ...") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
arg_lines :: [Char]
arg_lines = (Arg a -> [Char]) -> [Arg a] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Arg a -> [Char]
forall {a}. Ord a => Int -> Arg a -> [Char]
arg_line Int
n) [Arg a]
argd where
arg_line :: Int -> Arg a -> [Char]
arg_line Int
na Arg a
a =
let s :: [Char]
s = Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
arg_string Arg a
a in
[Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
na Int -> Int -> Int
forall a. Num a => a -> a -> a
- ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s)) Char
' ' [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
[Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Arg a -> [Char]
forall a. Ord a => Arg a -> [Char]
argDesc Arg a
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
parse :: [Char]
-> Map [Char] (Arg a)
-> Map Char (Arg a)
-> (Map a Argval, [Arg a], [[Char]])
-> [[Char]]
-> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
parse [Char]
_ Map [Char] (Arg a)
_ Map Char (Arg a)
_ av :: (Map a Argval, [Arg a], [[Char]])
av@(Map a Argval
_, [Arg a]
_, []) [] = ([], (Map a Argval, [Arg a], [[Char]])
av)
parse [Char]
usage Map [Char] (Arg a)
_ Map Char (Arg a)
_ (Map a Argval, [Arg a], [[Char]])
av [] =
case ArgsParseControl -> ArgsComplete
apcComplete (ArgsParseControl -> ArgsComplete)
-> ArgsParseControl -> ArgsComplete
forall a b. (a -> b) -> a -> b
$ b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
ArgsComplete
ArgsComplete -> [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage [Char]
"unexpected extra arguments"
ArgsComplete
_ -> ([], (Map a Argval, [Arg a], [[Char]])
av)
parse [Char]
usage Map [Char] (Arg a)
name_hash Map Char (Arg a)
abbr_hash (Map a Argval
am, [Arg a]
posn, [[Char]]
rest) av :: [[Char]]
av@([Char]
aa : [[Char]]
aas) =
case [Char]
aa of
[Char]
"--" -> case b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
ArgsParseControl ArgsComplete
ArgsComplete ArgsDash
ArgsHardDash ->
[Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
"unexpected -- " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
[Char]
"(extra arguments not allowed)")
ArgsParseControl
_ -> ([], (Map a Argval
am, [Arg a]
posn, ([[Char]]
rest [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
aas)))
s :: [Char]
s@(Char
'-' : Char
'-' : [Char]
name)
| Maybe (Arg a) -> Bool
forall a. Maybe a -> Bool
isJust ([Char] -> Map [Char] (Arg a) -> Maybe (Arg a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name Map [Char] (Arg a)
name_hash) Bool -> Bool -> Bool
||
ArgsParseControl -> ArgsDash
apcDash (b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData) ArgsDash -> ArgsDash -> Bool
forall a. Eq a => a -> a -> Bool
== ArgsDash
ArgsHardDash ->
case [Char] -> Map [Char] (Arg a) -> Maybe (Arg a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name Map [Char] (Arg a)
name_hash of
Just Arg a
ad ->
let ([[Char]]
args', Map a Argval
am') = [Char] -> Arg a -> [[Char]] -> ([[Char]], Map a Argval)
peel [Char]
s Arg a
ad [[Char]]
aas in
([[Char]]
args', (Map a Argval
am', [Arg a]
posn, [[Char]]
rest))
Maybe (Arg a)
Nothing ->
case b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
ArgsParseControl ArgsComplete
ArgsInterspersed ArgsDash
_ ->
([[Char]]
aas, (Map a Argval
am, [Arg a]
posn, [[Char]]
rest [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name]))
ArgsParseControl
_ ->
[Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage
([Char]
"unknown argument --" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name)
(Char
'-' : Char
abbr : [Char]
abbrs)
| Maybe (Arg a) -> Bool
forall a. Maybe a -> Bool
isJust (Char -> Map Char (Arg a) -> Maybe (Arg a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
abbr Map Char (Arg a)
abbr_hash) Bool -> Bool -> Bool
||
ArgsParseControl -> ArgsDash
apcDash (b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData) ArgsDash -> ArgsDash -> Bool
forall a. Eq a => a -> a -> Bool
== ArgsDash
ArgsHardDash ->
case Char -> Map Char (Arg a) -> Maybe (Arg a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
abbr Map Char (Arg a)
abbr_hash of
Just Arg a
ad ->
let ([[Char]]
args', Map a Argval
am') = [Char] -> Arg a -> [[Char]] -> ([[Char]], Map a Argval)
peel [Char
'-', Char
abbr] Arg a
ad [[Char]]
aas
state' :: (Map a Argval, [Arg a], [[Char]])
state' = (Map a Argval
am', [Arg a]
posn, [[Char]]
rest)
in case [Char]
abbrs of
[] -> ([[Char]]
args', (Map a Argval, [Arg a], [[Char]])
state')
(Char
'-' : [Char]
_) -> [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage
([Char]
"bad internal '-' in argument " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
aa)
[Char]
_ -> ([Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
abbrs] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args', (Map a Argval, [Arg a], [[Char]])
state')
Maybe (Arg a)
Nothing ->
case ArgsParseControl -> ArgsComplete
apcComplete (ArgsParseControl -> ArgsComplete)
-> ArgsParseControl -> ArgsComplete
forall a b. (a -> b) -> a -> b
$ b -> ArgsParseControl
forall a. APCData a => a -> ArgsParseControl
getAPCData b
apcData of
ArgsComplete
ArgsInterspersed ->
([[Char]]
aas,
(Map a Argval
am, [Arg a]
posn, [[Char]]
rest [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
abbr Char -> ShowS
forall a. a -> [a] -> [a]
: [Char]
abbrs]))
ArgsComplete
_ -> [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage
([Char]
"unknown argument -" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
abbr])
[Char]
_ ->
case [Arg a]
posn of
(Arg a
p : [Arg a]
ps) ->
let ([Arg a]
_, [Arg a]
req_posn) = (Arg a -> Bool) -> [Arg a] -> ([Arg a], [Arg a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_optional [Arg a]
posn in
case [[Char]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
av Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Arg a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg a]
req_posn of
Int
n_extra | Int
n_extra Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| (Int
n_extra Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Arg a -> Bool
forall a. Ord a => Arg a -> Bool
arg_required Arg a
p) ->
let ([[Char]]
args', Map a Argval
am') = [Char] -> Arg a -> [[Char]] -> ([[Char]], Map a Argval)
peel (DataArg -> [Char]
dataArgName (DataArg -> [Char]) -> DataArg -> [Char]
forall a b. (a -> b) -> a -> b
$ Maybe DataArg -> DataArg
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DataArg -> DataArg) -> Maybe DataArg -> DataArg
forall a b. (a -> b) -> a -> b
$
Arg a -> Maybe DataArg
forall a. Ord a => Arg a -> Maybe DataArg
argData Arg a
p) Arg a
p [[Char]]
av in
([[Char]]
args', (Map a Argval
am', [Arg a]
ps, [[Char]]
rest))
Int
0 -> ([[Char]]
av, (Map a Argval
am, [Arg a]
ps, [[Char]]
rest))
Int
_ -> [Char] -> [Char] -> ([[Char]], (Map a Argval, [Arg a], [[Char]]))
forall a. [Char] -> [Char] -> a
parseError [Char]
usage
[Char]
"missing required positional argument(s)"
[] -> ([], (Map a Argval
am, [], [[Char]]
rest [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
av))
where
add_entry :: [Char] -> Map k a -> (k, a) -> Map k a
add_entry [Char]
s Map k a
m (k
k, a
a) =
case k -> Map k a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member k
k Map k a
m of
Bool
False -> k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k a
a Map k a
m
Bool
True -> [Char] -> [Char] -> Map k a
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
"duplicate argument " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s)
peel :: [Char] -> Arg a -> [[Char]] -> ([[Char]], Map a Argval)
peel [Char]
name (Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Maybe DataArg
Nothing, argIndex :: forall a. Ord a => Arg a -> a
argIndex = a
index }) [[Char]]
argl =
let am' :: Map a Argval
am' = [Char] -> Map a Argval -> (a, Argval) -> Map a Argval
forall {k} {a}. Ord k => [Char] -> Map k a -> (k, a) -> Map k a
add_entry [Char]
name Map a Argval
am (a
index, Argval
ArgvalFlag)
in ([[Char]]
argl, Map a Argval
am')
peel [Char]
name (Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData = Just (DataArg {}) }) [] =
[Char] -> [Char] -> ([[Char]], Map a Argval)
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is missing its argument")
peel [Char]
name (Arg { argData :: forall a. Ord a => Arg a -> Maybe DataArg
argData =
Just (DataArg { dataArgArgtype :: DataArg -> Argtype
dataArgArgtype = Argtype
atype }),
argIndex :: forall a. Ord a => Arg a -> a
argIndex = a
index })
([Char]
a : [[Char]]
argl) =
let v :: Argval
v = case Argtype
atype of
ArgtypeString Maybe [Char]
_ -> [Char] -> Argval
ArgvalString [Char]
a
ArgtypeInteger Maybe Integer
_ -> (Integer -> Argval) -> [Char] -> Argval
forall {t} {t}. Read t => (t -> t) -> [Char] -> t
read_arg Integer -> Argval
ArgvalInteger
[Char]
"an integer"
ArgtypeInt Maybe Int
_ -> (Int -> Argval) -> [Char] -> Argval
forall {t} {t}. Read t => (t -> t) -> [Char] -> t
read_arg Int -> Argval
ArgvalInt [Char]
"an int"
ArgtypeDouble Maybe Double
_ -> (Double -> Argval) -> [Char] -> Argval
forall {t} {t}. Read t => (t -> t) -> [Char] -> t
read_arg Double -> Argval
ArgvalDouble [Char]
"a double"
ArgtypeFloat Maybe Float
_ -> (Float -> Argval) -> [Char] -> Argval
forall {t} {t}. Read t => (t -> t) -> [Char] -> t
read_arg Float -> Argval
ArgvalFloat [Char]
"a float"
where
read_arg :: (t -> t) -> [Char] -> t
read_arg t -> t
constructor [Char]
kind =
case ReadS t
forall a. Read a => ReadS a
reads [Char]
a of
[(t
val, [Char]
"")] -> t -> t
constructor t
val
[(t, [Char])]
_ -> [Char] -> [Char] -> t
forall a. [Char] -> [Char] -> a
parseError [Char]
usage ([Char]
"argument " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
[Char]
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
[Char]
" is not " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
kind)
am' :: Map a Argval
am' = [Char] -> Map a Argval -> (a, Argval) -> Map a Argval
forall {k} {a}. Ord k => [Char] -> Map k a -> (k, a) -> Map k a
add_entry [Char]
name Map a Argval
am (a
index, Argval
v)
in ([[Char]]
argl, Map a Argval
am')
parseArgsIO :: (Show a, Ord a, APCData b) =>
b
-> [ Arg a ]
-> IO (Args a)
parseArgsIO :: forall a b.
(Show a, Ord a, APCData b) =>
b -> [Arg a] -> IO (Args a)
parseArgsIO b
apcData [Arg a]
argd = do
[[Char]]
argv <- IO [[Char]]
getArgs
[Char]
pathname <- IO [Char]
getProgName
Args a -> IO (Args a)
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> [Arg a] -> [Char] -> [[Char]] -> Args a
forall a b.
(Show a, Ord a, APCData b) =>
b -> [Arg a] -> [Char] -> [[Char]] -> Args a
parseArgs b
apcData [Arg a]
argd [Char]
pathname [[Char]]
argv)
gotArg :: (Ord a) =>
Args a
-> a
-> Bool
gotArg :: forall a. Ord a => Args a -> a -> Bool
gotArg (Args { __args :: forall a. Ord a => Args a -> ArgRecord a
__args = ArgRecord Map a Argval
am }) a
k =
case a -> Map a Argval -> Maybe Argval
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
k Map a Argval
am of
Just Argval
_ -> Bool
True
Maybe Argval
Nothing -> Bool
False
class ArgType b where
getArg :: (Show a, Ord a)
=> Args a
-> a
-> Maybe b
getRequiredArg :: (Show a, Ord a)
=> Args a
-> a
-> b
getRequiredArg Args a
ads a
index =
case Args a -> a -> Maybe b
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg Args a
ads a
index of
Just b
v -> b
v
Maybe b
Nothing -> [Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error: required argument "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
index [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"not supplied")
getArgPrimitive :: Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive :: forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe b
decons (Args { __args :: forall a. Ord a => Args a -> ArgRecord a
__args = ArgRecord Map a Argval
am }) a
k =
a -> Map a Argval -> Maybe Argval
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
k Map a Argval
am Maybe Argval -> (Argval -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Argval -> Maybe b
decons
instance ArgType () where
getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe ()
getArg =
(Argval -> Maybe ()) -> Args a -> a -> Maybe ()
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe ()
forall {m :: * -> *}. Monad m => Argval -> m ()
flagArg
where
flagArg :: Argval -> m ()
flagArg Argval
ArgvalFlag = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
flagArg Argval
_ = [Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: flag arg at wrong type"
instance ArgType ([] Char) where
getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe [Char]
getArg =
(Argval -> Maybe [Char]) -> Args a -> a -> Maybe [Char]
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe [Char]
forall {m :: * -> *}. Monad m => Argval -> m [Char]
stringArg
where
stringArg :: Argval -> m [Char]
stringArg (ArgvalString [Char]
s) = [Char] -> m [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
s
stringArg Argval
_ = [Char] -> m [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: string arg at wrong type"
getArgString :: (Show a, Ord a) =>
Args a
-> a
-> Maybe String
getArgString :: forall a. (Show a, Ord a) => Args a -> a -> Maybe [Char]
getArgString = Args a -> a -> Maybe [Char]
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg
instance ArgType Integer where
getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Integer
getArg =
(Argval -> Maybe Integer) -> Args a -> a -> Maybe Integer
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe Integer
forall {m :: * -> *}. Monad m => Argval -> m Integer
integerArg
where
integerArg :: Argval -> m Integer
integerArg (ArgvalInteger Integer
i) = Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
integerArg Argval
_ = [Char] -> m Integer
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: integer arg at wrong type"
getArgInteger :: (Show a, Ord a) =>
Args a
-> a
-> Maybe Integer
getArgInteger :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Integer
getArgInteger = Args a -> a -> Maybe Integer
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg
instance ArgType Int where
getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Int
getArg =
(Argval -> Maybe Int) -> Args a -> a -> Maybe Int
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe Int
forall {m :: * -> *}. Monad m => Argval -> m Int
intArg
where
intArg :: Argval -> m Int
intArg (ArgvalInt Int
i) = Int -> m Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
intArg Argval
_ = [Char] -> m Int
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: int arg at wrong type"
getArgInt :: (Show a, Ord a) =>
Args a
-> a
-> Maybe Int
getArgInt :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Int
getArgInt = Args a -> a -> Maybe Int
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg
instance ArgType Double where
getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Double
getArg =
(Argval -> Maybe Double) -> Args a -> a -> Maybe Double
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe Double
forall {m :: * -> *}. Monad m => Argval -> m Double
doubleArg
where
doubleArg :: Argval -> m Double
doubleArg (ArgvalDouble Double
d) = Double -> m Double
forall (m :: * -> *) a. Monad m => a -> m a
return Double
d
doubleArg Argval
_ = [Char] -> m Double
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: double arg at wrong type"
getArgDouble :: (Show a, Ord a) =>
Args a
-> a
-> Maybe Double
getArgDouble :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Double
getArgDouble = Args a -> a -> Maybe Double
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg
instance ArgType Float where
getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Float
getArg =
(Argval -> Maybe Float) -> Args a -> a -> Maybe Float
forall a b. Ord a => (Argval -> Maybe b) -> Args a -> a -> Maybe b
getArgPrimitive Argval -> Maybe Float
forall {m :: * -> *}. Monad m => Argval -> m Float
floatArg
where
floatArg :: Argval -> m Float
floatArg (ArgvalFloat Float
f) = Float -> m Float
forall (m :: * -> *) a. Monad m => a -> m a
return Float
f
floatArg Argval
_ = [Char] -> m Float
forall a. HasCallStack => [Char] -> a
error [Char]
"internal error: float arg at wrong type"
getArgFloat :: (Show a, Ord a) =>
Args a
-> a
-> Maybe Float
getArgFloat :: forall a. (Show a, Ord a) => Args a -> a -> Maybe Float
getArgFloat = Args a -> a -> Maybe Float
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg
newtype ArgFileOpener = ArgFileOpener {
ArgFileOpener -> IOMode -> IO Handle
argFileOpener :: IOMode -> IO Handle
}
instance ArgType ArgFileOpener where
getArg :: forall a. (Show a, Ord a) => Args a -> a -> Maybe ArgFileOpener
getArg Args a
ads a
index =
Args a -> a -> Maybe [Char]
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg Args a
ads a
index Maybe [Char]
-> ([Char] -> Maybe ArgFileOpener) -> Maybe ArgFileOpener
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(\[Char]
s -> ArgFileOpener -> Maybe ArgFileOpener
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgFileOpener -> Maybe ArgFileOpener)
-> ArgFileOpener -> Maybe ArgFileOpener
forall a b. (a -> b) -> a -> b
$ ArgFileOpener :: (IOMode -> IO Handle) -> ArgFileOpener
ArgFileOpener { argFileOpener :: IOMode -> IO Handle
argFileOpener = [Char] -> IOMode -> IO Handle
openFile [Char]
s })
getArgFile :: (Show a, Ord a) =>
Args a
-> a
-> IOMode
-> IO (Maybe Handle)
getArgFile :: forall a.
(Show a, Ord a) =>
Args a -> a -> IOMode -> IO (Maybe Handle)
getArgFile Args a
ads a
k IOMode
m =
case Args a -> a -> Maybe ArgFileOpener
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg Args a
ads a
k of
Just ArgFileOpener
fo -> (do Handle
h <- ArgFileOpener -> IOMode -> IO Handle
argFileOpener ArgFileOpener
fo IOMode
m; Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h))
Maybe ArgFileOpener
Nothing -> Maybe Handle -> IO (Maybe Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
getArgStdio :: (Show a, Ord a) =>
Args a
-> a
-> IOMode
-> IO Handle
getArgStdio :: forall a. (Show a, Ord a) => Args a -> a -> IOMode -> IO Handle
getArgStdio Args a
ads a
k IOMode
m =
case Args a -> a -> Maybe [Char]
forall b a. (ArgType b, Show a, Ord a) => Args a -> a -> Maybe b
getArg Args a
ads a
k of
Just [Char]
s -> [Char] -> IOMode -> IO Handle
openFile [Char]
s IOMode
m
Maybe [Char]
Nothing ->
case IOMode
m of
IOMode
ReadMode -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
IOMode
WriteMode -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
IOMode
AppendMode -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
IOMode
ReadWriteMode ->
[Char] -> IO Handle
forall a. HasCallStack => [Char] -> a
error ([Char]
"internal error: tried to open stdio "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"in ReadWriteMode")
baseName :: String
-> String
baseName :: ShowS
baseName [Char]
s =
let s' :: [Char]
s' = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') [Char]
s in
if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
s' then [Char]
s else ShowS
baseName (ShowS
forall a. [a] -> [a]
tail [Char]
s')
usageError :: (Ord a) => Args a -> String -> b
usageError :: forall a b. Ord a => Args a -> [Char] -> b
usageError Args a
ads [Char]
msg = [Char] -> b
forall a. HasCallStack => [Char] -> a
error (Args a -> [Char]
forall a. Ord a => Args a -> [Char]
argsUsage Args a
ads [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg)