-- |
-- Module: Options
-- License: MIT
module Options
  ( -- * Defining options
    Options (..),
    defaultOptions,
    simpleOption,
    DefineOptions,
    SimpleOptionType (..),

    -- * Defining subcommands
    Subcommand,
    subcommand,

    -- * Running main with options
    runCommand,
    runSubcommand,

    -- * Parsing argument lists
    Parsed,
    parsedError,
    parsedHelp,

    -- ** Parsing options
    ParsedOptions,
    parsedOptions,
    parsedArguments,
    parseOptions,

    -- ** Parsing sub-commands
    ParsedSubcommand,
    parsedSubcommand,
    parseSubcommand,

    -- * Advanced option definitions
    OptionType,
    defineOption,
    Option,
    optionShortFlags,
    optionLongFlags,
    optionDefault,
    optionDescription,
    optionGroup,

    -- ** Option groups
    Group,
    group,
    groupName,
    groupTitle,
    groupDescription,

    -- * Option types
    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,

    -- ** Custom option types
    optionType,
    optionTypeName,
    optionTypeDefault,
    optionTypeParse,
    optionTypeShow,
    optionTypeUnary,
    optionTypeMerge,
  )
where

import Control.Monad (forM_)
import Control.Monad.Except (ExceptT, runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Functor.Identity
import Data.Int
import Data.List (intercalate)
import Data.Map qualified as Map
import Data.Maybe (isJust)
import Data.Set qualified as Set
import Data.Word
import Options.Help
import Options.Tokenize
import Options.Types
import Options.Util (mapEither)
import System.Environment qualified
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStr, hPutStrLn, stderr, stdout)

-- | Options are defined together in a single data type, which will be an
--   instance of 'Options'
--
-- See 'defineOptions' for details on defining instances of 'Options'.
class Options opts where
  -- | Defines the structure and metadata of the options in this type,
  -- including their types, flag names, and documentation.
  --
  -- Options with a basic type and a single flag name may be defined
  -- with 'simpleOption'. Options with more complex requirements may
  -- be defined with 'defineOption'.
  --
  -- Non-option fields in the type may be set using applicative functions
  -- such as 'pure'.
  --
  -- Options may be included from another type by using a nested call to
  -- 'defineOptions'.
  --
  -- Library authors are encouraged to aggregate their options into a
  -- few top-level types, so application authors can include it
  -- easily in their own option definitions.
  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)
      )

-- | An options value containing only the default values for each option
--
-- This is equivalent to the options value when parsing an empty argument list.
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

-- | An option's type determines how the option will be parsed, and which
--   Haskell type the parsed value will be stored as
--
-- There are many types available, covering most basic types and a few more advanced types.
data OptionType val = OptionType
  { -- | The name of this option type; used in @--help@ output.
    forall val. OptionType val -> String
optionTypeName :: String,
    -- | The default value for options of this type. This will be used
    -- if 'optionDefault' is not set when defining the option.
    forall val. OptionType val -> val
optionTypeDefault :: val,
    -- | Try to parse the given string to an option value. If parsing
    -- fails, an error message will be returned.
    forall val. OptionType val -> String -> Either String val
optionTypeParse :: String -> Either String val,
    -- | Format the value for display; used in @--help@ output.
    forall val. OptionType val -> val -> String
optionTypeShow :: val -> String,
    -- | If not Nothing, then options of this type may be set by a unary
    -- flag. The option will be parsed as if the given value were set.
    forall val. OptionType val -> Maybe val
optionTypeUnary :: Maybe val,
    -- | If not Nothing, then options of this type may be set with repeated
    -- flags. Each flag will be parsed with 'optionTypeParse', and the
    -- resulting parsed values will be passed to this function for merger
    -- into the final value.
    forall val. OptionType val -> Maybe ([val] -> val)
optionTypeMerge :: Maybe ([val] -> val)
  }

-- | Define an option group with the given name and title
--
-- Use 'groupDescription' to add additional descriptive text, if needed.
group ::
  -- | Name
  String ->
  -- | Title; see 'groupTitle'.
  String ->
  -- | Description; see 'groupDescription'.
  String ->
  Group
