{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Options.Harg.Construct
  ( option,
    flag,
    switch,
    switch',
    argument,
    long,
    short,
    help,
    metavar,
    envVar,
    defaultVal,
    defaultStr,
    required,
    optional,
    parseWith,
    readParser,
    strParser,
    boolParser,
    manyParser,
    HasLong,
    HasShort,
    HasHelp,
    HasMetavar,
    HasEnvVar,
    HasDefaultVal,
    HasDefaultStr,
    HasRequired,
    HasOptional,
    IsOpt,
  )
where

import Data.Char (toLower)
import Data.Kind (Constraint)
import Data.List.Split (splitOn)
import Data.String (IsString (..))
import GHC.TypeLits (AppendSymbol, ErrorMessage (..), Symbol, TypeError)
import Options.Harg.Types
import Text.Read (readMaybe)

class HasLong o (attr :: [OptAttr]) where
  -- | Add a 'Options.Applicative.long' modifier to an option
  long :: String -> o attr a -> o attr a

instance HasLong OptionOpt a where
  long :: String -> OptionOpt a a -> OptionOpt a a
long s :: String
s o :: OptionOpt a a
o = OptionOpt a a
o {_oLong :: Maybe String
_oLong = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

instance HasLong FlagOpt a where
  long :: String -> FlagOpt a a -> FlagOpt a a
long s :: String
s o :: FlagOpt a a
o = FlagOpt a a
o {_fLong :: Maybe String
_fLong = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

class HasShort o (attr :: [OptAttr]) where
  -- | Add a 'Options.Applicative.short' modifier to an option
  short :: Char -> o attr a -> o attr a

instance HasShort OptionOpt a where
  short :: Char -> OptionOpt a a -> OptionOpt a a
short c :: Char
c o :: OptionOpt a a
o = OptionOpt a a
o {_oShort :: Maybe Char
_oShort = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c}

instance HasShort FlagOpt a where
  short :: Char -> FlagOpt a a -> FlagOpt a a
short c :: Char
c o :: FlagOpt a a
o = FlagOpt a a
o {_fShort :: Maybe Char
_fShort = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c}

class HasHelp o (attr :: [OptAttr]) where
  -- | Add 'Options.Applicative.help' to an option
  help :: String -> o attr a -> o attr a

instance HasHelp OptionOpt a where
  help :: String -> OptionOpt a a -> OptionOpt a a
help s :: String
s o :: OptionOpt a a
o = OptionOpt a a
o {_oHelp :: Maybe String
_oHelp = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

instance HasHelp FlagOpt a where
  help :: String -> FlagOpt a a -> FlagOpt a a
help s :: String
s o :: FlagOpt a a
o = FlagOpt a a
o {_fHelp :: Maybe String
_fHelp = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

instance HasHelp ArgumentOpt a where
  help :: String -> ArgumentOpt a a -> ArgumentOpt a a
help s :: String
s o :: ArgumentOpt a a
o = ArgumentOpt a a
o {_aHelp :: Maybe String
_aHelp = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

class HasMetavar o (attr :: [OptAttr]) where
  -- | Add a 'Options.Applicative.metavar' metavar to an option, to be
  -- displayed as the meta-parameter next to long/short modifiers
  metavar :: String -> o attr a -> o attr a

instance HasMetavar OptionOpt a where
  metavar :: String -> OptionOpt a a -> OptionOpt a a
metavar s :: String
s o :: OptionOpt a a
o = OptionOpt a a
o {_oMetavar :: Maybe String
_oMetavar = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

instance HasMetavar ArgumentOpt a where
  metavar :: String -> ArgumentOpt a a -> ArgumentOpt a a
metavar s :: String
s o :: ArgumentOpt a a
o = ArgumentOpt a a
o {_aMetavar :: Maybe String
_aMetavar = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

class HasEnvVar o (attr :: [OptAttr]) where
  -- | Specify an environment variable to lookup for an option
  envVar :: String -> o attr a -> o attr a

instance HasEnvVar OptionOpt a where
  envVar :: String -> OptionOpt a a -> OptionOpt a a
envVar s :: String
s o :: OptionOpt a a
o = OptionOpt a a
o {_oEnvVar :: Maybe String
_oEnvVar = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

instance HasEnvVar FlagOpt a where
  envVar :: String -> FlagOpt a a -> FlagOpt a a
envVar s :: String
s o :: FlagOpt a a
o = FlagOpt a a
o {_fEnvVar :: Maybe String
_fEnvVar = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

instance HasEnvVar ArgumentOpt a where
  envVar :: String -> ArgumentOpt a a -> ArgumentOpt a a
envVar s :: String
s o :: ArgumentOpt a a
o = ArgumentOpt a a
o {_aEnvVar :: Maybe String
_aEnvVar = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

class HasDefaultVal o (attr :: [OptAttr]) where
  -- | Add a default value to an option. Cannot be used in conjuction with
  -- with 'required', 'defaultStr' or 'optional'.
  defaultVal ::
    ( NotInAttrs OptDefault attr (DuplicateAttrMultipleErr "defaultVal" '["defaultStr", "required"]),
      NotInAttrs OptOptional attr (IncompatibleAttrsErr "defaultVal" "optional")
    ) =>
    a ->
    o attr a ->
    o (OptDefault ': attr) a

instance HasDefaultVal OptionOpt a where
  defaultVal :: a -> OptionOpt a a -> OptionOpt ('OptDefault : a) a
defaultVal a :: a
a o :: OptionOpt a a
o = OptionOpt a a
o {_oDefaultVal :: Maybe a
_oDefaultVal = a -> Maybe a
forall a. a -> Maybe a
Just a
a}

instance HasDefaultVal ArgumentOpt a where
  defaultVal :: a -> ArgumentOpt a a -> ArgumentOpt ('OptDefault : a) a
defaultVal a :: a
a o :: ArgumentOpt a a
o = ArgumentOpt a a
o {_aDefaultVal :: Maybe a
_aDefaultVal = a -> Maybe a
forall a. a -> Maybe a
Just a
a}

class HasDefaultStr o (attr :: [OptAttr]) where
  -- | Add a default unparsed value to an option. Cannot be used in conjuction
  -- with 'defaultVal', 'required' or 'optional'.
  defaultStr ::
    ( NotInAttrs OptDefault attr (DuplicateAttrMultipleErr "defaultStr" '["defaultVal", "required"]),
      NotInAttrs OptOptional attr (IncompatibleAttrsErr "defaultStr" "optional")
    ) =>
    String ->
    o attr a ->
    o (OptDefault ': attr) a

instance HasDefaultStr OptionOpt a where
  defaultStr :: String -> OptionOpt a a -> OptionOpt ('OptDefault : a) a
defaultStr s :: String
s o :: OptionOpt a a
o = OptionOpt a a
o {_oDefaultStr :: Maybe String
_oDefaultStr = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

instance HasDefaultStr ArgumentOpt a where
  defaultStr :: String -> ArgumentOpt a a -> ArgumentOpt ('OptDefault : a) a
defaultStr s :: String
s o :: ArgumentOpt a a
o = ArgumentOpt a a
o {_aDefaultStr :: Maybe String
_aDefaultStr = String -> Maybe String
forall a. a -> Maybe a
Just String
s}

class HasRequired o (attr :: [OptAttr]) where
  -- | Mark an option as required. Cannot be used in conjunction with
  -- 'optional', 'defaultVal' or 'requiredStr'.
  required ::
    ( NotInAttrs OptDefault attr (DuplicateAttrMultipleErr "required" '["defaultVal", "defaultStr"]),
      NotInAttrs OptOptional attr (IncompatibleAttrsErr "required" "optional")
    ) =>
    o attr a ->
    o (OptDefault ': attr) a

instance HasRequired OptionOpt a where
  required :: OptionOpt a a -> OptionOpt ('OptDefault : a) a
required o :: OptionOpt a a
o = OptionOpt a a
o {_oDefaultVal :: Maybe a
_oDefaultVal = Maybe a
forall a. Maybe a
Nothing}

instance HasRequired ArgumentOpt a where
  required :: ArgumentOpt a a -> ArgumentOpt ('OptDefault : a) a
required o :: ArgumentOpt a a
o = ArgumentOpt a a
o {_aDefaultVal :: Maybe a
_aDefaultVal = Maybe a
forall a. Maybe a
Nothing}

-- | Class for options that can be optional. Cannot be used in conjunction with
-- 'HasDefaultVal', 'HasDefaultStr' or 'HasRequired'. Note that this will turn a
-- parser for @a@ into a parser for @Maybe a@, modifying the reader function
-- appropriately.
-- For example:
--
-- @
--   someOpt :: Opt (Maybe Int)
--   someOpt
--     = optionWith readParser
--         ( long "someopt"
--         . optional
--         )
-- @
class HasOptional o (attr :: [OptAttr]) where
  -- | Specify that an option is optional. This will convert an @Opt a@ to an
  -- @Opt (Maybe a)@. Cannot be used in conjunction with 'defaultVal', 'defaultStr'
  -- or 'required'.
  optional ::
    ( NotInAttrs OptOptional attr (DuplicateAttrErr "optional"),
      NotInAttrs OptDefault attr (IncompatibleAttrsErr "optional" "defaultVal")
    ) =>
    o attr a ->
    o (OptOptional ': attr) (Maybe a)

instance HasOptional OptionOpt a where
  optional :: OptionOpt a a -> OptionOpt ('OptOptional : a) (Maybe a)
optional OptionOpt {..} =
    OptionOpt :: forall (attr :: [OptAttr]) a.
Maybe String
-> Maybe Char
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe a
-> Maybe String
-> OptReader a
-> OptionOpt attr a
OptionOpt
      { _oLong :: Maybe String
_oLong = Maybe String
_oLong,
        _oShort :: Maybe Char
_oShort = Maybe Char
_oShort,
        _oHelp :: Maybe String
_oHelp = Maybe String
_oHelp,
        _oMetavar :: Maybe String
_oMetavar = Maybe String
_oMetavar,
        _oEnvVar :: Maybe String
_oEnvVar = Maybe String
_oEnvVar,
        _oDefaultVal :: Maybe (Maybe a)
_oDefaultVal = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing,
        _oDefaultStr :: Maybe String
_oDefaultStr = Maybe String
forall a. Maybe a
Nothing,
        _oReader :: OptReader (Maybe a)
_oReader = (a -> Maybe a) -> Either String a -> Either String (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Either String a -> Either String (Maybe a))
-> OptReader a -> OptReader (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptReader a
_oReader
      }

instance HasOptional ArgumentOpt a where
  optional :: ArgumentOpt a a -> ArgumentOpt ('OptOptional : a) (Maybe a)
optional ArgumentOpt {..} =
    ArgumentOpt :: forall (attr :: [OptAttr]) a.
Maybe String
-> Maybe String
-> Maybe String
-> Maybe a
-> Maybe String
-> OptReader a
-> ArgumentOpt attr a
ArgumentOpt
      { _aHelp :: Maybe String
_aHelp = Maybe String
_aHelp,
        _aMetavar :: Maybe String
_aMetavar = Maybe String
_aMetavar,
        _aEnvVar :: Maybe String
_aEnvVar = Maybe String
_aEnvVar,
        _aDefaultVal :: Maybe (Maybe a)
_aDefaultVal = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing,
        _aDefaultStr :: Maybe String
_aDefaultStr = Maybe String
forall a. Maybe a
Nothing,
        _aReader :: OptReader (Maybe a)
_aReader = (a -> Maybe a) -> Either String a -> Either String (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Either String a -> Either String (Maybe a))
-> OptReader a -> OptReader (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptReader a
_aReader
      }

-- | Class to convert an intermediate option type into 'Opt'. Instances
-- should set the appropriate '_optType'.
class IsOpt o (attr :: [OptAttr]) where
  -- | Convert an intermediate option to an 'Opt'
  toOpt :: o attr a -> Opt a

instance IsOpt OptionOpt attr where
  toOpt :: OptionOpt attr a -> Opt a
toOpt OptionOpt {..} =
    Opt :: forall a.
Maybe String
-> Maybe Char
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe a
-> Maybe String
-> OptReader a
-> OptType a
-> Opt a
Opt
      { _optLong :: Maybe String
_optLong = Maybe String
_oLong,
        _optShort :: Maybe Char
_optShort = Maybe Char
_oShort,
        _optHelp :: Maybe String
_optHelp = Maybe String
_oHelp,
        _optMetavar :: Maybe String
_optMetavar = Maybe String
_oMetavar,
        _optEnvVar :: Maybe String
_optEnvVar = Maybe String
_oEnvVar,
        _optDefaultVal :: Maybe a
_optDefaultVal = Maybe a
_oDefaultVal,
        _optDefaultStr :: Maybe String
_optDefaultStr = Maybe String
_oDefaultStr,
        _optReader :: OptReader a
_optReader = OptReader a
_oReader,
        _optType :: OptType a
_optType = OptType a
forall a. OptType a
OptionOptType
      }

instance IsOpt FlagOpt attr where
  toOpt :: FlagOpt attr a -> Opt a
toOpt FlagOpt {..} =
    Opt :: forall a.
Maybe String
-> Maybe Char
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe a
-> Maybe String
-> OptReader a
-> OptType a
-> Opt a
Opt
      { _optLong :: Maybe String
_optLong = Maybe String
_fLong,
        _optShort :: Maybe Char
_optShort = Maybe Char
_fShort,
        _optHelp :: Maybe String
_optHelp = Maybe String
_fHelp,
        _optMetavar :: Maybe String
_optMetavar = Maybe String
forall a. Maybe a
Nothing,
        _optEnvVar :: Maybe String
_optEnvVar = Maybe String
_fEnvVar,
        _optDefaultVal :: Maybe a
_optDefaultVal = a -> Maybe a
forall a. a -> Maybe a
Just a
_fDefaultVal,
        _optDefaultStr :: Maybe String
_optDefaultStr = Maybe String
forall a. Maybe a
Nothing,
        _optReader :: OptReader a
_optReader = OptReader a
_fReader,
        _optType :: OptType a
_optType = a -> OptType a
forall a. a -> OptType a
FlagOptType a
_fActive
      }

instance IsOpt ArgumentOpt attr where
  toOpt :: ArgumentOpt attr a -> Opt a
toOpt ArgumentOpt {..} =
    Opt :: forall a.
Maybe String
-> Maybe Char
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe a
-> Maybe String
-> OptReader a
-> OptType a
-> Opt a
Opt
      { _optLong :: Maybe String
_optLong = Maybe String
forall a. Maybe a
Nothing,
        _optShort :: Maybe Char
_optShort = Maybe Char
forall a. Maybe a
Nothing,
        _optHelp :: Maybe String
_optHelp = Maybe String
_aHelp,
        _optMetavar :: Maybe String
_optMetavar = Maybe String
_aMetavar,
        _optEnvVar :: Maybe String
_optEnvVar = Maybe String
_aEnvVar,
        _optDefaultVal :: Maybe a
_optDefaultVal = Maybe a
_aDefaultVal,
        _optDefaultStr :: Maybe String
_optDefaultStr = Maybe String
_aDefaultStr,
        _optReader :: OptReader a
_optReader = OptReader a
_aReader,
        _optType :: OptType a
_optType = OptType a
forall a. OptType a
ArgumentOptType
      }

-- | Create an option parser, equivalent to 'Options.Applicative.option'. The
-- second argument is the modifiers to add to the option, and can be defined by
-- using function composition ('.').
--
-- @
--   someOption :: Opt Int
--   someOption
--     = option readParser
--         ( long "someopt"
--         . help "Some option"
--         . defaultVal 256
--         )
-- @
option ::
  OptReader a ->
  (OptionOpt '[] a -> OptionOpt attr b) ->
  Opt b
option :: OptReader a -> (OptionOpt '[] a -> OptionOpt attr b) -> Opt b
option p :: OptReader a
p f :: OptionOpt '[] a -> OptionOpt attr b
f =
  OptionOpt attr b -> Opt b
forall (o :: [OptAttr] -> * -> *) (attr :: [OptAttr]) a.
IsOpt o attr =>
o attr a -> Opt a
toOpt (OptionOpt attr b -> Opt b) -> OptionOpt attr b -> Opt b
forall a b. (a -> b) -> a -> b
$ OptionOpt '[] a -> OptionOpt attr b
f OptionOpt '[] a
opt
  where
    opt :: OptionOpt '[] a
opt =
      OptionOpt :: forall (attr :: [OptAttr]) a.
Maybe String
-> Maybe Char
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe a
-> Maybe String
-> OptReader a
-> OptionOpt attr a
OptionOpt
        { _oLong :: Maybe String
_oLong = Maybe String
forall a. Maybe a
Nothing,
          _oShort :: Maybe Char
_oShort = Maybe Char
forall a. Maybe a
Nothing,
          _oHelp :: Maybe String
_oHelp = Maybe String
forall a. Maybe a
Nothing,
          _oMetavar :: Maybe String
_oMetavar = Maybe String
forall a. Maybe a
Nothing,
          _oEnvVar :: Maybe String
_oEnvVar = Maybe String
forall a. Maybe a
Nothing,
          _oDefaultVal :: Maybe a
_oDefaultVal = Maybe a
forall a. Maybe a
Nothing,
          _oDefaultStr :: Maybe String
_oDefaultStr = Maybe String
forall a. Maybe a
Nothing,
          _oReader :: OptReader a
_oReader = OptReader a
p
        }

-- | Create a flag parser, equivalent to 'Options.Applicative.option'. The
-- first argument is the default value (returned when the flag modifier is
-- absent), and the second is the active value (returned when the flag
-- modifier is present). The second argument is the modifiers to add to the
-- option, and can be defined by using function composition ('.').
--
-- @
--   someFlag :: Opt Int
--   someFlag
--     = flag 0 1
--         ( long "someflag"
--         . help "Some flag"
--         )
-- @
flag ::
  -- | Default value
  a ->
  -- | Active value
  a ->
  (FlagOpt '[] a -> FlagOpt attr b) ->
  Opt b
flag :: a -> a -> (FlagOpt '[] a -> FlagOpt attr b) -> Opt b
flag d :: a
d active :: a
active f :: FlagOpt '[] a -> FlagOpt attr b
f =
  FlagOpt attr b -> Opt b
forall (o :: [OptAttr] -> * -> *) (attr :: [OptAttr]) a.
IsOpt o attr =>
o attr a -> Opt a
toOpt (FlagOpt attr b -> Opt b) -> FlagOpt attr b -> Opt b
forall a b. (a -> b) -> a -> b
$ FlagOpt '[] a -> FlagOpt attr b
f FlagOpt '[] a
opt
  where
    opt :: FlagOpt '[] a
opt =
      FlagOpt :: forall (attr :: [OptAttr]) a.
Maybe String
-> Maybe Char
-> Maybe String
-> Maybe String
-> a
-> OptReader a
-> a
-> FlagOpt attr a
FlagOpt
        { _fLong :: Maybe String
_fLong = Maybe String
forall a. Maybe a
Nothing,
          _fShort :: Maybe Char
_fShort = Maybe Char
forall a. Maybe a
Nothing,
          _fHelp :: Maybe String
_fHelp = Maybe String
forall a. Maybe a
Nothing,
          _fEnvVar :: Maybe String
_fEnvVar = Maybe String
forall a. Maybe a
Nothing,
          _fDefaultVal :: a
_fDefaultVal = a
d,
          _fActive :: a
_fActive = a
active,
          _fReader :: OptReader a
_fReader = Either String a -> OptReader a
forall a b. a -> b -> a
const (a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
d) -- TODO
        }

-- | A 'flag' parser, specialized to 'Bool'. The parser (e.g. when parsing
-- an environment variable) will accept @true@ and @false@, but case
-- insensitive, rather than using the 'Read' instance for 'Bool'. The
-- default value is 'False', and the active value is 'True'.
--
-- @
--   someSwitch :: Opt Bool
--   someSwitch
--     = switch
--         ( long "someswitch"
--         . help "Some switch"
--         )
-- @
switch ::
  (FlagOpt '[] Bool -> FlagOpt attr Bool) ->
  Opt Bool
switch :: (FlagOpt '[] Bool -> FlagOpt attr Bool) -> Opt Bool
switch f :: FlagOpt '[] Bool -> FlagOpt attr Bool
f =
  Opt Bool
fl {_optReader :: OptReader Bool
_optReader = OptReader Bool
boolParser}
  where
    fl :: Opt Bool
fl =
      Bool -> Bool -> (FlagOpt '[] Bool -> FlagOpt attr Bool) -> Opt Bool
forall a (attr :: [OptAttr]) b.
a -> a -> (FlagOpt '[] a -> FlagOpt attr b) -> Opt b
flag Bool
False Bool
True FlagOpt '[] Bool -> FlagOpt attr Bool
f

-- | Similar to 'switch', but the default value is 'True' and the active is
-- 'False'.
switch' ::
  (FlagOpt '[] Bool -> FlagOpt attr Bool) ->
  Opt Bool
switch' :: (FlagOpt '[] Bool -> FlagOpt attr Bool) -> Opt Bool
switch' f :: FlagOpt '[] Bool -> FlagOpt attr Bool
f =
  Opt Bool
fl {_optReader :: OptReader Bool
_optReader = OptReader Bool
boolParser}
  where
    fl :: Opt Bool
fl =
      Bool -> Bool -> (FlagOpt '[] Bool -> FlagOpt attr Bool) -> Opt Bool
forall a (attr :: [OptAttr]) b.
a -> a -> (FlagOpt '[] a -> FlagOpt attr b) -> Opt b
flag Bool
True Bool
False FlagOpt '[] Bool -> FlagOpt attr Bool
f

-- | Create an argument parser, equivalent to 'Options.Applicative.argument'.
-- The second argument is the modifiers to add to the option, and can be
-- defined by using function composition ('.').
--
-- @
--   someArgument :: Opt Int
--   someArgument
--     = argument
--         ( help "Some argument"
--         . defaultVal "this is the default"
--         )
-- @
argument ::
  OptReader a ->
  (ArgumentOpt '[] a -> ArgumentOpt attr b) ->
  Opt b
argument :: OptReader a -> (ArgumentOpt '[] a -> ArgumentOpt attr b) -> Opt b
argument p :: OptReader a
p f :: ArgumentOpt '[] a -> ArgumentOpt attr b
f =
  ArgumentOpt attr b -> Opt b
forall (o :: [OptAttr] -> * -> *) (attr :: [OptAttr]) a.
IsOpt o attr =>
o attr a -> Opt a
toOpt (ArgumentOpt attr b -> Opt b) -> ArgumentOpt attr b -> Opt b
forall a b. (a -> b) -> a -> b
$ ArgumentOpt '[] a -> ArgumentOpt attr b
f ArgumentOpt '[] a
opt
  where
    opt :: ArgumentOpt '[] a
opt =
      ArgumentOpt :: forall (attr :: [OptAttr]) a.
Maybe String
-> Maybe String
-> Maybe String
-> Maybe a
-> Maybe String
-> OptReader a
-> ArgumentOpt attr a
ArgumentOpt
        { _aHelp :: Maybe String
_aHelp = Maybe String
forall a. Maybe a
Nothing,
          _aMetavar :: Maybe String
_aMetavar = Maybe String
forall a. Maybe a
Nothing,
          _aEnvVar :: Maybe String
_aEnvVar = Maybe String
forall a. Maybe a
Nothing,
          _aDefaultVal :: Maybe a
_aDefaultVal = Maybe a
forall a. Maybe a
Nothing,
          _aDefaultStr :: Maybe String
_aDefaultStr = Maybe String
forall a. Maybe a
Nothing,
          _aReader :: OptReader a
_aReader = OptReader a
p
        }

-- | Convert a parser that returns 'Maybe' to a parser that returns 'Either',
-- with the default 'Left' value @unable to parse: \<input\>@.
parseWith ::
  -- | Original parser
  (String -> Maybe a) ->
  (String -> Either String a)
parseWith :: (String -> Maybe a) -> String -> Either String a
parseWith parser :: String -> Maybe a
parser s :: String
s =
  Either String a
-> (a -> Either String a) -> Maybe a -> Either String a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String a
forall a b. a -> Either a b
Left String
err) a -> Either String a
forall a b. b -> Either a b
Right (String -> Maybe a
parser String
s)
  where
    err :: String
err =
      "Unable to parse: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s

-- | A parser that uses the 'Read' instance to parse into a type.
readParser :: Read a => OptReader a
readParser :: OptReader a
readParser =
  (String -> Maybe a) -> OptReader a
forall a. (String -> Maybe a) -> String -> Either String a
parseWith String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe

-- | A parser that returns a string. Any type that has an instance of
-- 'IsString' will work, and this parser always succeeds.
strParser ::
  IsString s =>
  String ->
  Either String s
strParser :: String -> Either String s
strParser =
  s -> Either String s
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> Either String s)
-> (String -> s) -> String -> Either String s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> s
forall a. IsString a => String -> a
fromString

-- | A parser that returns a 'Bool'. This will succeed for the strings
-- @true@ and @false@ in a case-insensitive manner.
boolParser :: String -> Either String Bool
boolParser :: OptReader Bool
boolParser s :: String
s =
  case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
    "true" -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
True
    "false" -> Bool -> Either String Bool
forall a b. b -> Either a b
Right Bool
False
    _ -> OptReader Bool
forall a b. a -> Either a b
Left ("Unable to parse " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " to Bool")

-- | A parser that can parse many items, returning a list.
manyParser ::
  -- | Separator
  String ->
  -- | Parser for each string
  OptReader a ->
  OptReader [a]
manyParser :: String -> OptReader a -> OptReader [a]
manyParser sep :: String
sep parser :: OptReader a
parser =
  OptReader a -> [String] -> Either String [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse OptReader a
parser ([String] -> Either String [a])
-> (String -> [String]) -> OptReader [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
sep

-- | Wrap a symbol in quotes, for pretty printing in type errors.
type QuoteSym (s :: Symbol) =
  'Text "`" :<>: 'Text s :<>: 'Text "`"

-- | Check if `x` is not an element of the type-level list `xs`. If it is
-- print the appropriate error message using `l` and `r` for clarity.
type family
  NotInAttrs
    (x :: k)
    (xs :: [k])
    (err :: ErrorMessage) ::
    Constraint
  where
  NotInAttrs _ '[] _ =
    ()
  NotInAttrs x (x ': _) err =
    TypeError err
  NotInAttrs x (y ': xs) err =
    NotInAttrs x xs err

type family CommaSep (xs :: [Symbol]) :: Symbol where
  CommaSep '[] = ""
  CommaSep '[x] = " or " `AppendSymbol` x
  CommaSep (x ': xs) = " or one of " `AppendSymbol` CommaSep' x xs

type family CommaSep' (s :: Symbol) (xs :: [Symbol]) :: Symbol where
  CommaSep' s '[] = s
  CommaSep' s (x ': xs) = CommaSep' (s `AppendSymbol` ", " `AppendSymbol` x) xs

type DuplicateAttrErr attr =
  QuoteSym attr
    :<>: 'Text " is already specified."

type DuplicateAttrMultipleErr attr rest =
  QuoteSym attr
    :<>: 'Text (CommaSep rest)
    :<>: 'Text " has already been specified."

type IncompatibleAttrsErr l r =
  QuoteSym l
    :<>: 'Text " and "
    :<>: QuoteSym r
    :<>: 'Text " cannot be mixed in an option definition."