{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Options
(
Options(..)
, defaultOptions
, simpleOption
, DefineOptions
, SimpleOptionType(..)
, Subcommand
, subcommand
, runCommand
, runSubcommand
, Parsed
, parsedError
, parsedHelp
, ParsedOptions
, parsedOptions
, parsedArguments
, parseOptions
, ParsedSubcommand
, parsedSubcommand
, parseSubcommand
, OptionType
, defineOption
, Option
, optionShortFlags
, optionLongFlags
, optionDefault
, optionDescription
, optionGroup
, Group
, group
, groupName
, groupTitle
, groupDescription
, optionType_bool
, optionType_string
, optionType_int
, optionType_int8
, optionType_int16
, optionType_int32
, optionType_int64
, optionType_word
, optionType_word8
, optionType_word16
, optionType_word32
, optionType_word64
, optionType_integer
, optionType_float
, optionType_double
, optionType_maybe
, optionType_list
, optionType_set
, optionType_map
, optionType_enum
, optionType
, optionTypeName
, optionTypeDefault
, optionTypeParse
, optionTypeShow
, optionTypeUnary
, optionTypeMerge
) where
import Control.Applicative
import Control.Monad (forM_)
import Control.Monad.Error (ErrorT, runErrorT, throwError)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.Functor.Identity
import Data.Int
import Data.List (intercalate)
import qualified Data.Map as Map
import Data.Maybe (isJust)
import qualified Data.Set as Set
import Data.Word
import qualified System.Environment
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStr, hPutStrLn, stderr, stdout)
import Options.Help
import Options.Tokenize
import Options.Types
import Options.Util (mapEither)
class Options opts where
defineOptions :: DefineOptions opts
data DefineOptions a = DefineOptions a (Integer -> (Integer, [OptionInfo])) (Integer -> Map.Map OptionKey [Token] -> Either String (Integer, a))
instance Functor DefineOptions where
fmap :: forall a b. (a -> b) -> DefineOptions a -> DefineOptions b
fmap a -> b
fn (DefineOptions a
defaultValue Integer -> (Integer, [OptionInfo])
getInfo Integer -> Map OptionKey [Token] -> Either String (Integer, a)
parse) = b
-> (Integer -> (Integer, [OptionInfo]))
-> (Integer -> Map OptionKey [Token] -> Either String (Integer, b))
-> DefineOptions b
forall a.
a
-> (Integer -> (Integer, [OptionInfo]))
-> (Integer -> Map OptionKey [Token] -> Either String (Integer, a))
-> DefineOptions a
DefineOptions (a -> b
fn a
defaultValue) Integer -> (Integer, [OptionInfo])
getInfo (\Integer
key Map OptionKey [Token]
tokens -> case Integer -> Map OptionKey [Token] -> Either String (Integer, a)
parse Integer
key Map OptionKey [Token]
tokens of
Left String
err -> String -> Either String (Integer, b)
forall a b. a -> Either a b
Left String
err
Right (Integer
key', a
a) -> (Integer, b) -> Either String (Integer, b)
forall a b. b -> Either a b
Right (Integer
key', a -> b
fn a
a))
instance Applicative DefineOptions where
pure :: forall a. a -> DefineOptions a
pure a
a = a
-> (Integer -> (Integer, [OptionInfo]))
-> (Integer -> Map OptionKey [Token] -> Either String (Integer, a))
-> DefineOptions a
forall a.
a
-> (Integer -> (Integer, [OptionInfo]))
-> (Integer -> Map OptionKey [Token] -> Either String (Integer, a))
-> DefineOptions a
DefineOptions a
a (\Integer
key -> (Integer
key, [])) (\Integer
key Map OptionKey [Token]
_ -> (Integer, a) -> Either String (Integer, a)
forall a b. b -> Either a b
Right (Integer
key, a
a))
(DefineOptions a -> b
acc_default Integer -> (Integer, [OptionInfo])
acc_getInfo Integer -> Map OptionKey [Token] -> Either String (Integer, a -> b)
acc_parse) <*> :: forall a b.
DefineOptions (a -> b) -> DefineOptions a -> DefineOptions b
<*> (DefineOptions a
defaultValue Integer -> (Integer, [OptionInfo])
getInfo Integer -> Map OptionKey [Token] -> Either String (Integer, a)
parse) = b
-> (Integer -> (Integer, [OptionInfo]))
-> (Integer -> Map OptionKey [Token] -> Either String (Integer, b))
-> DefineOptions b
forall a.
a
-> (Integer -> (Integer, [OptionInfo]))
-> (Integer -> Map OptionKey [Token] -> Either String (Integer, a))
-> DefineOptions a
DefineOptions
(a -> b
acc_default a
defaultValue)
(\Integer
key -> case Integer -> (Integer, [OptionInfo])
acc_getInfo Integer
key of
(Integer
key', [OptionInfo]
infos) -> case Integer -> (Integer, [OptionInfo])
getInfo Integer
key' of
(Integer
key'', [OptionInfo]
infos') -> (Integer
key'', [OptionInfo]
infos [OptionInfo] -> [OptionInfo] -> [OptionInfo]
forall a. [a] -> [a] -> [a]
++ [OptionInfo]
infos'))
(\Integer
key Map OptionKey [Token]
tokens -> case Integer -> Map OptionKey [Token] -> Either String (Integer, a -> b)
acc_parse Integer
key Map OptionKey [Token]
tokens of
Left String
err -> String -> Either String (Integer, b)
forall a b. a -> Either a b
Left String
err
Right (Integer
key', a -> b
fn) -> case Integer -> Map OptionKey [Token] -> Either String (Integer, a)
parse Integer
key' Map OptionKey [Token]
tokens of
Left String
err -> String -> Either String (Integer, b)
forall a b. a -> Either a b
Left String
err
Right (Integer
key'', a
a) -> (Integer, b) -> Either String (Integer, b)
forall a b. b -> Either a b
Right (Integer
key'', a -> b
fn a
a))
defaultOptions :: Options opts => opts
defaultOptions :: forall opts. Options opts => opts
defaultOptions = case DefineOptions opts
forall opts. Options opts => DefineOptions opts
defineOptions of
(DefineOptions opts
def Integer -> (Integer, [OptionInfo])
_ Integer -> Map OptionKey [Token] -> Either String (Integer, opts)
_) -> opts
def
data OptionType val = OptionType
{
forall val. OptionType val -> String
optionTypeName :: String
, forall val. OptionType val -> val
optionTypeDefault :: val
, forall val. OptionType val -> String -> Either String val
optionTypeParse :: String -> Either String val
, forall val. OptionType val -> val -> String
optionTypeShow :: val -> String
, forall val. OptionType val -> Maybe val
optionTypeUnary :: Maybe val
, forall val. OptionType val -> Maybe ([val] -> val)
optionTypeMerge :: Maybe ([val] -> val)
}
group :: String
-> String
-> String
-> Group
group :: String -> String -> String -> Group
group = String -> String -> String -> Group
Group
optionType :: String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType :: forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
name val
def String -> Either String val
parse val -> String
show' = String
-> val
-> (String -> Either String val)
-> (val -> String)
-> Maybe val
-> Maybe ([val] -> val)
-> OptionType val
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> Maybe val
-> Maybe ([val] -> val)
-> OptionType val
OptionType String
name val
def String -> Either String val
parse val -> String
show' Maybe val
forall a. Maybe a
Nothing Maybe ([val] -> val)
forall a. Maybe a
Nothing
class SimpleOptionType a where
simpleOptionType :: OptionType a
instance SimpleOptionType Bool where
simpleOptionType :: OptionType Bool
simpleOptionType = OptionType Bool
optionType_bool
optionType_bool :: OptionType Bool
optionType_bool :: OptionType Bool
optionType_bool = (String
-> Bool
-> (String -> Either String Bool)
-> (Bool -> String)
-> OptionType Bool
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"bool" Bool
False String -> Either String Bool
parseBool (\Bool
x -> if Bool
x then String
"true" else String
"false"))
{ optionTypeUnary :: Maybe Bool
optionTypeUnary = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
}
parseBool :: String -> Either String Bool
parseBool :: String -> Either String Bool
parseBool String
s = case String
s of
String
"true" -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
True
String
"false" -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
False
String
_ -> String -> Either String Bool
forall a b. a -> Either a b
Left (String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not in {\"true\", \"false\"}.")
instance SimpleOptionType String where
simpleOptionType :: OptionType String
simpleOptionType = OptionType String
optionType_string
optionType_string :: OptionType String
optionType_string :: OptionType String
optionType_string = String
-> String
-> (String -> Either String String)
-> (String -> String)
-> OptionType String
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"text" String
"" String -> Either String String
forall a b. b -> Either a b
Right String -> String
forall a. Show a => a -> String
show
instance SimpleOptionType Integer where
simpleOptionType :: OptionType Integer
simpleOptionType = OptionType Integer
optionType_integer
optionType_integer :: OptionType Integer
optionType_integer :: OptionType Integer
optionType_integer = String
-> Integer
-> (String -> Either String Integer)
-> (Integer -> String)
-> OptionType Integer
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"integer" Integer
0 String -> Either String Integer
parseInteger Integer -> String
forall a. Show a => a -> String
show
parseInteger :: String -> Either String Integer
parseInteger :: String -> Either String Integer
parseInteger String
s = Either String Integer
parsed where
parsed :: Either String Integer
parsed = if Bool
valid
then Integer -> Either String Integer
forall a b. b -> Either a b
Right (String -> Integer
forall a. Read a => String -> a
read String
s)
else String -> Either String Integer
forall a b. a -> Either a b
Left (String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not an integer.")
valid :: Bool
valid = case String
s of
[] -> Bool
False
Char
'-':String
s' -> String -> Bool
allDigits String
s'
String
_ -> String -> Bool
allDigits String
s
allDigits :: String -> Bool
allDigits = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')
parseBoundedIntegral :: (Bounded a, Integral a) => String -> String -> Either String a
parseBoundedIntegral :: forall a.
(Bounded a, Integral a) =>
String -> String -> Either String a
parseBoundedIntegral String
label = String -> Either String a
parse where
getBounds :: (Bounded a, Integral a) => (String -> Either String a) -> a -> a -> (Integer, Integer)
getBounds :: forall a.
(Bounded a, Integral a) =>
(String -> Either String a) -> a -> a -> (Integer, Integer)
getBounds String -> Either String a
_ a
min' a
max' = (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
min', a -> Integer
forall a. Integral a => a -> Integer
toInteger a
max')
(Integer
minInt, Integer
maxInt) = (String -> Either String a) -> a -> a -> (Integer, Integer)
forall a.
(Bounded a, Integral a) =>
(String -> Either String a) -> a -> a -> (Integer, Integer)
getBounds String -> Either String a
parse a
forall a. Bounded a => a
minBound a
forall a. Bounded a => a
maxBound
parse :: String -> Either String a
parse String
s = case String -> Either String Integer
parseInteger String
s of
Left String
err -> String -> Either String a
forall a b. a -> Either a b
Left String
err
Right Integer
int -> if Integer
int Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
minInt Bool -> Bool -> Bool
|| Integer
int Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
maxInt
then String -> Either String a
forall a b. a -> Either a b
Left (Integer -> String
forall a. Show a => a -> String
show Integer
int String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not within bounds [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
minInt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
maxInt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
label String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
else a -> Either String a
forall a b. b -> Either a b
Right (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
int)
optionTypeBoundedInt :: (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt :: forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
tName = String
-> a
-> (String -> Either String a)
-> (a -> String)
-> OptionType a
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
tName a
0 (String -> String -> Either String a
forall a.
(Bounded a, Integral a) =>
String -> String -> Either String a
parseBoundedIntegral String
tName) a -> String
forall a. Show a => a -> String
show
instance SimpleOptionType Int where
simpleOptionType :: OptionType Int
simpleOptionType = OptionType Int
optionType_int
optionType_int :: OptionType Int
optionType_int :: OptionType Int
optionType_int = String -> OptionType Int
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"int"
instance SimpleOptionType Int8 where
simpleOptionType :: OptionType Int8
simpleOptionType = OptionType Int8
optionType_int8
optionType_int8 :: OptionType Int8
optionType_int8 :: OptionType Int8
optionType_int8 = String -> OptionType Int8
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"int8"
instance SimpleOptionType Int16 where
simpleOptionType :: OptionType Int16
simpleOptionType = OptionType Int16
optionType_int16
optionType_int16 :: OptionType Int16
optionType_int16 :: OptionType Int16
optionType_int16 = String -> OptionType Int16
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"int16"
instance SimpleOptionType Int32 where
simpleOptionType :: OptionType Int32
simpleOptionType = OptionType Int32
optionType_int32
optionType_int32 :: OptionType Int32
optionType_int32 :: OptionType Int32
optionType_int32 = String -> OptionType Int32
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"int32"
instance SimpleOptionType Int64 where
simpleOptionType :: OptionType Int64
simpleOptionType = OptionType Int64
optionType_int64
optionType_int64 :: OptionType Int64
optionType_int64 :: OptionType Int64
optionType_int64 = String -> OptionType Int64
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"int64"
instance SimpleOptionType Word where
simpleOptionType :: OptionType Word
simpleOptionType = OptionType Word
optionType_word
optionType_word :: OptionType Word
optionType_word :: OptionType Word
optionType_word = String -> OptionType Word
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"uint"
instance SimpleOptionType Word8 where
simpleOptionType :: OptionType Word8
simpleOptionType = OptionType Word8
optionType_word8
optionType_word8 :: OptionType Word8
optionType_word8 :: OptionType Word8
optionType_word8 = String -> OptionType Word8
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"uint8"
instance SimpleOptionType Word16 where
simpleOptionType :: OptionType Word16
simpleOptionType = OptionType Word16
optionType_word16
optionType_word16 :: OptionType Word16
optionType_word16 :: OptionType Word16
optionType_word16 = String -> OptionType Word16
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"uint16"
instance SimpleOptionType Word32 where
simpleOptionType :: OptionType Word32
simpleOptionType = OptionType Word32
optionType_word32
optionType_word32 :: OptionType Word32
optionType_word32 :: OptionType Word32
optionType_word32 = String -> OptionType Word32
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"uint32"
instance SimpleOptionType Word64 where
simpleOptionType :: OptionType Word64
simpleOptionType = OptionType Word64
optionType_word64
optionType_word64 :: OptionType Word64
optionType_word64 :: OptionType Word64
optionType_word64 = String -> OptionType Word64
forall a. (Bounded a, Integral a, Show a) => String -> OptionType a
optionTypeBoundedInt String
"uint64"
instance SimpleOptionType Float where
simpleOptionType :: OptionType Float
simpleOptionType = OptionType Float
optionType_float
optionType_float :: OptionType Float
optionType_float :: OptionType Float
optionType_float = String
-> Float
-> (String -> Either String Float)
-> (Float -> String)
-> OptionType Float
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"float32" Float
0 String -> Either String Float
forall a. Read a => String -> Either String a
parseFloat Float -> String
forall a. Show a => a -> String
show
instance SimpleOptionType Double where
simpleOptionType :: OptionType Double
simpleOptionType = OptionType Double
optionType_double
optionType_double :: OptionType Double
optionType_double :: OptionType Double
optionType_double = String
-> Double
-> (String -> Either String Double)
-> (Double -> String)
-> OptionType Double
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"float64" Double
0 String -> Either String Double
forall a. Read a => String -> Either String a
parseFloat Double -> String
forall a. Show a => a -> String
show
parseFloat :: Read a => String -> Either String a
parseFloat :: forall a. Read a => String -> Either String a
parseFloat String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
[(a
x, String
"")] -> a -> Either String a
forall a b. b -> Either a b
Right a
x
[(a, String)]
_ -> String -> Either String a
forall a b. a -> Either a b
Left (String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a number.")
instance SimpleOptionType a => SimpleOptionType (Maybe a) where
simpleOptionType :: OptionType (Maybe a)
simpleOptionType = OptionType a -> OptionType (Maybe a)
forall a. OptionType a -> OptionType (Maybe a)
optionType_maybe OptionType a
forall a. SimpleOptionType a => OptionType a
simpleOptionType
optionType_maybe :: OptionType a -> OptionType (Maybe a)
optionType_maybe :: forall a. OptionType a -> OptionType (Maybe a)
optionType_maybe OptionType a
t = OptionType (Maybe a)
maybeT { optionTypeUnary :: Maybe (Maybe a)
optionTypeUnary = Maybe (Maybe a)
unary } where
maybeT :: OptionType (Maybe a)
maybeT = String
-> Maybe a
-> (String -> Either String (Maybe a))
-> (Maybe a -> String)
-> OptionType (Maybe a)
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
name Maybe a
forall a. Maybe a
Nothing (OptionType a -> String -> Either String (Maybe a)
forall val. OptionType val -> String -> Either String (Maybe val)
parseMaybe OptionType a
t) (OptionType a -> Maybe a -> String
forall val. OptionType val -> Maybe val -> String
showMaybe OptionType a
t)
name :: String
name = String
"maybe<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ OptionType a -> String
forall val. OptionType val -> String
optionTypeName OptionType a
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
unary :: Maybe (Maybe a)
unary = case OptionType a -> Maybe a
forall val. OptionType val -> Maybe val
optionTypeUnary OptionType a
t of
Maybe a
Nothing -> Maybe (Maybe a)
forall a. Maybe a
Nothing
Just a
val -> Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (a -> Maybe a
forall a. a -> Maybe a
Just a
val)
parseMaybe :: OptionType val -> String -> Either String (Maybe val)
parseMaybe :: forall val. OptionType val -> String -> Either String (Maybe val)
parseMaybe OptionType val
t String
s = case String
s of
String
"" -> Maybe val -> Either String (Maybe val)
forall a b. b -> Either a b
Right Maybe val
forall a. Maybe a
Nothing
String
_ -> case OptionType val -> String -> Either String val
forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType val
t String
s of
Left String
err -> String -> Either String (Maybe val)
forall a b. a -> Either a b
Left String
err
Right val
a -> Maybe val -> Either String (Maybe val)
forall a b. b -> Either a b
Right (val -> Maybe val
forall a. a -> Maybe a
Just val
a)
showMaybe :: OptionType val -> Maybe val -> String
showMaybe :: forall val. OptionType val -> Maybe val -> String
showMaybe OptionType val
_ Maybe val
Nothing = String
""
showMaybe OptionType val
t (Just val
x) = OptionType val -> val -> String
forall val. OptionType val -> val -> String
optionTypeShow OptionType val
t val
x
optionType_set :: Ord a
=> Char
-> OptionType a
-> OptionType (Set.Set a)
optionType_set :: forall a. Ord a => Char -> OptionType a -> OptionType (Set a)
optionType_set Char
sep OptionType a
t = String
-> Set a
-> (String -> Either String (Set a))
-> (Set a -> String)
-> OptionType (Set a)
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
name Set a
forall a. Set a
Set.empty String -> Either String (Set a)
parseSet Set a -> String
showSet where
name :: String
name = String
"set<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ OptionType a -> String
forall val. OptionType val -> String
optionTypeName OptionType a
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
parseSet :: String -> Either String (Set a)
parseSet String
s = case (String -> Either String a) -> [String] -> Either String [a]
forall a.
(String -> Either String a) -> [String] -> Either String [a]
parseList (OptionType a -> String -> Either String a
forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType a
t) (Char -> String -> [String]
split Char
sep String
s) of
Left String
err -> String -> Either String (Set a)
forall a b. a -> Either a b
Left String
err
Right [a]
xs -> Set a -> Either String (Set a)
forall a b. b -> Either a b
Right ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
xs)
showSet :: Set a -> String
showSet Set a
xs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
sep] ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OptionType a -> a -> String
forall val. OptionType val -> val -> String
optionTypeShow OptionType a
t) (Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
xs))
optionType_map :: Ord k
=> Char
-> Char
-> OptionType k
-> OptionType v
-> OptionType (Map.Map k v)
optionType_map :: forall k v.
Ord k =>
Char
-> Char -> OptionType k -> OptionType v -> OptionType (Map k v)
optionType_map Char
itemSep Char
keySep OptionType k
kt OptionType v
vt = String
-> Map k v
-> (String -> Either String (Map k v))
-> (Map k v -> String)
-> OptionType (Map k v)
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
name Map k v
forall k a. Map k a
Map.empty String -> Either String (Map k v)
parser Map k v -> String
showMap where
name :: String
name = String
"map<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ OptionType k -> String
forall val. OptionType val -> String
optionTypeName OptionType k
kt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
forall a. [a] -> [a] -> [a]
++ OptionType v -> String
forall val. OptionType val -> String
optionTypeName OptionType v
vt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
parser :: String -> Either String (Map k v)
parser String
s = Char
-> (String -> Either String k)
-> (String -> Either String v)
-> [String]
-> Either String (Map k v)
forall k v.
Ord k =>
Char
-> (String -> Either String k)
-> (String -> Either String v)
-> [String]
-> Either String (Map k v)
parseMap Char
keySep (OptionType k -> String -> Either String k
forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType k
kt) (OptionType v -> String -> Either String v
forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType v
vt) (Char -> String -> [String]
split Char
itemSep String
s)
showMap :: Map k v -> String
showMap Map k v
m = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
itemSep] (((k, v) -> String) -> [(k, v)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> String
showItem (Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m))
showItem :: (k, v) -> String
showItem (k
k, v
v) = OptionType k -> k -> String
forall val. OptionType val -> val -> String
optionTypeShow OptionType k
kt k
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
keySep] String -> String -> String
forall a. [a] -> [a] -> [a]
++ OptionType v -> v -> String
forall val. OptionType val -> val -> String
optionTypeShow OptionType v
vt v
v
parseList :: (String -> Either String a) -> [String] -> Either String [a]
parseList :: forall a.
(String -> Either String a) -> [String] -> Either String [a]
parseList String -> Either String a
p = [String] -> Either String [a]
loop where
loop :: [String] -> Either String [a]
loop [] = [a] -> Either String [a]
forall a b. b -> Either a b
Right []
loop (String
x:[String]
xs) = case String -> Either String a
p String
x of
Left String
err -> String -> Either String [a]
forall a b. a -> Either a b
Left String
err
Right a
v -> case [String] -> Either String [a]
loop [String]
xs of
Left String
err -> String -> Either String [a]
forall a b. a -> Either a b
Left String
err
Right [a]
vs -> [a] -> Either String [a]
forall a b. b -> Either a b
Right (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
vs)
parseMap :: Ord k => Char -> (String -> Either String k) -> (String -> Either String v) -> [String] -> Either String (Map.Map k v)
parseMap :: forall k v.
Ord k =>
Char
-> (String -> Either String k)
-> (String -> Either String v)
-> [String]
-> Either String (Map k v)
parseMap Char
keySep String -> Either String k
pKey String -> Either String v
pVal = [String] -> Either String (Map k v)
parsed where
parsed :: [String] -> Either String (Map k v)
parsed [String]
strs = case (String -> Either String (k, v))
-> [String] -> Either String [(k, v)]
forall a.
(String -> Either String a) -> [String] -> Either String [a]
parseList String -> Either String (k, v)
pItem [String]
strs of
Left String
err -> String -> Either String (Map k v)
forall a b. a -> Either a b
Left String
err
Right [(k, v)]
xs -> Map k v -> Either String (Map k v)
forall a b. b -> Either a b
Right ([(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k, v)]
xs)
pItem :: String -> Either String (k, v)
pItem String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
keySep) String
s of
(String
sKey, String
valAndSep) -> case String
valAndSep of
[] -> String -> Either String (k, v)
forall a b. a -> Either a b
Left (String
"Map item " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no value.")
Char
_ : String
sVal -> case String -> Either String k
pKey String
sKey of
Left String
err -> String -> Either String (k, v)
forall a b. a -> Either a b
Left String
err
Right k
key -> case String -> Either String v
pVal String
sVal of
Left String
err -> String -> Either String (k, v)
forall a b. a -> Either a b
Left String
err
Right v
val -> (k, v) -> Either String (k, v)
forall a b. b -> Either a b
Right (k
key, v
val)
split :: Char -> String -> [String]
split :: Char -> String -> [String]
split Char
_ [] = []
split Char
sep String
s0 = String -> [String]
loop String
s0 where
loop :: String -> [String]
loop String
s = let
(String
chunk, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
sep) String
s
cont :: [String]
cont = String
chunk String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
loop (String -> String
forall a. HasCallStack => [a] -> [a]
tail String
rest)
in if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest then [String
chunk] else [String]
cont
optionType_list :: Char
-> OptionType a
-> OptionType [a]
optionType_list :: forall a. Char -> OptionType a -> OptionType [a]
optionType_list Char
sep OptionType a
t = String
-> [a]
-> (String -> Either String [a])
-> ([a] -> String)
-> OptionType [a]
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
name [] String -> Either String [a]
parser [a] -> String
shower where
name :: String
name = String
"list<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ OptionType a -> String
forall val. OptionType val -> String
optionTypeName OptionType a
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
parser :: String -> Either String [a]
parser String
s = (String -> Either String a) -> [String] -> Either String [a]
forall a.
(String -> Either String a) -> [String] -> Either String [a]
parseList (OptionType a -> String -> Either String a
forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType a
t) (Char -> String -> [String]
split Char
sep String
s)
shower :: [a] -> String
shower [a]
xs = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate [Char
sep] ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (OptionType a -> a -> String
forall val. OptionType val -> val -> String
optionTypeShow OptionType a
t) [a]
xs)
optionType_enum :: (Bounded a, Enum a, Show a)
=> String
-> OptionType a
optionType_enum :: forall a. (Bounded a, Enum a, Show a) => String -> OptionType a
optionType_enum String
tName = String
-> a
-> (String -> Either String a)
-> (a -> String)
-> OptionType a
forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
tName a
forall a. Bounded a => a
minBound String -> Either String a
parseEnum a -> String
forall a. Show a => a -> String
show where
values :: Map String a
values = [(String, a)] -> Map String a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(a -> String
forall a. Show a => a -> String
show a
x, a
x) | a
x <- a -> [a]
forall a. Enum a => a -> [a]
enumFrom a
forall a. Bounded a => a
minBound]
setString :: String
setString = String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. Show a => a -> String
show (Map String a -> [String]
forall k a. Map k a -> [k]
Map.keys Map String a
values)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
parseEnum :: String -> Either String a
parseEnum String
s = case String -> Map String a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
s Map String a
values of
Maybe a
Nothing -> String -> Either String a
forall a b. a -> Either a b
Left (String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
setString String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
Just a
x -> a -> Either String a
forall a b. b -> Either a b
Right a
x
simpleOption :: SimpleOptionType a
=> String
-> a
-> String
-> DefineOptions a
simpleOption :: forall a.
SimpleOptionType a =>
String -> a -> String -> DefineOptions a
simpleOption String
flag a
def String
desc = OptionType a -> (Option a -> Option a) -> DefineOptions a
forall a. OptionType a -> (Option a -> Option a) -> DefineOptions a
defineOption OptionType a
forall a. SimpleOptionType a => OptionType a
simpleOptionType (\Option a
o -> Option a
o
{ optionLongFlags :: [String]
optionLongFlags = [String
flag]
, optionDefault :: a
optionDefault = a
def
, optionDescription :: String
optionDescription = String
desc
})
defineOption :: OptionType a -> (Option a -> Option a) -> DefineOptions a
defineOption :: forall a. OptionType a -> (Option a -> Option a) -> DefineOptions a
defineOption OptionType a
t Option a -> Option a
fn = a
-> (Integer -> (Integer, [OptionInfo]))
-> (Integer -> Map OptionKey [Token] -> Either String (Integer, a))
-> DefineOptions a
forall a.
a
-> (Integer -> (Integer, [OptionInfo]))
-> (Integer -> Map OptionKey [Token] -> Either String (Integer, a))
-> DefineOptions a
DefineOptions (Option a -> a
forall a. Option a -> a
optionDefault Option a
opt) Integer -> (Integer, [OptionInfo])
getInfo Integer -> Map OptionKey [Token] -> Either String (Integer, a)
parser where
opt :: Option a
opt = Option a -> Option a
fn (Option
{ optionShortFlags :: String
optionShortFlags = []
, optionLongFlags :: [String]
optionLongFlags = []
, optionDefault :: a
optionDefault = OptionType a -> a
forall val. OptionType val -> val
optionTypeDefault OptionType a
t
, optionDescription :: String
optionDescription = String
""
, optionGroup :: Maybe Group
optionGroup = Maybe Group
forall a. Maybe a
Nothing
, optionLocation :: Maybe Location
optionLocation = Maybe Location
forall a. Maybe a
Nothing
})
getInfo :: Integer -> (Integer, [OptionInfo])
getInfo Integer
key = (Integer
keyInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1, [OptionInfo
{ optionInfoKey :: OptionKey
optionInfoKey = Integer -> OptionKey
OptionKeyGenerated Integer
key
, optionInfoShortFlags :: String
optionInfoShortFlags = Option a -> String
forall a. Option a -> String
optionShortFlags Option a
opt
, optionInfoLongFlags :: [String]
optionInfoLongFlags = Option a -> [String]
forall a. Option a -> [String]
optionLongFlags Option a
opt
, optionInfoDefault :: String
optionInfoDefault = OptionType a -> a -> String
forall val. OptionType val -> val -> String
optionTypeShow OptionType a
t (Option a -> a
forall a. Option a -> a
optionDefault Option a
opt)
, optionInfoDescription :: String
optionInfoDescription = Option a -> String
forall a. Option a -> String
optionDescription Option a
opt
, optionInfoGroup :: Maybe Group
optionInfoGroup = Option a -> Maybe Group
forall a. Option a -> Maybe Group
optionGroup Option a
opt
, optionInfoLocation :: Maybe Location
optionInfoLocation = Option a -> Maybe Location
forall a. Option a -> Maybe Location
optionLocation Option a
opt
, optionInfoTypeName :: String
optionInfoTypeName = OptionType a -> String
forall val. OptionType val -> String
optionTypeName OptionType a
t
, optionInfoUnary :: Bool
optionInfoUnary = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (OptionType a -> Maybe a
forall val. OptionType val -> Maybe val
optionTypeUnary OptionType a
t)
, optionInfoUnaryOnly :: Bool
optionInfoUnaryOnly = Bool
False
}])
parseToken :: Token -> Either String a
parseToken Token
tok = case Token
tok of
TokenUnary String
flagName -> case OptionType a -> Maybe a
forall val. OptionType val -> Maybe val
optionTypeUnary OptionType a
t of
Maybe a
Nothing -> String -> Either String a
forall a b. a -> Either a b
Left (String
"The flag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flagName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" requires an argument.")
Just a
val -> a -> Either String a
forall a b. b -> Either a b
Right a
val
Token String
flagName String
rawValue -> case OptionType a -> String -> Either String a
forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType a
t String
rawValue of
Left String
err -> String -> Either String a
forall a b. a -> Either a b
Left (String
"Value for flag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flagName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is invalid: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
Right a
val -> a -> Either String a
forall a b. b -> Either a b
Right a
val
parser :: Integer -> Map OptionKey [Token] -> Either String (Integer, a)
parser Integer
key Map OptionKey [Token]
tokens = case OptionKey -> Map OptionKey [Token] -> Maybe [Token]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Integer -> OptionKey
OptionKeyGenerated Integer
key) Map OptionKey [Token]
tokens of
Maybe [Token]
Nothing -> (Integer, a) -> Either String (Integer, a)
forall a b. b -> Either a b
Right (Integer
keyInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1, Option a -> a
forall a. Option a -> a
optionDefault Option a
opt)
Just [Token]
toks -> case [Token]
toks of
[] -> (Integer, a) -> Either String (Integer, a)
forall a b. b -> Either a b
Right (Integer
keyInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1, Option a -> a
forall a. Option a -> a
optionDefault Option a
opt)
[Token
tok] -> case Token -> Either String a
parseToken Token
tok of
Left String
err -> String -> Either String (Integer, a)
forall a b. a -> Either a b
Left String
err
Right a
val -> (Integer, a) -> Either String (Integer, a)
forall a b. b -> Either a b
Right (Integer
keyInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1, a
val)
[Token]
_ -> case OptionType a -> Maybe ([a] -> a)
forall val. OptionType val -> Maybe ([val] -> val)
optionTypeMerge OptionType a
t of
Maybe ([a] -> a)
Nothing -> String -> Either String (Integer, a)
forall a b. a -> Either a b
Left (String
"Multiple values for flag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Token] -> String
showMultipleFlagValues [Token]
toks)
Just [a] -> a
appendFn -> case (Token -> Either String a) -> [Token] -> Either String [a]
forall a err b. (a -> Either err b) -> [a] -> Either err [b]
mapEither Token -> Either String a
parseToken [Token]
toks of
Left String
err -> String -> Either String (Integer, a)
forall a b. a -> Either a b
Left String
err
Right [a]
vals -> (Integer, a) -> Either String (Integer, a)
forall a b. b -> Either a b
Right (Integer
keyInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1, [a] -> a
appendFn [a]
vals)
showMultipleFlagValues :: [Token] -> String
showMultipleFlagValues :: [Token] -> String
showMultipleFlagValues = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String) -> ([Token] -> [String]) -> [Token] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token -> String) -> [Token] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Token -> String
showToken where
showToken :: Token -> String
showToken (TokenUnary String
flagName) = String
flagName
showToken (Token String
flagName String
rawValue) = String -> String
forall a. Show a => a -> String
show (String
flagName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rawValue)
data Option a = Option
{
forall a. Option a -> String
optionShortFlags :: [Char]
, forall a. Option a -> [String]
optionLongFlags :: [String]
, forall a. Option a -> a
optionDefault :: a
, forall a. Option a -> String
optionDescription :: String
, forall a. Option a -> Maybe Group
optionGroup :: Maybe Group
, forall a. Option a -> Maybe Location
optionLocation :: Maybe Location
}
validateOptionDefs :: [OptionInfo] -> [(String, [OptionInfo])] -> Either String OptionDefinitions
validateOptionDefs :: [OptionInfo]
-> [(String, [OptionInfo])] -> Either String OptionDefinitions
validateOptionDefs [OptionInfo]
cmdInfos [(String, [OptionInfo])]
subInfos = Identity (Either String OptionDefinitions)
-> Either String OptionDefinitions
forall a. Identity a -> a
runIdentity (Identity (Either String OptionDefinitions)
-> Either String OptionDefinitions)
-> Identity (Either String OptionDefinitions)
-> Either String OptionDefinitions
forall a b. (a -> b) -> a -> b
$ ErrorT String Identity OptionDefinitions
-> Identity (Either String OptionDefinitions)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT String Identity OptionDefinitions
-> Identity (Either String OptionDefinitions))
-> ErrorT String Identity OptionDefinitions
-> Identity (Either String OptionDefinitions)
forall a b. (a -> b) -> a -> b
$ do
let subcmdNames :: [String]
subcmdNames = ((String, [OptionInfo]) -> String)
-> [(String, [OptionInfo])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, [OptionInfo]) -> String
forall a b. (a, b) -> a
fst [(String, [OptionInfo])]
subInfos
if Set String -> Int
forall a. Set a -> Int
Set.size ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
subcmdNames) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
subcmdNames
then ErrorType (ErrorT String Identity) -> ErrorT String Identity ()
forall a.
ErrorType (ErrorT String Identity) -> ErrorT String Identity a
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError String
ErrorType (ErrorT String Identity)
"Multiple subcommands exist with the same name."
else () -> ErrorT String Identity ()
forall a. a -> ErrorT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let allOptInfos :: [OptionInfo]
allOptInfos = [OptionInfo]
cmdInfos [OptionInfo] -> [OptionInfo] -> [OptionInfo]
forall a. [a] -> [a] -> [a]
++ [[OptionInfo]] -> [OptionInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[OptionInfo]
infos | (String
_, [OptionInfo]
infos) <- [(String, [OptionInfo])]
subInfos]
case (OptionInfo -> Either String ())
-> [OptionInfo] -> Either String [()]
forall a err b. (a -> Either err b) -> [a] -> Either err [b]
mapEither OptionInfo -> Either String ()
optValidFlags [OptionInfo]
allOptInfos of
Left String
err -> ErrorType (ErrorT String Identity) -> ErrorT String Identity ()
forall a.
ErrorType (ErrorT String Identity) -> ErrorT String Identity a
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError String
ErrorType (ErrorT String Identity)
err
Right [()]
_ -> () -> ErrorT String Identity ()
forall a. a -> ErrorT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Map DeDupFlag OptionInfo
cmdDeDupedFlags <- Map DeDupFlag OptionInfo
-> [OptionInfo]
-> ErrorT String Identity (Map DeDupFlag OptionInfo)
checkNoDuplicateFlags Map DeDupFlag OptionInfo
forall k a. Map k a
Map.empty [OptionInfo]
cmdInfos
[(String, [OptionInfo])]
-> ((String, [OptionInfo])
-> ErrorT String Identity (Map DeDupFlag OptionInfo))
-> ErrorT String Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, [OptionInfo])]
subInfos (\(String, [OptionInfo])
subInfo -> Map DeDupFlag OptionInfo
-> [OptionInfo]
-> ErrorT String Identity (Map DeDupFlag OptionInfo)
checkNoDuplicateFlags Map DeDupFlag OptionInfo
cmdDeDupedFlags ((String, [OptionInfo]) -> [OptionInfo]
forall a b. (a, b) -> b
snd (String, [OptionInfo])
subInfo))
OptionDefinitions -> ErrorT String Identity OptionDefinitions
forall a. a -> ErrorT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (OptionDefinitions -> OptionDefinitions
addHelpFlags ([OptionInfo] -> [(String, [OptionInfo])] -> OptionDefinitions
OptionDefinitions [OptionInfo]
cmdInfos [(String, [OptionInfo])]
subInfos))
optValidFlags :: OptionInfo -> Either String ()
optValidFlags :: OptionInfo -> Either String ()
optValidFlags OptionInfo
info = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (OptionInfo -> String
optionInfoShortFlags OptionInfo
info) Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (OptionInfo -> [String]
optionInfoLongFlags OptionInfo
info)
then case OptionInfo -> Maybe Location
optionInfoLocation OptionInfo
info of
Maybe Location
Nothing -> String -> Either String ()
forall a b. a -> Either a b
Left (String
"Option with description " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (OptionInfo -> String
optionInfoDescription OptionInfo
info) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no flags.")
Just Location
loc -> String -> Either String ()
forall a b. a -> Either a b
Left (String
"Option with description " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (OptionInfo -> String
optionInfoDescription OptionInfo
info) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
locationFilename Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Location -> Integer
locationLine Location
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no flags.")
else () -> Either String ()
forall a b. b -> Either a b
Right ()
data DeDupFlag = DeDupShort Char | DeDupLong String
deriving (DeDupFlag -> DeDupFlag -> Bool
(DeDupFlag -> DeDupFlag -> Bool)
-> (DeDupFlag -> DeDupFlag -> Bool) -> Eq DeDupFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeDupFlag -> DeDupFlag -> Bool
== :: DeDupFlag -> DeDupFlag -> Bool
$c/= :: DeDupFlag -> DeDupFlag -> Bool
/= :: DeDupFlag -> DeDupFlag -> Bool
Eq, Eq DeDupFlag
Eq DeDupFlag
-> (DeDupFlag -> DeDupFlag -> Ordering)
-> (DeDupFlag -> DeDupFlag -> Bool)
-> (DeDupFlag -> DeDupFlag -> Bool)
-> (DeDupFlag -> DeDupFlag -> Bool)
-> (DeDupFlag -> DeDupFlag -> Bool)
-> (DeDupFlag -> DeDupFlag -> DeDupFlag)
-> (DeDupFlag -> DeDupFlag -> DeDupFlag)
-> Ord DeDupFlag
DeDupFlag -> DeDupFlag -> Bool
DeDupFlag -> DeDupFlag -> Ordering
DeDupFlag -> DeDupFlag -> DeDupFlag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DeDupFlag -> DeDupFlag -> Ordering
compare :: DeDupFlag -> DeDupFlag -> Ordering
$c< :: DeDupFlag -> DeDupFlag -> Bool
< :: DeDupFlag -> DeDupFlag -> Bool
$c<= :: DeDupFlag -> DeDupFlag -> Bool
<= :: DeDupFlag -> DeDupFlag -> Bool
$c> :: DeDupFlag -> DeDupFlag -> Bool
> :: DeDupFlag -> DeDupFlag -> Bool
$c>= :: DeDupFlag -> DeDupFlag -> Bool
>= :: DeDupFlag -> DeDupFlag -> Bool
$cmax :: DeDupFlag -> DeDupFlag -> DeDupFlag
max :: DeDupFlag -> DeDupFlag -> DeDupFlag
$cmin :: DeDupFlag -> DeDupFlag -> DeDupFlag
min :: DeDupFlag -> DeDupFlag -> DeDupFlag
Ord, Int -> DeDupFlag -> String -> String
[DeDupFlag] -> String -> String
DeDupFlag -> String
(Int -> DeDupFlag -> String -> String)
-> (DeDupFlag -> String)
-> ([DeDupFlag] -> String -> String)
-> Show DeDupFlag
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DeDupFlag -> String -> String
showsPrec :: Int -> DeDupFlag -> String -> String
$cshow :: DeDupFlag -> String
show :: DeDupFlag -> String
$cshowList :: [DeDupFlag] -> String -> String
showList :: [DeDupFlag] -> String -> String
Show)
checkNoDuplicateFlags :: Map.Map DeDupFlag OptionInfo -> [OptionInfo] -> ErrorT String Identity (Map.Map DeDupFlag OptionInfo)
checkNoDuplicateFlags :: Map DeDupFlag OptionInfo
-> [OptionInfo]
-> ErrorT String Identity (Map DeDupFlag OptionInfo)
checkNoDuplicateFlags Map DeDupFlag OptionInfo
checked [] = Map DeDupFlag OptionInfo
-> ErrorT String Identity (Map DeDupFlag OptionInfo)
forall a. a -> ErrorT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Map DeDupFlag OptionInfo
checked
checkNoDuplicateFlags Map DeDupFlag OptionInfo
checked (OptionInfo
info:[OptionInfo]
infos) = do
let mappedShort :: [DeDupFlag]
mappedShort = (Char -> DeDupFlag) -> String -> [DeDupFlag]
forall a b. (a -> b) -> [a] -> [b]
map Char -> DeDupFlag
DeDupShort (OptionInfo -> String
optionInfoShortFlags OptionInfo
info)
let mappedLong :: [DeDupFlag]
mappedLong = (String -> DeDupFlag) -> [String] -> [DeDupFlag]
forall a b. (a -> b) -> [a] -> [b]
map String -> DeDupFlag
DeDupLong (OptionInfo -> [String]
optionInfoLongFlags OptionInfo
info)
let mappedFlags :: [DeDupFlag]
mappedFlags = [DeDupFlag]
mappedShort [DeDupFlag] -> [DeDupFlag] -> [DeDupFlag]
forall a. [a] -> [a] -> [a]
++ [DeDupFlag]
mappedLong
[DeDupFlag]
-> (DeDupFlag -> ErrorT String Identity ())
-> ErrorT String Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DeDupFlag]
mappedFlags ((DeDupFlag -> ErrorT String Identity ())
-> ErrorT String Identity ())
-> (DeDupFlag -> ErrorT String Identity ())
-> ErrorT String Identity ()
forall a b. (a -> b) -> a -> b
$ \DeDupFlag
mapKey -> case DeDupFlag -> Map DeDupFlag OptionInfo -> Maybe OptionInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DeDupFlag
mapKey Map DeDupFlag OptionInfo
checked of
Maybe OptionInfo
Nothing -> () -> ErrorT String Identity ()
forall a. a -> ErrorT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just OptionInfo
prevInfo -> if OptionInfo -> OptionInfo -> Bool
eqIgnoringKey OptionInfo
info OptionInfo
prevInfo
then () -> ErrorT String Identity ()
forall a. a -> ErrorT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else let
flagName :: String
flagName = case DeDupFlag
mapKey of
DeDupShort Char
flag -> Char
'-' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
flag Char -> String -> String
forall a. a -> [a] -> [a]
: []
DeDupLong String
long -> String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
long
in ErrorType (ErrorT String Identity) -> ErrorT String Identity ()
forall a.
ErrorType (ErrorT String Identity) -> ErrorT String Identity a
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError (String
"Duplicate option flag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
flagName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
let infoMap :: Map DeDupFlag OptionInfo
infoMap = [(DeDupFlag, OptionInfo)] -> Map DeDupFlag OptionInfo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(DeDupFlag
f, OptionInfo
info) | DeDupFlag
f <- [DeDupFlag]
mappedFlags]
Map DeDupFlag OptionInfo
-> [OptionInfo]
-> ErrorT String Identity (Map DeDupFlag OptionInfo)
checkNoDuplicateFlags (Map DeDupFlag OptionInfo
-> Map DeDupFlag OptionInfo -> Map DeDupFlag OptionInfo
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map DeDupFlag OptionInfo
checked Map DeDupFlag OptionInfo
infoMap) [OptionInfo]
infos
eqIgnoringKey :: OptionInfo -> OptionInfo -> Bool
eqIgnoringKey :: OptionInfo -> OptionInfo -> Bool
eqIgnoringKey OptionInfo
x OptionInfo
y = OptionInfo -> OptionInfo
normKey OptionInfo
x OptionInfo -> OptionInfo -> Bool
forall a. Eq a => a -> a -> Bool
== OptionInfo -> OptionInfo
normKey OptionInfo
y where
normKey :: OptionInfo -> OptionInfo
normKey OptionInfo
info = OptionInfo
info { optionInfoKey :: OptionKey
optionInfoKey = OptionKey
OptionKeyIgnored }
class Parsed a where
parsedError_ :: a -> Maybe String
parsedHelp_ :: a -> String
data ParsedOptions opts = ParsedOptions (Maybe opts) (Maybe String) String [String]
data ParsedSubcommand action = ParsedSubcommand (Maybe action) (Maybe String) String
instance Parsed (ParsedOptions a) where
parsedError_ :: ParsedOptions a -> Maybe String
parsedError_ (ParsedOptions Maybe a
_ Maybe String
x String
_ [String]
_) = Maybe String
x
parsedHelp_ :: ParsedOptions a -> String
parsedHelp_ (ParsedOptions Maybe a
_ Maybe String
_ String
x [String]
_) = String
x
instance Parsed (ParsedSubcommand a) where
parsedError_ :: ParsedSubcommand a -> Maybe String
parsedError_ (ParsedSubcommand Maybe a
_ Maybe String
x String
_) = Maybe String
x
parsedHelp_ :: ParsedSubcommand a -> String
parsedHelp_ (ParsedSubcommand Maybe a
_ Maybe String
_ String
x) = String
x
parsedOptions :: ParsedOptions opts -> Maybe opts
parsedOptions :: forall opts. ParsedOptions opts -> Maybe opts
parsedOptions (ParsedOptions Maybe opts
x Maybe String
_ String
_ [String]
_) = Maybe opts
x
parsedArguments :: ParsedOptions opts -> [String]
parsedArguments :: forall opts. ParsedOptions opts -> [String]
parsedArguments (ParsedOptions Maybe opts
_ Maybe String
_ String
_ [String]
x) = [String]
x
parsedSubcommand :: ParsedSubcommand action -> Maybe action
parsedSubcommand :: forall action. ParsedSubcommand action -> Maybe action
parsedSubcommand (ParsedSubcommand Maybe action
x Maybe String
_ String
_) = Maybe action
x
parsedError :: Parsed a => a -> Maybe String
parsedError :: forall a. Parsed a => a -> Maybe String
parsedError = a -> Maybe String
forall a. Parsed a => a -> Maybe String
parsedError_
parsedHelp :: Parsed a => a -> String
parsedHelp :: forall a. Parsed a => a -> String
parsedHelp = a -> String
forall a. Parsed a => a -> String
parsedHelp_
parseOptions :: Options opts => [String] -> ParsedOptions opts
parseOptions :: forall opts. Options opts => [String] -> ParsedOptions opts
parseOptions [String]
argv = ParsedOptions opts
parsed where
(DefineOptions opts
_ Integer -> (Integer, [OptionInfo])
getInfos Integer -> Map OptionKey [Token] -> Either String (Integer, opts)
parser) = DefineOptions opts
forall opts. Options opts => DefineOptions opts
defineOptions
(Integer
_, [OptionInfo]
optionInfos) = Integer -> (Integer, [OptionInfo])
getInfos Integer
0
parseTokens :: Map OptionKey [Token] -> Either String (Integer, opts)
parseTokens = Integer -> Map OptionKey [Token] -> Either String (Integer, opts)
parser Integer
0
parsed :: ParsedOptions opts
parsed = case [OptionInfo]
-> [(String, [OptionInfo])] -> Either String OptionDefinitions
validateOptionDefs [OptionInfo]
optionInfos [] of
Left String
err -> Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions Maybe opts
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
err) String
"" []
Right OptionDefinitions
optionDefs -> case OptionDefinitions
-> [String] -> (Maybe String, Either String Tokens)
tokenize (OptionDefinitions -> OptionDefinitions
addHelpFlags OptionDefinitions
optionDefs) [String]
argv of
(Maybe String
_, Left String
err) -> Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions Maybe opts
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
err) (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs Maybe String
forall a. Maybe a
Nothing) []
(Maybe String
_, Right Tokens
tokens) -> case Tokens -> Maybe HelpFlag
checkHelpFlag Tokens
tokens of
Just HelpFlag
helpFlag -> Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions Maybe opts
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
helpFlag OptionDefinitions
optionDefs Maybe String
forall a. Maybe a
Nothing) []
Maybe HelpFlag
Nothing -> case Map OptionKey [Token] -> Either String (Integer, opts)
parseTokens (Tokens -> Map OptionKey [Token]
tokensMap Tokens
tokens) of
Left String
err -> Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions Maybe opts
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
err) (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs Maybe String
forall a. Maybe a
Nothing) []
Right (Integer
_, opts
opts) -> Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions (opts -> Maybe opts
forall a. a -> Maybe a
Just opts
opts) Maybe String
forall a. Maybe a
Nothing (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs Maybe String
forall a. Maybe a
Nothing) (Tokens -> [String]
tokensArgv Tokens
tokens)
runCommand :: (MonadIO m, Options opts) => (opts -> [String] -> m a) -> m a
runCommand :: forall (m :: * -> *) opts a.
(MonadIO m, Options opts) =>
(opts -> [String] -> m a) -> m a
runCommand opts -> [String] -> m a
io = do
[String]
argv <- IO [String] -> m [String]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
System.Environment.getArgs
let parsed :: ParsedOptions opts
parsed = [String] -> ParsedOptions opts
forall opts. Options opts => [String] -> ParsedOptions opts
parseOptions [String]
argv
case ParsedOptions opts -> Maybe opts
forall opts. ParsedOptions opts -> Maybe opts
parsedOptions ParsedOptions opts
parsed of
Just opts
opts -> opts -> [String] -> m a
io opts
opts (ParsedOptions opts -> [String]
forall opts. ParsedOptions opts -> [String]
parsedArguments ParsedOptions opts
parsed)
Maybe opts
Nothing -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ case ParsedOptions opts -> Maybe String
forall a. Parsed a => a -> Maybe String
parsedError ParsedOptions opts
parsed of
Just String
err -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (ParsedOptions opts -> String
forall a. Parsed a => a -> String
parsedHelp ParsedOptions opts
parsed)
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
IO a
forall a. IO a
exitFailure
Maybe String
Nothing -> do
Handle -> String -> IO ()
hPutStr Handle
stdout (ParsedOptions opts -> String
forall a. Parsed a => a -> String
parsedHelp ParsedOptions opts
parsed)
IO a
forall a. IO a
exitSuccess
data Subcommand cmdOpts action = Subcommand String (Integer -> ([OptionInfo], (cmdOpts -> Tokens -> Either String action), Integer))
subcommand :: (Options cmdOpts, Options subcmdOpts)
=> String
-> (cmdOpts -> subcmdOpts -> [String] -> action)
-> Subcommand cmdOpts action
subcommand :: forall cmdOpts subcmdOpts action.
(Options cmdOpts, Options subcmdOpts) =>
String
-> (cmdOpts -> subcmdOpts -> [String] -> action)
-> Subcommand cmdOpts action
subcommand String
name cmdOpts -> subcmdOpts -> [String] -> action
fn = String
-> (Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer))
-> Subcommand cmdOpts action
forall cmdOpts action.
String
-> (Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer))
-> Subcommand cmdOpts action
Subcommand String
name (\Integer
initialKey -> let
(DefineOptions subcmdOpts
_ Integer -> (Integer, [OptionInfo])
getInfos Integer
-> Map OptionKey [Token] -> Either String (Integer, subcmdOpts)
parser) = DefineOptions subcmdOpts
forall opts. Options opts => DefineOptions opts
defineOptions
(Integer
nextKey, [OptionInfo]
optionInfos) = Integer -> (Integer, [OptionInfo])
getInfos Integer
initialKey
parseTokens :: Map OptionKey [Token] -> Either String (Integer, subcmdOpts)
parseTokens = Integer
-> Map OptionKey [Token] -> Either String (Integer, subcmdOpts)
parser Integer
initialKey
runAction :: cmdOpts -> Tokens -> Either String action
runAction cmdOpts
cmdOpts Tokens
tokens = case Map OptionKey [Token] -> Either String (Integer, subcmdOpts)
parseTokens (Tokens -> Map OptionKey [Token]
tokensMap Tokens
tokens) of
Left String
err -> String -> Either String action
forall a b. a -> Either a b
Left String
err
Right (Integer
_, subcmdOpts
subOpts) -> action -> Either String action
forall a b. b -> Either a b
Right (cmdOpts -> subcmdOpts -> [String] -> action
fn cmdOpts
cmdOpts subcmdOpts
subOpts (Tokens -> [String]
tokensArgv Tokens
tokens))
in ([OptionInfo]
optionInfos, cmdOpts -> Tokens -> Either String action
runAction, Integer
nextKey))
parseSubcommand :: Options cmdOpts => [Subcommand cmdOpts action] -> [String] -> ParsedSubcommand action
parseSubcommand :: forall cmdOpts action.
Options cmdOpts =>
[Subcommand cmdOpts action] -> [String] -> ParsedSubcommand action
parseSubcommand [Subcommand cmdOpts action]
subcommands [String]
argv = ParsedSubcommand action
parsed where
(DefineOptions cmdOpts
_ Integer -> (Integer, [OptionInfo])
getInfos Integer
-> Map OptionKey [Token] -> Either String (Integer, cmdOpts)
parser) = DefineOptions cmdOpts
forall opts. Options opts => DefineOptions opts
defineOptions
(Integer
cmdNextKey, [OptionInfo]
cmdInfos) = Integer -> (Integer, [OptionInfo])
getInfos Integer
0
cmdParseTokens :: Map OptionKey [Token] -> Either String (Integer, cmdOpts)
cmdParseTokens = Integer
-> Map OptionKey [Token] -> Either String (Integer, cmdOpts)
parser Integer
0
subcmdInfos :: [(String, [OptionInfo])]
subcmdInfos = do
Subcommand String
name Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer)
fn <- [Subcommand cmdOpts action]
subcommands
let ([OptionInfo]
infos, cmdOpts -> Tokens -> Either String action
_, Integer
_) = Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer)
fn Integer
cmdNextKey
(String, [OptionInfo]) -> [(String, [OptionInfo])]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, [OptionInfo]
infos)
subcmdRunners :: Map String (cmdOpts -> Tokens -> Either String action)
subcmdRunners = [(String, cmdOpts -> Tokens -> Either String action)]
-> Map String (cmdOpts -> Tokens -> Either String action)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, cmdOpts -> Tokens -> Either String action)]
-> Map String (cmdOpts -> Tokens -> Either String action))
-> [(String, cmdOpts -> Tokens -> Either String action)]
-> Map String (cmdOpts -> Tokens -> Either String action)
forall a b. (a -> b) -> a -> b
$ do
Subcommand String
name Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer)
fn <- [Subcommand cmdOpts action]
subcommands
let ([OptionInfo]
_, cmdOpts -> Tokens -> Either String action
runner, Integer
_) = Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer)
fn Integer
cmdNextKey
(String, cmdOpts -> Tokens -> Either String action)
-> [(String, cmdOpts -> Tokens -> Either String action)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, cmdOpts -> Tokens -> Either String action
runner)
parsed :: ParsedSubcommand action
parsed = case [OptionInfo]
-> [(String, [OptionInfo])] -> Either String OptionDefinitions
validateOptionDefs [OptionInfo]
cmdInfos [(String, [OptionInfo])]
subcmdInfos of
Left String
err -> Maybe action -> Maybe String -> String -> ParsedSubcommand action
forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand Maybe action
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
err) String
""
Right OptionDefinitions
optionDefs -> case OptionDefinitions
-> [String] -> (Maybe String, Either String Tokens)
tokenize (OptionDefinitions -> OptionDefinitions
addHelpFlags OptionDefinitions
optionDefs) [String]
argv of
(Maybe String
subcmd, Left String
err) -> Maybe action -> Maybe String -> String -> ParsedSubcommand action
forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand Maybe action
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
err) (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs Maybe String
subcmd)
(Maybe String
subcmd, Right Tokens
tokens) -> case Tokens -> Maybe HelpFlag
checkHelpFlag Tokens
tokens of
Just HelpFlag
helpFlag -> Maybe action -> Maybe String -> String -> ParsedSubcommand action
forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand Maybe action
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
helpFlag OptionDefinitions
optionDefs Maybe String
subcmd)
Maybe HelpFlag
Nothing -> case Tokens -> Maybe String -> Either String action
findAction Tokens
tokens Maybe String
subcmd of
Left String
err -> Maybe action -> Maybe String -> String -> ParsedSubcommand action
forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand Maybe action
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
err) (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs Maybe String
subcmd)
Right action
action -> Maybe action -> Maybe String -> String -> ParsedSubcommand action
forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand (action -> Maybe action
forall a. a -> Maybe a
Just action
action) Maybe String
forall a. Maybe a
Nothing (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs Maybe String
subcmd)
findAction :: Tokens -> Maybe String -> Either String action
findAction Tokens
_ Maybe String
Nothing = String -> Either String action
forall a b. a -> Either a b
Left String
"No subcommand specified"
findAction Tokens
tokens (Just String
subcmdName) = case Map OptionKey [Token] -> Either String (Integer, cmdOpts)
cmdParseTokens (Tokens -> Map OptionKey [Token]
tokensMap Tokens
tokens) of
Left String
err -> String -> Either String action
forall a b. a -> Either a b
Left String
err
Right (Integer
_, cmdOpts
cmdOpts) -> case String
-> Map String (cmdOpts -> Tokens -> Either String action)
-> Maybe (cmdOpts -> Tokens -> Either String action)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
subcmdName Map String (cmdOpts -> Tokens -> Either String action)
subcmdRunners of
Maybe (cmdOpts -> Tokens -> Either String action)
Nothing -> String -> Either String action
forall a b. a -> Either a b
Left (String
"Unknown subcommand " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
subcmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
Just cmdOpts -> Tokens -> Either String action
getRunner -> case cmdOpts -> Tokens -> Either String action
getRunner cmdOpts
cmdOpts Tokens
tokens of
Left String
err -> String -> Either String action
forall a b. a -> Either a b
Left String
err
Right action
action -> action -> Either String action
forall a b. b -> Either a b
Right action
action
runSubcommand :: (Options opts, MonadIO m) => [Subcommand opts (m a)] -> m a
runSubcommand :: forall opts (m :: * -> *) a.
(Options opts, MonadIO m) =>
[Subcommand opts (m a)] -> m a
runSubcommand [Subcommand opts (m a)]
subcommands = do
[String]
argv <- IO [String] -> m [String]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
System.Environment.getArgs
let parsed :: ParsedSubcommand (m a)
parsed = [Subcommand opts (m a)] -> [String] -> ParsedSubcommand (m a)
forall cmdOpts action.
Options cmdOpts =>
[Subcommand cmdOpts action] -> [String] -> ParsedSubcommand action
parseSubcommand [Subcommand opts (m a)]
subcommands [String]
argv
case ParsedSubcommand (m a) -> Maybe (m a)
forall action. ParsedSubcommand action -> Maybe action
parsedSubcommand ParsedSubcommand (m a)
parsed of
Just m a
cmd -> m a
cmd
Maybe (m a)
Nothing -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ case ParsedSubcommand (m a) -> Maybe String
forall a. Parsed a => a -> Maybe String
parsedError ParsedSubcommand (m a)
parsed of
Just String
err -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (ParsedSubcommand (m a) -> String
forall a. Parsed a => a -> String
parsedHelp ParsedSubcommand (m a)
parsed)
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
IO a
forall a. IO a
exitFailure
Maybe String
Nothing -> do
Handle -> String -> IO ()
hPutStr Handle
stdout (ParsedSubcommand (m a) -> String
forall a. Parsed a => a -> String
parsedHelp ParsedSubcommand (m a)
parsed)
IO a
forall a. IO a
exitSuccess