group :: String -> String -> String -> Group
group = String -> String -> String -> Group
Group

-- | Define a new option type with the given name, default, and behavior
optionType ::
  -- | Name
  String ->
  -- | Default value
  val ->
  -- | Parser
  (String -> Either String val) ->
  -- | Formatter
  (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

-- | Store an option as a @'Bool'@
--
-- The option's value must be either @\"true\"@ or @\"false\"@.
-- Boolean options are unary, which means that their value is
-- optional when specified on the command line.
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 = Just 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

-- | Store an option value as a @'String'@
--
-- The value is decoded to Unicode first, if needed.
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

-- | Store an option as an @'Integer'@
--
-- The option value must be an integer.
-- There is no minimum or maximum value.
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

-- | Store an option as an @'Int'@
--
-- The option value must be an integer /n/ such that @'minBound' <= n <= 'maxBound'@.
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

-- | Store an option as an @'Int8'@
--
-- The option value must be an integer /n/ such that @'minBound' <= n <= 'maxBound'@.
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

-- | Store an option as an @'Int16'@
--
-- The option value must be an integer /n/ such that @'minBound' <= n <= 'maxBound'@.
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

-- | Store an option as an @'Int32'@
--
-- The option value must be an integer /n/ such that @'minBound' <= n <= 'maxBound'@.
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

-- | Store an option as an @'Int64'@
--
-- The option value must be an integer /n/ such that @'minBound' <= n <= 'maxBound'@.
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

-- | Store an option as a @'Word'@
--
-- The option value must be a positive integer /n/ such that @0 <= n <= 'maxBound'@.
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

-- | Store an option as a @'Word8'@
--
-- The option value must be a positive integer /n/ such that @0 <= n <= 'maxBound'@.
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

-- | Store an option as a @'Word16'@
--
-- The option value must be a positive integer /n/ such that @0 <= n <= 'maxBound'@.
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

-- | Store an option as a @'Word32'@
--
-- The option value must be a positive integer /n/ such that @0 <= n <= 'maxBound'@.
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

-- | Store an option as a @'Word64'@
--
-- The option value must be a positive integer /n/ such that @0 <= n <= 'maxBound'@.
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

-- | Store an option as a @'Float'@
--
-- The option value must be a number.
-- Due to the imprecision of floating-point math, the stored value might not
-- exactly match the user's input.
-- If the user's input is out of range for the @'Float'@ type, it will be
-- stored as @Infinity@ or @-Infinity@.
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

-- | Store an option as a @'Double'@
--
-- The option value must be a number.
-- Due to the imprecision of floating-point math, the stored value might
-- not exactly match the user's input.
-- If the user's input is out of range for the @'Double'@ type, it will
-- be stored as @Infinity@ or @-Infinity@.
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

-- | Store an option as a @'Maybe'@ of another type
--
-- The value will be @Nothing@ if the option is set to an empty string.
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 = 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

-- | Store an option as a @'Set.Set'@, using another option type for the elements
--
-- The separator should be a character that will not occur within the values,
-- such as a comma or semicolon.
--
-- Duplicate elements in the input are permitted.
optionType_set ::
  Ord a =>
  -- | Element separator
  Char ->
  -- | Element type
  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))

-- | Store an option as a 'Map.Map', using other option types for the keys and values
--
-- The item separator is used to separate key/value pairs from each other.
-- It should be a character that will not occur within either the keys or values.
--
-- The value separator is used to separate the key from the value.
-- It should be a character that will not occur within the keys.
-- It may occur within the values.
--
-- Duplicate keys in the input are permitted.
-- The final value for each key is stored.
optionType_map ::
  Ord k =>
  -- | Item separator
  Char ->
  -- | Key/Value separator
  Char ->
  -- | Key type
  OptionType k ->
  -- | Value type
  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
v a -> [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

-- | Store an option as a list, using another option type for the elements
--
-- The separator should be a character that will not occur within the values,
-- such as a comma or semicolon.
optionType_list ::
  -- | Element separator
  Char ->
  -- | Element type
  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)

-- | Store an option as one of a set of possible values
--
-- This is a simplistic implementation, useful for quick scripts.
-- For more possibilities, see 'optionType'.
optionType_enum ::
  (Bounded a, Enum a, Show a) =>
  -- | Option type name
  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

