{-# 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 :: (a -> b) -> DefineOptions a -> DefineOptions b
fmap fn :: a -> b
fn (DefineOptions defaultValue :: a
defaultValue getInfo :: Integer -> (Integer, [OptionInfo])
getInfo parse :: 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 (\key :: Integer
key tokens :: Map OptionKey [Token]
tokens -> case Integer -> Map OptionKey [Token] -> Either String (Integer, a)
parse Integer
key Map OptionKey [Token]
tokens of
Left err :: String
err -> String -> Either String (Integer, b)
forall a b. a -> Either a b
Left String
err
Right (key' :: Integer
key', a :: 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 :: a -> DefineOptions a
pure a :: 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 (\key :: Integer
key -> (Integer
key, [])) (\key :: Integer
key _ -> (Integer, a) -> Either String (Integer, a)
forall a b. b -> Either a b
Right (Integer
key, a
a))
(DefineOptions acc_default :: a -> b
acc_default acc_getInfo :: Integer -> (Integer, [OptionInfo])
acc_getInfo acc_parse :: Integer -> Map OptionKey [Token] -> Either String (Integer, a -> b)
acc_parse) <*> :: DefineOptions (a -> b) -> DefineOptions a -> DefineOptions b
<*> (DefineOptions defaultValue :: a
defaultValue getInfo :: Integer -> (Integer, [OptionInfo])
getInfo parse :: 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)
(\key :: Integer
key -> case Integer -> (Integer, [OptionInfo])
acc_getInfo Integer
key of
(key' :: Integer
key', infos :: [OptionInfo]
infos) -> case Integer -> (Integer, [OptionInfo])
getInfo Integer
key' of
(key'' :: Integer
key'', infos' :: [OptionInfo]
infos') -> (Integer
key'', [OptionInfo]
infos [OptionInfo] -> [OptionInfo] -> [OptionInfo]
forall a. [a] -> [a] -> [a]
++ [OptionInfo]
infos'))
(\key :: Integer
key tokens :: Map OptionKey [Token]
tokens -> case Integer -> Map OptionKey [Token] -> Either String (Integer, a -> b)
acc_parse Integer
key Map OptionKey [Token]
tokens of
Left err :: String
err -> String -> Either String (Integer, b)
forall a b. a -> Either a b
Left String
err
Right (key' :: Integer
key', fn :: a -> b
fn) -> case Integer -> Map OptionKey [Token] -> Either String (Integer, a)
parse Integer
key' Map OptionKey [Token]
tokens of
Left err :: String
err -> String -> Either String (Integer, b)
forall a b. a -> Either a b
Left String
err
Right (key'' :: Integer
key'', a :: 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 :: opts
defaultOptions = case DefineOptions opts
forall opts. Options opts => DefineOptions opts
defineOptions of
(DefineOptions def :: opts
def _ _) -> opts
def
data OptionType val = OptionType
{
OptionType val -> String
optionTypeName :: String
, OptionType val -> val
optionTypeDefault :: val
, OptionType val -> String -> Either String val
optionTypeParse :: String -> Either String val
, OptionType val -> val -> String
optionTypeShow :: val -> String
, OptionType val -> Maybe val
optionTypeUnary :: Maybe 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 :: String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType name :: String
name def :: val
def parse :: String -> Either String val
parse show' :: 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 "bool" Bool
False String -> Either String Bool
parseBool (\x :: Bool
x -> if Bool
x then "true" else "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 s :: String
s = case String
s of
"true" -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
True
"false" -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
False
_ -> 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]
++ " 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 "text" "" 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 "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 s :: 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]
++ " is not an integer.")
valid :: Bool
valid = case String
s of
[] -> Bool
False
'-':s' :: String
s' -> String -> Bool
allDigits String
s'
_ -> String -> Bool
allDigits String
s
allDigits :: String -> Bool
allDigits = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '9')
parseBoundedIntegral :: (Bounded a, Integral a) => String -> String -> Either String a
parseBoundedIntegral :: String -> String -> Either String a
parseBoundedIntegral label :: String
label = String -> Either String a
parse where
getBounds :: (Bounded a, Integral a) => (String -> Either String a) -> a -> a -> (Integer, Integer)
getBounds :: (String -> Either String a) -> a -> a -> (Integer, Integer)
getBounds _ min' :: a
min' max' :: a
max' = (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
min', a -> Integer
forall a. Integral a => a -> Integer
toInteger a
max')
(minInt :: Integer
minInt, maxInt :: 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 s :: String
s = case String -> Either String Integer
parseInteger String
s of
Left err :: String
err -> String -> Either String a
forall a b. a -> Either a b
Left String
err
Right int :: 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]
++ " 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
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
maxInt String -> String -> String
forall a. [a] -> [a] -> [a]
++ "] of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
label String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".")
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 :: String -> OptionType a
optionTypeBoundedInt tName :: 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 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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "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 "float32" 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 "float64" 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 :: String -> Either String a
parseFloat s :: String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
[(x :: a
x, "")] -> a -> Either String a
forall a b. b -> Either a b
Right a
x
_ -> 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]
++ " 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 :: OptionType a -> OptionType (Maybe a)
optionType_maybe t :: 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 = "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]
++ ">"
unary :: Maybe (Maybe a)
unary = case OptionType a -> Maybe a
forall val. OptionType val -> Maybe val
optionTypeUnary OptionType a
t of
Nothing -> Maybe (Maybe a)
forall a. Maybe a
Nothing
Just val :: 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 :: OptionType val -> String -> Either String (Maybe val)
parseMaybe t :: OptionType val
t s :: String
s = case String
s of
"" -> Maybe val -> Either String (Maybe val)
forall a b. b -> Either a b
Right Maybe val
forall a. Maybe a
Nothing
_ -> case OptionType val -> String -> Either String val
forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType val
t String
s of
Left err :: String
err -> String -> Either String (Maybe val)
forall a b. a -> Either a b
Left String
err
Right a :: 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 :: OptionType val -> Maybe val -> String
showMaybe _ Nothing = ""
showMaybe t :: OptionType val
t (Just x :: 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 :: Char -> OptionType a -> OptionType (Set a)
optionType_set sep :: Char
sep t :: 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 = "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]
++ ">"
parseSet :: String -> Either String (Set a)
parseSet s :: 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 err :: String
err -> String -> Either String (Set a)
forall a b. a -> Either a b
Left String
err
Right xs :: [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 xs :: 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 :: Char
-> Char -> OptionType k -> OptionType v -> OptionType (Map k v)
optionType_map itemSep :: Char
itemSep keySep :: Char
keySep kt :: OptionType k
kt vt :: 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 = "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
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]
++ ">"
parser :: String -> Either String (Map k v)
parser s :: 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 m :: 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
k, v :: 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 :: (String -> Either String a) -> [String] -> Either String [a]
parseList p :: 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 (x :: String
x:xs :: [String]
xs) = case String -> Either String a
p String
x of
Left err :: String
err -> String -> Either String [a]
forall a b. a -> Either a b
Left String
err
Right v :: a
v -> case [String] -> Either String [a]
loop [String]
xs of
Left err :: String
err -> String -> Either String [a]
forall a b. a -> Either a b
Left String
err
Right vs :: [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 :: Char
-> (String -> Either String k)
-> (String -> Either String v)
-> [String]
-> Either String (Map k v)
parseMap keySep :: Char
keySep pKey :: String -> Either String k
pKey pVal :: String -> Either String v
pVal = [String] -> Either String (Map k v)
parsed where
parsed :: [String] -> Either String (Map k v)
parsed strs :: [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 err :: String
err -> String -> Either String (Map k v)
forall a b. a -> Either a b
Left String
err
Right xs :: [(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 s :: 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
(sKey :: String
sKey, valAndSep :: String
valAndSep) -> case String
valAndSep of
[] -> String -> Either String (k, v)
forall a b. a -> Either a b
Left ("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]
++ " has no value.")
_ : sVal :: String
sVal -> case String -> Either String k
pKey String
sKey of
Left err :: String
err -> String -> Either String (k, v)
forall a b. a -> Either a b
Left String
err
Right key :: k
key -> case String -> Either String v
pVal String
sVal of
Left err :: String
err -> String -> Either String (k, v)
forall a b. a -> Either a b
Left String
err
Right val :: 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 _ [] = []
split sep :: Char
sep s0 :: String
s0 = String -> [String]
loop String
s0 where
loop :: String -> [String]
loop s :: String
s = let
(chunk :: String
chunk, rest :: 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. [a] -> [a]
tail String
rest)
in if String -> 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 :: Char -> OptionType a -> OptionType [a]
optionType_list sep :: Char
sep t :: 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 = "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]
++ ">"
parser :: String -> Either String [a]
parser s :: 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 xs :: [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 :: String -> OptionType a
optionType_enum tName :: 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
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " ((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]
++ "}"
parseEnum :: String -> Either String a
parseEnum s :: 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
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]
++ " is not in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
setString String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".")
Just x :: 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 :: String -> a -> String -> DefineOptions a
simpleOption flag :: String
flag def :: a
def desc :: 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 (\o :: 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 :: OptionType a -> (Option a -> Option a) -> DefineOptions a
defineOption t :: OptionType a
t fn :: 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 :: forall a.
String
-> [String]
-> a
-> String
-> Maybe Group
-> Maybe Location
-> Option a
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 = ""
, 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 key :: Integer
key = (Integer
keyInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1, [OptionInfo :: OptionKey
-> String
-> [String]
-> String
-> Bool
-> Bool
-> String
-> Maybe Group
-> Maybe Location
-> String
-> OptionInfo
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 tok :: Token
tok = case Token
tok of
TokenUnary flagName :: String
flagName -> case OptionType a -> Maybe a
forall val. OptionType val -> Maybe val
optionTypeUnary OptionType a
t of
Nothing -> String -> Either String a
forall a b. a -> Either a b
Left ("The flag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flagName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " requires an argument.")
Just val :: a
val -> a -> Either String a
forall a b. b -> Either a b
Right a
val
Token flagName :: String
flagName rawValue :: 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 err :: String
err -> String -> Either String a
forall a b. a -> Either a b
Left ("Value for flag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flagName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is invalid: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
Right val :: 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 key :: Integer
key tokens :: 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
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
+1, Option a -> a
forall a. Option a -> a
optionDefault Option a
opt)
Just toks :: [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
+1, Option a -> a
forall a. Option a -> a
optionDefault Option a
opt)
[tok :: Token
tok] -> case Token -> Either String a
parseToken Token
tok of
Left err :: String
err -> String -> Either String (Integer, a)
forall a b. a -> Either a b
Left String
err
Right val :: 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
+1, a
val)
_ -> case OptionType a -> Maybe ([a] -> a)
forall val. OptionType val -> Maybe ([val] -> val)
optionTypeMerge OptionType a
t of
Nothing -> String -> Either String (Integer, a)
forall a b. a -> Either a b
Left ("Multiple values for flag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Token] -> String
showMultipleFlagValues [Token]
toks)
Just appendFn :: [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 err :: String
err -> String -> Either String (Integer, a)
forall a b. a -> Either a b
Left String
err
Right vals :: [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
+1, [a] -> a
appendFn [a]
vals)
showMultipleFlagValues :: [Token] -> String
showMultipleFlagValues :: [Token] -> String
showMultipleFlagValues = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " " ([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 flagName :: String
flagName) = String
flagName
showToken (Token flagName :: String
flagName rawValue :: String
rawValue) = String -> String
forall a. Show a => a -> String
show (String
flagName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rawValue)
data Option a = Option
{
Option a -> String
optionShortFlags :: [Char]
, Option a -> [String]
optionLongFlags :: [String]
, Option a -> a
optionDefault :: a
, Option a -> String
optionDescription :: String
, Option a -> Maybe Group
optionGroup :: Maybe Group
, Option a -> Maybe Location
optionLocation :: Maybe Location
}
validateOptionDefs :: [OptionInfo] -> [(String, [OptionInfo])] -> Either String OptionDefinitions
validateOptionDefs :: [OptionInfo]
-> [(String, [OptionInfo])] -> Either String OptionDefinitions
validateOptionDefs cmdInfos :: [OptionInfo]
cmdInfos subInfos :: [(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 (t :: * -> *) a. Foldable t => t a -> Int
length [String]
subcmdNames
then ErrorType (ErrorT String Identity) -> ErrorT String Identity ()
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError ErrorType (ErrorT String Identity)
"Multiple subcommands exist with the same name."
else () -> ErrorT String Identity ()
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 | (_, infos :: [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 err :: String
err -> ErrorType (ErrorT String Identity) -> ErrorT String Identity ()
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError String
ErrorType (ErrorT String Identity)
err
Right _ -> () -> ErrorT String Identity ()
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 (\subInfo :: (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 (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 info :: OptionInfo
info = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (OptionInfo -> String
optionInfoShortFlags OptionInfo
info) Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (OptionInfo -> [String]
optionInfoLongFlags OptionInfo
info)
then case OptionInfo -> Maybe Location
optionInfoLocation OptionInfo
info of
Nothing -> String -> Either String ()
forall a b. a -> Either a b
Left ("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]
++ " has no flags.")
Just loc :: Location
loc -> String -> Either String ()
forall a b. a -> Either a b
Left ("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]
++ " 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
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]
++ " 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
/= :: DeDupFlag -> DeDupFlag -> Bool
$c/= :: DeDupFlag -> DeDupFlag -> Bool
== :: DeDupFlag -> DeDupFlag -> Bool
$c== :: 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
min :: DeDupFlag -> DeDupFlag -> DeDupFlag
$cmin :: DeDupFlag -> DeDupFlag -> DeDupFlag
max :: DeDupFlag -> DeDupFlag -> DeDupFlag
$cmax :: DeDupFlag -> DeDupFlag -> DeDupFlag
>= :: DeDupFlag -> DeDupFlag -> Bool
$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
compare :: DeDupFlag -> DeDupFlag -> Ordering
$ccompare :: DeDupFlag -> DeDupFlag -> Ordering
$cp1Ord :: Eq 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
showList :: [DeDupFlag] -> String -> String
$cshowList :: [DeDupFlag] -> String -> String
show :: DeDupFlag -> String
$cshow :: DeDupFlag -> String
showsPrec :: Int -> DeDupFlag -> String -> String
$cshowsPrec :: Int -> 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 checked :: Map DeDupFlag OptionInfo
checked [] = Map DeDupFlag OptionInfo
-> ErrorT String Identity (Map DeDupFlag OptionInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Map DeDupFlag OptionInfo
checked
checkNoDuplicateFlags checked :: Map DeDupFlag OptionInfo
checked (info :: OptionInfo
info:infos :: [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
$ \mapKey :: 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
Nothing -> () -> ErrorT String Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just prevInfo :: OptionInfo
prevInfo -> if OptionInfo -> OptionInfo -> Bool
eqIgnoringKey OptionInfo
info OptionInfo
prevInfo
then () -> ErrorT String Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else let
flagName :: String
flagName = case DeDupFlag
mapKey of
DeDupShort flag :: Char
flag -> '-' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
flag Char -> String -> String
forall a. a -> [a] -> [a]
: []
DeDupLong long :: String
long -> "--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
long
in ErrorType (ErrorT String Identity) -> ErrorT String Identity ()
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError ("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]
++ ".")
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 x :: OptionInfo
x y :: 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 info :: 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 _ x :: Maybe String
x _ _) = Maybe String
x
parsedHelp_ :: ParsedOptions a -> String
parsedHelp_ (ParsedOptions _ _ x :: String
x _) = String
x
instance Parsed (ParsedSubcommand a) where
parsedError_ :: ParsedSubcommand a -> Maybe String
parsedError_ (ParsedSubcommand _ x :: Maybe String
x _) = Maybe String
x
parsedHelp_ :: ParsedSubcommand a -> String
parsedHelp_ (ParsedSubcommand _ _ x :: String
x) = String
x
parsedOptions :: ParsedOptions opts -> Maybe opts
parsedOptions :: ParsedOptions opts -> Maybe opts
parsedOptions (ParsedOptions x :: Maybe opts
x _ _ _) = Maybe opts
x
parsedArguments :: ParsedOptions opts -> [String]
parsedArguments :: ParsedOptions opts -> [String]
parsedArguments (ParsedOptions _ _ _ x :: [String]
x) = [String]
x
parsedSubcommand :: ParsedSubcommand action -> Maybe action
parsedSubcommand :: ParsedSubcommand action -> Maybe action
parsedSubcommand (ParsedSubcommand x :: Maybe action
x _ _) = Maybe action
x
parsedError :: Parsed a => a -> Maybe String
parsedError :: a -> Maybe String
parsedError = a -> Maybe String
forall a. Parsed a => a -> Maybe String
parsedError_
parsedHelp :: Parsed a => a -> String
parsedHelp :: a -> String
parsedHelp = a -> String
forall a. Parsed a => a -> String
parsedHelp_
parseOptions :: Options opts => [String] -> ParsedOptions opts
parseOptions :: [String] -> ParsedOptions opts
parseOptions argv :: [String]
argv = ParsedOptions opts
parsed where
(DefineOptions _ getInfos :: Integer -> (Integer, [OptionInfo])
getInfos parser :: Integer -> Map OptionKey [Token] -> Either String (Integer, opts)
parser) = DefineOptions opts
forall opts. Options opts => DefineOptions opts
defineOptions
(_, optionInfos :: [OptionInfo]
optionInfos) = Integer -> (Integer, [OptionInfo])
getInfos 0
parseTokens :: Map OptionKey [Token] -> Either String (Integer, opts)
parseTokens = Integer -> Map OptionKey [Token] -> Either String (Integer, opts)
parser 0
parsed :: ParsedOptions opts
parsed = case [OptionInfo]
-> [(String, [OptionInfo])] -> Either String OptionDefinitions
validateOptionDefs [OptionInfo]
optionInfos [] of
Left err :: 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) "" []
Right optionDefs :: OptionDefinitions
optionDefs -> case OptionDefinitions
-> [String] -> (Maybe String, Either String Tokens)
tokenize (OptionDefinitions -> OptionDefinitions
addHelpFlags OptionDefinitions
optionDefs) [String]
argv of
(_, Left err :: 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 tokens :: Tokens
tokens) -> case Tokens -> Maybe HelpFlag
checkHelpFlag Tokens
tokens of
Just helpFlag :: 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) []
Nothing -> case Map OptionKey [Token] -> Either String (Integer, opts)
parseTokens (Tokens -> Map OptionKey [Token]
tokensMap Tokens
tokens) of
Left err :: 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 (_, opts :: 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 :: (opts -> [String] -> m a) -> m a
runCommand io :: opts -> [String] -> m a
io = do
[String]
argv <- IO [String] -> m [String]
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 -> opts -> [String] -> m a
io opts
opts (ParsedOptions opts -> [String]
forall opts. ParsedOptions opts -> [String]
parsedArguments ParsedOptions opts
parsed)
Nothing -> 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 err :: 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
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 :: String
-> (cmdOpts -> subcmdOpts -> [String] -> action)
-> Subcommand cmdOpts action
subcommand name :: String
name fn :: 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 (\initialKey :: Integer
initialKey -> let
(DefineOptions _ getInfos :: Integer -> (Integer, [OptionInfo])
getInfos parser :: Integer
-> Map OptionKey [Token] -> Either String (Integer, subcmdOpts)
parser) = DefineOptions subcmdOpts
forall opts. Options opts => DefineOptions opts
defineOptions
(nextKey :: Integer
nextKey, optionInfos :: [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
cmdOpts tokens :: Tokens
tokens = case Map OptionKey [Token] -> Either String (Integer, subcmdOpts)
parseTokens (Tokens -> Map OptionKey [Token]
tokensMap Tokens
tokens) of
Left err :: String
err -> String -> Either String action
forall a b. a -> Either a b
Left String
err
Right (_, subOpts :: 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 :: [Subcommand cmdOpts action] -> [String] -> ParsedSubcommand action
parseSubcommand subcommands :: [Subcommand cmdOpts action]
subcommands argv :: [String]
argv = ParsedSubcommand action
parsed where
(DefineOptions _ getInfos :: Integer -> (Integer, [OptionInfo])
getInfos parser :: Integer
-> Map OptionKey [Token] -> Either String (Integer, cmdOpts)
parser) = DefineOptions cmdOpts
forall opts. Options opts => DefineOptions opts
defineOptions
(cmdNextKey :: Integer
cmdNextKey, cmdInfos :: [OptionInfo]
cmdInfos) = Integer -> (Integer, [OptionInfo])
getInfos 0
cmdParseTokens :: Map OptionKey [Token] -> Either String (Integer, cmdOpts)
cmdParseTokens = Integer
-> Map OptionKey [Token] -> Either String (Integer, cmdOpts)
parser 0
subcmdInfos :: [(String, [OptionInfo])]
subcmdInfos = do
Subcommand name :: String
name fn :: Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer)
fn <- [Subcommand cmdOpts action]
subcommands
let (infos :: [OptionInfo]
infos, _, _) = Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer)
fn Integer
cmdNextKey
(String, [OptionInfo]) -> [(String, [OptionInfo])]
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 name :: String
name fn :: Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer)
fn <- [Subcommand cmdOpts action]
subcommands
let (_, runner :: cmdOpts -> Tokens -> Either String action
runner, _) = Integer
-> ([OptionInfo], cmdOpts -> Tokens -> Either String action,
Integer)
fn Integer
cmdNextKey
(String, cmdOpts -> Tokens -> Either String action)
-> [(String, cmdOpts -> Tokens -> Either String action)]
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 err :: 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) ""
Right optionDefs :: OptionDefinitions
optionDefs -> case OptionDefinitions
-> [String] -> (Maybe String, Either String Tokens)
tokenize (OptionDefinitions -> OptionDefinitions
addHelpFlags OptionDefinitions
optionDefs) [String]
argv of
(subcmd :: Maybe String
subcmd, Left err :: 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)
(subcmd :: Maybe String
subcmd, Right tokens :: Tokens
tokens) -> case Tokens -> Maybe HelpFlag
checkHelpFlag Tokens
tokens of
Just helpFlag :: 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)
Nothing -> case Tokens -> Maybe String -> Either String action
findAction Tokens
tokens Maybe String
subcmd of
Left err :: 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
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 _ Nothing = String -> Either String action
forall a b. a -> Either a b
Left "No subcommand specified"
findAction tokens :: Tokens
tokens (Just subcmdName :: String
subcmdName) = case Map OptionKey [Token] -> Either String (Integer, cmdOpts)
cmdParseTokens (Tokens -> Map OptionKey [Token]
tokensMap Tokens
tokens) of
Left err :: String
err -> String -> Either String action
forall a b. a -> Either a b
Left String
err
Right (_, cmdOpts :: 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
Nothing -> String -> Either String action
forall a b. a -> Either a b
Left ("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]
++ ".")
Just getRunner :: cmdOpts -> Tokens -> Either String action
getRunner -> case cmdOpts -> Tokens -> Either String action
getRunner cmdOpts
cmdOpts Tokens
tokens of
Left err :: String
err -> String -> Either String action
forall a b. a -> Either a b
Left String
err
Right action :: 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 :: [Subcommand opts (m a)] -> m a
runSubcommand subcommands :: [Subcommand opts (m a)]
subcommands = do
[String]
argv <- IO [String] -> m [String]
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 cmd :: m a
cmd -> m a
cmd
Nothing -> 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 err :: 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
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