-- |
-- 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) =
    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 -> forall a b. a -> Either a b
Left String
err
          Right (Integer
key', a
a) -> 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 = 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]
_ -> 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) =
    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 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 -> 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 -> forall a b. a -> Either a b
Left String
err
            Right (Integer
key'', a
a) -> 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 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' = 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' forall a. Maybe a
Nothing 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 =
  (forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"bool" Bool
False String -> Either String Bool
parseBool (\Bool
x -> if Bool
x then String
"true" else String
"false"))
    { optionTypeUnary :: Maybe Bool
optionTypeUnary = forall a. a -> Maybe a
Just Bool
True
    }

parseBool :: String -> Either String Bool
parseBool :: String -> Either String Bool
parseBool String
s = case String
s of
  String
"true" -> forall a b. b -> Either a b
Right Bool
True
  String
"false" -> forall a b. b -> Either a b
Right Bool
False
  String
_ -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show String
s 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 = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"text" String
"" forall a b. b -> Either a b
Right 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 = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"integer" Integer
0 String -> Either String Integer
parseInteger 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 forall a b. b -> Either a b
Right (forall a. Read a => String -> a
read String
s)
        else forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show String
s 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c 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' = (forall a. Integral a => a -> Integer
toInteger a
min', forall a. Integral a => a -> Integer
toInteger a
max')

    (Integer
minInt, Integer
maxInt) = forall a.
(Bounded a, Integral a) =>
(String -> Either String a) -> a -> a -> (Integer, Integer)
getBounds String -> Either String a
parse forall a. Bounded a => a
minBound 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 -> forall a b. a -> Either a b
Left String
err
      Right Integer
int ->
        if Integer
int forall a. Ord a => a -> a -> Bool
< Integer
minInt Bool -> Bool -> Bool
|| Integer
int forall a. Ord a => a -> a -> Bool
> Integer
maxInt
          then forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show Integer
int forall a. [a] -> [a] -> [a]
++ String
" is not within bounds [" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
minInt forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
maxInt forall a. [a] -> [a] -> [a]
++ String
"] of type " forall a. [a] -> [a] -> [a]
++ String
label forall a. [a] -> [a] -> [a]
++ String
".")
          else forall a b. b -> Either a b
Right (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 = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
tName a
0 (forall a.
(Bounded a, Integral a) =>
String -> String -> Either String a
parseBoundedIntegral String
tName) 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"float32" Float
0 forall a. Read a => String -> Either String a
parseFloat 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 = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
"float64" Double
0 forall a. Read a => String -> Either String a
parseFloat 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 forall a. Read a => ReadS a
reads String
s of
  [(a
x, String
"")] -> forall a b. b -> Either a b
Right a
x
  [(a, String)]
_ -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
" is not a number.")

instance SimpleOptionType a => SimpleOptionType (Maybe a) where
  simpleOptionType :: OptionType (Maybe a)
simpleOptionType = forall a. OptionType a -> OptionType (Maybe a)
optionType_maybe 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 :: Maybe (Maybe a)
optionTypeUnary = Maybe (Maybe a)
unary}
  where
    maybeT :: OptionType (Maybe a)
maybeT = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
name forall a. Maybe a
Nothing (forall val. OptionType val -> String -> Either String (Maybe val)
parseMaybe OptionType a
t) (forall val. OptionType val -> Maybe val -> String
showMaybe OptionType a
t)
    name :: String
name = String
"maybe<" forall a. [a] -> [a] -> [a]
++ forall val. OptionType val -> String
optionTypeName OptionType a
t forall a. [a] -> [a] -> [a]
++ String
">"
    unary :: Maybe (Maybe a)
unary = case forall val. OptionType val -> Maybe val
optionTypeUnary OptionType a
t of
      Maybe a
Nothing -> forall a. Maybe a
Nothing
      Just a