-- | Defines a new option in the current options type
simpleOption ::
  SimpleOptionType a =>
  String -> -- long flag
  a -> -- default value
  String -> -- description
  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 = [flag],
            optionDefault = def,
            optionDescription = desc
          }
    )

-- | Defines a new option in the current options type
--
-- All options must have one or more /flags/.
-- Options may also have a default value, a description, and a group.
--
-- The /flags/ are how the user specifies an option on the command line.
-- Flags may be /short/ or /long/.
-- See 'optionShortFlags' and 'optionLongFlags' for details.
--
-- @
-- 'defineOption' 'optionType_word16' (\\o -> o
--    { 'optionLongFlags' = [\"port\"]
--    , 'optionDefault' = 80
--    })
-- @
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
key Integer -> 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 val
    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
key Integer -> 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
        -- shouldn't happen, but lets do something graceful anyway.
        [] -> (Integer, a) -> Either String (Integer, a)
forall a b. b -> Either a b
Right (Integer
key Integer -> 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
key Integer -> 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
key Integer -> 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
  { -- | Short flags are a single character. When entered by a user,
    -- they are preceded by a dash and possibly other short flags.
    --
    -- Short flags must be a letter or a number.
    --
    -- Example: An option with @optionShortFlags = [\'p\']@ may be set using:
    --
    -- >$ ./app -p 443
    -- >$ ./app -p443
    forall a. Option a -> String
optionShortFlags :: [Char],
    -- | Long flags are multiple characters. When entered by a user, they
    -- are preceded by two dashes.
    --
    -- Long flags may contain letters, numbers, @\'-\'@, and @\'_\'@.
    --
    -- Example: An option with @optionLongFlags = [\"port\"]@ may be set using:
    --
    -- >$ ./app --port 443
    -- >$ ./app --port=443
    forall a. Option a -> [String]
optionLongFlags :: [String],
    -- | Options may have a default value. This will be parsed as if the
    -- user had entered it on the command line.
    forall a. Option a -> a
optionDefault :: a,
    -- | An option's description is used with the default implementation
    -- of @--help@. It should be a short string describing what the option
    -- does.
    forall a. Option a -> String
optionDescription :: String,
    -- | Which group the option is in. See the \"Option groups\" section
    -- for details.
    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
$ ExceptT String Identity OptionDefinitions
-> Identity (Either String OptionDefinitions)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
  -- All subcommands have unique names.
  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 -- TODO: the error should mention which subcommand names are duplicated
      ErrorType (ExceptT String Identity) -> ExceptT String Identity ()
forall a.
ErrorType (ExceptT String Identity) -> ExceptT String Identity a
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError String
ErrorType (ExceptT String Identity)
"Multiple subcommands exist with the same name."
    else () -> ExceptT String Identity ()
forall a. a -> ExceptT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Each option defines at least one short or long flag.
  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 (ExceptT String Identity) -> ExceptT String Identity ()
forall a.
ErrorType (ExceptT String Identity) -> ExceptT String Identity a
forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError String
ErrorType (ExceptT String Identity)
err
    Right [()]
_ -> () -> ExceptT String Identity ()
forall a. a -> ExceptT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- There are no duplicate short or long flags, unless:
  -- The flags are defined in separate subcommands.
  -- The flags have identical OptionInfos (aside from keys)
  Map DeDupFlag OptionInfo
cmdDeDupedFlags <- Map DeDupFlag OptionInfo
-> [OptionInfo]
-> ExceptT String Identity (Map DeDupFlag OptionInfo)
checkNoDuplicateFlags Map DeDupFlag OptionInfo
forall k a. Map k a
Map.empty [OptionInfo]
cmdInfos
  [(String, [OptionInfo])]
-> ((String, [OptionInfo])
    -> ExceptT String Identity (Map DeDupFlag OptionInfo))
-> ExceptT 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]
-> ExceptT String Identity (Map DeDupFlag OptionInfo)
checkNoDuplicateFlags Map DeDupFlag OptionInfo
cmdDeDupedFlags ((String, [OptionInfo]) -> [OptionInfo]
forall a b. (a, b) -> b
snd (String, [OptionInfo])
subInfo))

  OptionDefinitions -> ExceptT String Identity OptionDefinitions
forall a. a -> ExceptT 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 -- TODO: All short or long flags have a reasonable name.
      () -> 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] -> ExceptT String Identity (Map.Map DeDupFlag OptionInfo)
checkNoDuplicateFlags :: Map DeDupFlag OptionInfo
-> [OptionInfo]
-> ExceptT String Identity (Map DeDupFlag OptionInfo)
checkNoDuplicateFlags Map DeDupFlag OptionInfo
checked [] = Map DeDupFlag OptionInfo
-> ExceptT String Identity (Map DeDupFlag OptionInfo)
forall a. a -> ExceptT 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 -> ExceptT String Identity ())
-> ExceptT String Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DeDupFlag]
mappedFlags \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 -> () -> ExceptT String Identity ()
forall a. a -> ExceptT 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 () -> ExceptT String Identity ()
forall a. a -> ExceptT 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 (ExceptT String Identity) -> ExceptT String Identity ()
forall a.
ErrorType (ExceptT String Identity) -> ExceptT 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]
-> ExceptT 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 = OptionKeyIgnored}

