{-# LANGUAGE DeriveFunctor #-}

module Options.Harg.Types
  ( Opt (..),
    OptionOpt (..),
    FlagOpt (..),
    ArgumentOpt (..),
    OptAttr (..),
    OptType (..),
    SomeOpt (..),
    OptReader,
    HargCtx (..),
    Environment,
    getCtx,
    ctxFromArgs,
    ctxFromEnv,
    pureCtx,
  )
where

import System.Environment (getArgs, getEnvironment)

type OptReader a = String -> Either String a

-- | The basic option type
data Opt a = Opt
  { -- | Modifier for long options (e.g. @--user@)
    Opt a -> Maybe String
_optLong :: Maybe String,
    -- | Modifier for short options (e.g. @-u@)
    Opt a -> Maybe Char
_optShort :: Maybe Char,
    -- | Option help to be shown when invoked
    --   with @--help/-h@ or in case of error
    Opt a -> Maybe String
_optHelp :: Maybe String,
    -- | Metavar to be shown in the help description
    Opt a -> Maybe String
_optMetavar :: Maybe String,
    -- | Environment variable for use with 'EnvSource'
    Opt a -> Maybe String
_optEnvVar :: Maybe String,
    -- | Default value
    Opt a -> Maybe a
_optDefaultVal :: Maybe a,
    -- | Default value as string (unparsed)
    Opt a -> Maybe String
_optDefaultStr :: Maybe String,
    -- | Option parser
    Opt a -> OptReader a
_optReader :: OptReader a,
    -- | Option type
    Opt a -> OptType a
_optType :: OptType a
  }
  deriving (a -> Opt b -> Opt a
(a -> b) -> Opt a -> Opt b
(forall a b. (a -> b) -> Opt a -> Opt b)
-> (forall a b. a -> Opt b -> Opt a) -> Functor Opt
forall a b. a -> Opt b -> Opt a
forall a b. (a -> b) -> Opt a -> Opt b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Opt b -> Opt a
$c<$ :: forall a b. a -> Opt b -> Opt a
fmap :: (a -> b) -> Opt a -> Opt b
$cfmap :: forall a b. (a -> b) -> Opt a -> Opt b
Functor)

-- | Option types
data OptType a
  = OptionOptType
  | -- | @a@ is the active value for the flag parser
    FlagOptType a
  | ArgumentOptType
  deriving (a -> OptType b -> OptType a
(a -> b) -> OptType a -> OptType b
(forall a b. (a -> b) -> OptType a -> OptType b)
-> (forall a b. a -> OptType b -> OptType a) -> Functor OptType
forall a b. a -> OptType b -> OptType a
forall a b. (a -> b) -> OptType a -> OptType b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> OptType b -> OptType a
$c<$ :: forall a b. a -> OptType b -> OptType a
fmap :: (a -> b) -> OptType a -> OptType b
$cfmap :: forall a b. (a -> b) -> OptType a -> OptType b
Functor)

data OptAttr
  = OptDefault
  | OptOptional

-- * Intermediate option types

-- | Option for flags with arguments. Corresponds to 'Options.Applicative.option'.
data OptionOpt (attr :: [OptAttr]) a = OptionOpt
  { OptionOpt attr a -> Maybe String
_oLong :: Maybe String,
    OptionOpt attr a -> Maybe Char
_oShort :: Maybe Char,
    OptionOpt attr a -> Maybe String
_oHelp :: Maybe String,
    OptionOpt attr a -> Maybe String
_oMetavar :: Maybe String,
    OptionOpt attr a -> Maybe String
_oEnvVar :: Maybe String,
    OptionOpt attr a -> Maybe a
_oDefaultVal :: Maybe a,
    OptionOpt attr a -> Maybe String
_oDefaultStr :: Maybe String,
    OptionOpt attr a -> OptReader a
_oReader :: OptReader a
  }

-- | Option for flags that act like switches between a default and an active
-- value. Corresponds to 'Options.Applicative.flag'.
data FlagOpt (attr :: [OptAttr]) a = FlagOpt
  { FlagOpt attr a -> Maybe String
_fLong :: Maybe String,
    FlagOpt attr a -> Maybe Char
_fShort :: Maybe Char,
    FlagOpt attr a -> Maybe String
_fHelp :: Maybe String,
    FlagOpt attr a -> Maybe String
_fEnvVar :: Maybe String,
    FlagOpt attr a -> a
_fDefaultVal :: a,
    FlagOpt attr a -> OptReader a
_fReader :: OptReader a,
    FlagOpt attr a -> a
_fActive :: a
  }

-- | Option for arguments (no long/short specifiers). Corresponds to
-- 'Options.Applicative.argument'.
data ArgumentOpt (attr :: [OptAttr]) a = ArgumentOpt
  { ArgumentOpt attr a -> Maybe String
_aHelp :: Maybe String,
    ArgumentOpt attr a -> Maybe String
_aMetavar :: Maybe String,
    ArgumentOpt attr a -> Maybe String
_aEnvVar :: Maybe String,
    ArgumentOpt attr a -> Maybe a
_aDefaultVal :: Maybe a,
    ArgumentOpt attr a -> Maybe String
_aDefaultStr :: Maybe String,
    ArgumentOpt attr a -> OptReader a
_aReader :: OptReader a
  }

-- | Existential wrapper for 'Opt', so that many options can be carried in
-- a list.
data SomeOpt where
  SomeOpt :: Opt a -> SomeOpt

-- | Environment variable pairs, can be retrieved with 'getEnvironment'.
type Environment =
  [(String, String)]

-- | Command line arguments, can be retrieved with 'getArgs'.
type Args =
  [String]

-- | Context to carry around, that contains environment variables and
-- command line arguments.
data HargCtx = HargCtx
  { HargCtx -> Environment
_hcEnv :: Environment,
    HargCtx -> Args
_hcArgs :: Args
  }

getCtx :: IO HargCtx
getCtx :: IO HargCtx
getCtx =
  Environment -> Args -> HargCtx
HargCtx (Environment -> Args -> HargCtx)
-> IO Environment -> IO (Args -> HargCtx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Environment
getEnvironment IO (Args -> HargCtx) -> IO Args -> IO HargCtx
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Args
getArgs

ctxFromArgs :: Args -> IO HargCtx
ctxFromArgs :: Args -> IO HargCtx
ctxFromArgs args :: Args
args =
  Environment -> Args -> HargCtx
HargCtx (Environment -> Args -> HargCtx)
-> IO Environment -> IO (Args -> HargCtx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Environment
getEnvironment IO (Args -> HargCtx) -> IO Args -> IO HargCtx
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Args -> IO Args
forall (f :: * -> *) a. Applicative f => a -> f a
pure Args
args

ctxFromEnv :: Environment -> IO HargCtx
ctxFromEnv :: Environment -> IO HargCtx
ctxFromEnv env :: Environment
env =
  Environment -> Args -> HargCtx
HargCtx Environment
env (Args -> HargCtx) -> IO Args -> IO HargCtx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Args
getArgs

pureCtx :: Environment -> Args -> HargCtx
pureCtx :: Environment -> Args -> HargCtx
pureCtx =
  Environment -> Args -> HargCtx
HargCtx