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