-- | See 'parseOptions' and 'parseSubcommand'
class Parsed a where
  parsedError_ :: a -> Maybe String
  parsedHelp_ :: a -> String

-- | See 'parseOptions'
data ParsedOptions opts = ParsedOptions (Maybe opts) (Maybe String) String [String]

-- | See 'parseSubcommand'
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

-- | Get the options value that was parsed from argv, or @Nothing@ if the
--   arguments could not be converted into options
--
-- Note: This function return @Nothing@ if the user provided a help flag.
-- To check whether an error occurred during parsing, check the value of 'parsedError'.
parsedOptions :: ParsedOptions opts -> Maybe opts
parsedOptions :: forall opts. ParsedOptions opts -> Maybe opts
parsedOptions (ParsedOptions Maybe opts
x Maybe String
_ String
_ [String]
_) = Maybe opts
x

-- | Get command-line arguments remaining after parsing options
--
-- The arguments are unchanged from the original argument list, and
-- have not been decoded or otherwise transformed.
parsedArguments :: ParsedOptions opts -> [String]
parsedArguments :: forall opts. ParsedOptions opts -> [String]
parsedArguments (ParsedOptions Maybe opts
_ Maybe String
_ String
_ [String]
x) = [String]
x

-- | Get the subcommand action that was parsed from argv, or @Nothing@ if the
--   arguments could not be converted into a valid action
--
-- Note: This function return @Nothing@ if the user provided a help flag.
-- To check whether an error occurred during parsing, check the value of 'parsedError'.
parsedSubcommand :: ParsedSubcommand action -> Maybe action
parsedSubcommand :: forall action. ParsedSubcommand action -> Maybe action
parsedSubcommand (ParsedSubcommand Maybe action
x Maybe String
_ String
_) = Maybe action
x

-- | Get the error that prevented options from being parsed from argv,
--   or @Nothing@ if no error was detected
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_

-- | Get a help message to show the user
--
-- If the arguments included a help flag, this will be a message
-- appropriate to that flag. Otherwise, it is a summary (equivalent to @--help@).
--
-- This is always a non-empty string, regardless of whether the parse
-- succeeded or failed. If you need to perform additional validation
-- on the options value, this message can be displayed if validation fails.
parsedHelp :: Parsed a => a -> String
parsedHelp :: forall a. Parsed a => a -> String
parsedHelp = a -> String
forall a. Parsed a => a -> String
parsedHelp_

-- | Attempt to convert a list of command-line arguments into an options value
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)

-- | Either calls the given continuation, prints help text and calls 'exitSuccess',
--   or prints an error and calls 'exitFailure'.
--
-- See 'runSubcommand' for details on subcommand support.
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 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) =>
  -- | The subcommand name
  String ->
  -- | The action to run
  (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)
    )

-- | Attempt to convert a list of command-line arguments into a subcommand action
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 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

-- | Used to run applications that are split into subcommands
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