val -> forall a. a -> Maybe a
Just (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
"" -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
  String
_ -> case forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType val
t String
s of
    Left String
err -> forall a b. a -> Either a b
Left String
err
    Right val
a -> forall a b. b -> Either a b
Right (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) = 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 = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
name forall a. Set a
Set.empty String -> Either String (Set a)
parseSet Set a -> String
showSet
  where
    name :: String
name = String
"set<" forall a. [a] -> [a] -> [a]
++ forall val. OptionType val -> String
optionTypeName OptionType a
t forall a. [a] -> [a] -> [a]
++ String
">"
    parseSet :: String -> Either String (Set a)
parseSet String
s = case forall a.
(String -> Either String a) -> [String] -> Either String [a]
parseList (forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType a
t) (Char -> String -> [String]
split Char
sep String
s) of
      Left String
err -> forall a b. a -> Either a b
Left String
err
      Right [a]
xs -> forall a b. b -> Either a b
Right (forall a. Ord a => [a] -> Set a
Set.fromList [a]
xs)
    showSet :: Set a -> String
showSet Set a
xs = forall a. [a] -> [[a]] -> [a]
intercalate [Char
sep] (forall a b. (a -> b) -> [a] -> [b]
map (forall val. OptionType val -> val -> String
optionTypeShow OptionType a
t) (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 = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
name 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<" forall a. [a] -> [a] -> [a]
++ forall val. OptionType val -> String
optionTypeName OptionType k
kt forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ forall val. OptionType val -> String
optionTypeName OptionType v
vt forall a. [a] -> [a] -> [a]
++ String
">"
    parser :: String -> Either String (Map k v)
parser String
s = forall k v.
Ord k =>
Char
-> (String -> Either String k)
-> (String -> Either String v)
-> [String]
-> Either String (Map k v)
parseMap Char
keySep (forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType k
kt) (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 = forall a. [a] -> [[a]] -> [a]
intercalate [Char
itemSep] (forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> String
showItem (forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m))
    showItem :: (k, v) -> String
showItem (k
k, v
v) = forall val. OptionType val -> val -> String
optionTypeShow OptionType k
kt k
k forall a. [a] -> [a] -> [a]
++ [Char
keySep] forall a. [a] -> [a] -> [a]
++ 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 [] = 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 -> 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 -> forall a b. a -> Either a b
Left String
err
        Right [a]
vs -> forall a b. b -> Either a b
Right (a
v 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 forall a.
(String -> Either String a) -> [String] -> Either String [a]
parseList String -> Either String (k, v)
pItem [String]
strs of
      Left String
err -> forall a b. a -> Either a b
Left String
err
      Right [(k, v)]
xs -> forall a b. b -> Either a b
Right (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 forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
keySep) String
s of
      (String
sKey, String
valAndSep) -> case String
valAndSep of
        [] -> forall a b. a -> Either a b
Left (String
"Map item " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
" has no value.")
        Char
_ : String
sVal -> case String -> Either String k
pKey String
sKey of
          Left String
err -> 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 -> forall a b. a -> Either a b
Left String
err
            Right v
val -> 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
sep) String
s
          cont :: [String]
cont = String
chunk forall a. a -> [a] -> [a]
: String -> [String]
loop (forall a. [a] -> [a]
tail String
rest)
       in if 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 = 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<" forall a. [a] -> [a] -> [a]
++ forall val. OptionType val -> String
optionTypeName OptionType a
t forall a. [a] -> [a] -> [a]
++ String
">"
    parser :: String -> Either String [a]
parser String
s = forall a.
(String -> Either String a) -> [String] -> Either String [a]
parseList (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 = forall a. [a] -> [[a]] -> [a]
intercalate [Char
sep] (forall a b. (a -> b) -> [a] -> [b]
map (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 = forall val.
String
-> val
-> (String -> Either String val)
-> (val -> String)
-> OptionType val
optionType String
tName forall a. Bounded a => a
minBound String -> Either String a
parseEnum forall a. Show a => a -> String
show
  where
    values :: Map String a
values = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall a. Show a => a -> String
show a
x, a
x) | a
x <- forall a. Enum a => a -> [a]
enumFrom forall a. Bounded a => a
minBound]
    setString :: String
setString = String
"{" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show (forall k a. Map k a -> [k]
Map.keys Map String a
values)) forall a. [a] -> [a] -> [a]
++ String
"}"
    parseEnum :: String -> Either String a
parseEnum String
s = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
s Map String a
values of
      Maybe a
Nothing -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
" is not in " forall a. [a] -> [a] -> [a]
++ String
setString forall a. [a] -> [a] -> [a]
++ String
".")
      Just a
x -> 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 =
  forall a. OptionType a -> (Option a -> Option a) -> DefineOptions a
defineOption
    forall a. SimpleOptionType a => OptionType a
simpleOptionType
    ( \Option a
o ->
        Option a
o
          { optionLongFlags :: [String]
optionLongFlags = [String
flag],
            optionDefault :: a
optionDefault = a
def,
            optionDescription :: String
optionDescription = String
desc
          }
    )

-- | 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 = forall a.
a
-> (Integer -> (Integer, [OptionInfo]))
-> (Integer -> Map OptionKey [Token] -> Either String (Integer, a))
-> DefineOptions a
DefineOptions (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 = forall val. OptionType val -> val
optionTypeDefault OptionType a
t,
              optionDescription :: String
optionDescription = String
"",
              optionGroup :: Maybe Group
optionGroup = forall a. Maybe a
Nothing,
              optionLocation :: Maybe Location
optionLocation = forall a. Maybe a
Nothing
            }
        )

    getInfo :: Integer -> (Integer, [OptionInfo])
getInfo Integer
key =
      ( Integer
key forall a. Num a => a -> a -> a
+ Integer
1,
        [ OptionInfo
            { optionInfoKey :: OptionKey
optionInfoKey = Integer -> OptionKey
OptionKeyGenerated Integer
key,
              optionInfoShortFlags :: String
optionInfoShortFlags = forall a. Option a -> String
optionShortFlags Option a
opt,
              optionInfoLongFlags :: [String]
optionInfoLongFlags = forall a. Option a -> [String]
optionLongFlags Option a
opt,
              optionInfoDefault :: String
optionInfoDefault = forall val. OptionType val -> val -> String
optionTypeShow OptionType a
t (forall a. Option a -> a
optionDefault Option a
opt),
              optionInfoDescription :: String
optionInfoDescription = forall a. Option a -> String
optionDescription Option a
opt,
              optionInfoGroup :: Maybe Group
optionInfoGroup = forall a. Option a -> Maybe Group
optionGroup Option a
opt,
              optionInfoLocation :: Maybe Location
optionInfoLocation = forall a. Option a -> Maybe Location
optionLocation Option a
opt,
              optionInfoTypeName :: String
optionInfoTypeName = forall val. OptionType val -> String
optionTypeName OptionType a
t,
              optionInfoUnary :: Bool
optionInfoUnary = forall a. Maybe a -> Bool
isJust (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 forall val. OptionType val -> Maybe val
optionTypeUnary OptionType a
t of
        Maybe a
Nothing -> forall a b. a -> Either a b
Left (String
"The flag " forall a. [a] -> [a] -> [a]
++ String
flagName forall a. [a] -> [a] -> [a]
++ String
" requires an argument.")
        Just a
val -> forall a b. b -> Either a b
Right a
val
      Token String
flagName String
rawValue -> case forall val. OptionType val -> String -> Either String val
optionTypeParse OptionType a
t String
rawValue of
        Left String
err -> forall a b. a -> Either a b
Left (String
"Value for flag " forall a. [a] -> [a] -> [a]
++ String
flagName forall a. [a] -> [a] -> [a]
++ String
" is invalid: " forall a. [a] -> [a] -> [a]
++ String
err)
        Right a
val -> 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 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 -> forall a b. b -> Either a b
Right (Integer
key forall a. Num a => a -> a -> a
+ Integer
1, 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.
        [] -> forall a b. b -> Either a b
Right (Integer
key forall a. Num a => a -> a -> a
+ Integer
1, forall a. Option a -> a
optionDefault Option a
opt)
        [Token
tok] -> case Token -> Either String a
parseToken Token
tok of
          Left String
err -> forall a b. a -> Either a b
Left String
err
          Right a
val -> forall a b. b -> Either a b
Right (Integer
key forall a. Num a => a -> a -> a
+ Integer
1, a
val)
        [Token]
_ -> case forall val. OptionType val -> Maybe ([val] -> val)
optionTypeMerge OptionType a
t of
          Maybe ([a] -> a)
Nothing -> forall a b. a -> Either a b
Left (String
"Multiple values for flag: " forall a. [a] -> [a] -> [a]
++ [Token] -> String
showMultipleFlagValues [Token]
toks)
          Just [a] -> a
appendFn -> case forall a err b. (a -> Either err b) -> [a] -> Either err [b]
mapEither Token -> Either String a
parseToken [Token]
toks of
            Left String
err -> forall a b. a -> Either a b
Left String
err
            Right [a]
vals -> forall a b. b -> Either a b
Right (Integer
key forall a. Num a => a -> a -> a
+ Integer
1, [a] -> a
appendFn [a]
vals)

showMultipleFlagValues :: [Token] -> String
showMultipleFlagValues :: [Token] -> String
showMultipleFlagValues = forall a. [a] -> [[a]] -> [a]
intercalate String
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a. Show a => a -> String
show (String
flagName forall a. [a] -> [a] -> [a]
++ 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 = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
  -- All subcommands have unique names.
  let subcmdNames :: [String]
subcmdNames = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, [OptionInfo])]
subInfos
  if forall a. Set a -> Int
Set.size (forall a. Ord a => [a] -> Set a
Set.fromList [String]
subcmdNames) forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
subcmdNames
    then -- TODO: the error should mention which subcommand names are duplicated
      forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError String
"Multiple subcommands exist with the same name."
    else 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 forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[OptionInfo]
infos | (String
_, [OptionInfo]
infos) <- [(String, [OptionInfo])]
subInfos]
  case forall a err b. (a -> Either err b) -> [a] -> Either err [b]
mapEither OptionInfo -> Either String ()
optValidFlags [OptionInfo]
allOptInfos of
    Left String
err -> forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError String
err
    Right [()]
_ -> 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 forall k a. Map k a
Map.empty [OptionInfo]
cmdInfos
  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 (forall a b. (a, b) -> b
snd (String, [OptionInfo])
subInfo))

  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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null (OptionInfo -> String
optionInfoShortFlags OptionInfo
info) Bool -> Bool -> 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 -> forall a b. a -> Either a b
Left (String
"Option with description " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (OptionInfo -> String
optionInfoDescription OptionInfo
info) forall a. [a] -> [a] -> [a]
++ String
" has no flags.")
      Just Location
loc -> forall a b. a -> Either a b
Left (String
"Option with description " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (OptionInfo -> String
optionInfoDescription OptionInfo
info) forall a. [a] -> [a] -> [a]
++ String
" at " forall a. [a] -> [a] -> [a]
++ Location -> String
locationFilename Location
loc forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Location -> Integer
locationLine Location
loc) forall a. [a] -> [a] -> [a]
++ String
" has no flags.")
    else -- TODO: All short or long flags have a reasonable name.
      forall a b. b -> Either a b
Right ()

data DeDupFlag = DeDupShort Char | DeDupLong String
  deriving (DeDupFlag -> DeDupFlag -> Bool
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
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
Ord, Int -> DeDupFlag -> ShowS
[DeDupFlag] -> ShowS
DeDupFlag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeDupFlag] -> ShowS
$cshowList :: [DeDupFlag] -> ShowS
show :: DeDupFlag -> String
$cshow :: DeDupFlag -> String
showsPrec :: Int -> DeDupFlag -> ShowS
$cshowsPrec :: Int -> DeDupFlag -> ShowS
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 [] = 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 = forall a b. (a -> b) -> [a] -> [b]
map Char -> DeDupFlag
DeDupShort (OptionInfo -> String
optionInfoShortFlags OptionInfo
info)
  let mappedLong :: [DeDupFlag]
mappedLong = forall a b. (a -> b) -> [a] -> [b]
map String -> DeDupFlag
DeDupLong (OptionInfo -> [String]
optionInfoLongFlags OptionInfo
info)
  let mappedFlags :: [DeDupFlag]
mappedFlags = [DeDupFlag]
mappedShort forall a. [a] -> [a] -> [a]
++ [DeDupFlag]
mappedLong
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DeDupFlag]
mappedFlags \DeDupFlag
mapKey -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DeDupFlag
mapKey Map DeDupFlag OptionInfo
checked of
    Maybe OptionInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just OptionInfo
prevInfo ->
      if OptionInfo -> OptionInfo -> Bool
eqIgnoringKey OptionInfo
info OptionInfo
prevInfo
        then forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else
          let flagName :: String
flagName = case DeDupFlag
mapKey of
                DeDupShort Char
flag -> Char
'-' forall a. a -> [a] -> [a]
: Char
flag forall a. a -> [a] -> [a]
: []
                DeDupLong String
long -> String
"--" forall a. [a] -> [a] -> [a]
++ String
long
           in forall (m :: * -> *) a. MonadError m => ErrorType m -> m a
throwError (String
"Duplicate option flag " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
flagName forall a. [a] -> [a] -> [a]
++ String
".")

  let infoMap :: Map DeDupFlag OptionInfo
infoMap = 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 (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 forall a. Eq a => a -> a -> Bool
== OptionInfo -> OptionInfo
normKey OptionInfo
y
  where
    normKey :: OptionInfo -> OptionInfo
normKey OptionInfo
info = OptionInfo
info {optionInfoKey :: OptionKey
optionInfoKey = OptionKey
OptionKeyIgnored}

-- | 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 = 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 = 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) = 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 -> forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions forall a. Maybe a
Nothing (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) -> forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
err) (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs forall a. Maybe a
Nothing) []
        (Maybe String
_, Right Tokens
tokens) -> case Tokens -> Maybe HelpFlag
checkHelpFlag Tokens
tokens of
          Just HelpFlag
helpFlag -> forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions forall a. Maybe a
Nothing forall a. Maybe a
Nothing (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
helpFlag OptionDefinitions
optionDefs 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 -> forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
err) (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs forall a. Maybe a
Nothing) []
            Right (Integer
_, opts
opts) -> forall opts.
Maybe opts
-> Maybe String -> String -> [String] -> ParsedOptions opts
ParsedOptions (forall a. a -> Maybe a
Just opts
opts) forall a. Maybe a
Nothing (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
System.Environment.getArgs
  let parsed :: ParsedOptions opts
parsed = forall opts. Options opts => [String] -> ParsedOptions opts
parseOptions [String]
argv
  case forall opts. ParsedOptions opts -> Maybe opts
parsedOptions ParsedOptions opts
parsed of
    Just opts
opts -> opts -> [String] -> m a
io opts
opts (forall opts. ParsedOptions opts -> [String]
parsedArguments ParsedOptions opts
parsed)
    Maybe opts
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO case forall a. Parsed a => a -> Maybe String
parsedError ParsedOptions opts
parsed of
      Just String
err -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (forall a. Parsed a => a -> String
parsedHelp ParsedOptions opts
parsed)
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
        forall a. IO a
exitFailure
      Maybe String
Nothing -> do
        Handle -> String -> IO ()
hPutStr Handle
stdout (forall a. Parsed a => a -> String
parsedHelp ParsedOptions opts
parsed)
        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 =
  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) = 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 -> forall a b. a -> Either a b
Left String
err
              Right (Integer
_, subcmdOpts
subOpts) -> 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) = 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
      forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, [OptionInfo]
infos)

    subcmdRunners :: Map String (cmdOpts -> Tokens -> Either String action)
subcmdRunners = 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
      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 -> forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand forall a. Maybe a
Nothing (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) -> forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand forall a. Maybe a
Nothing (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 -> forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand forall a. Maybe a
Nothing 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 -> forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
err) (HelpFlag -> OptionDefinitions -> Maybe String -> String
helpFor HelpFlag
HelpSummary OptionDefinitions
optionDefs Maybe String
subcmd)
            Right action
action -> forall action.
Maybe action -> Maybe String -> String -> ParsedSubcommand action
ParsedSubcommand (forall a. a -> Maybe a
Just action
action) 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 = 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 -> forall a b. a -> Either a b
Left String
err
      Right (Integer
_, cmdOpts
cmdOpts) -> case 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 -> forall a b. a -> Either a b
Left (String
"Unknown subcommand " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
subcmdName 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 -> forall a b. a -> Either a b
Left String
err
          Right action
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
System.Environment.getArgs
  let parsed :: ParsedSubcommand (m a)
parsed = forall cmdOpts action.
Options cmdOpts =>
[Subcommand cmdOpts action] -> [String] -> ParsedSubcommand action
parseSubcommand [Subcommand opts (m a)]
subcommands [String]
argv
  case forall action. ParsedSubcommand action -> Maybe action
parsedSubcommand ParsedSubcommand (m a)
parsed of
    Just m a
cmd -> m a
cmd
    Maybe (m a)
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case forall a. Parsed a => a -> Maybe String
parsedError ParsedSubcommand (m a)
parsed of
      Just String
err -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (forall a. Parsed a => a -> String
parsedHelp ParsedSubcommand (m a)
parsed)
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
        forall a. IO a
exitFailure
      Maybe String
Nothing -> do
        Handle -> String -> IO ()
hPutStr Handle
stdout (forall a. Parsed a => a -> String
parsedHelp ParsedSubcommand (m a)
parsed)
        forall a. IO a
exitSuccess