module Optima
  ( -- * IO
    params,

    -- * Params
    Params,
    param,
    group,

    -- * ParamGroup
    ParamGroup,
    member,
    subgroup,

    -- * Param
    Param,
    value,
    flag,

    -- * Value
    Value,
    explicitlyParsed,
    implicitlyParsed,

    -- * Default
    Default,
    explicitlyRepresented,
    showable,
    defaultless,

    -- * ValueFormat
    ValueFormat,
    formattedByEnum,
    formattedByEnumUsingShow,
    unformatted,
  )
where

import qualified Attoparsec.Data as Attoparsec
import qualified Data.Attoparsec.Text as Attoparsec
import qualified Data.Text as Text
import Optima.Prelude hiding (group)
import qualified Options.Applicative as Optparse
import qualified Text.Builder as TextBuilder

-- * Types

-- |
-- Parameters product parser.
-- Should be used for composition of all application parameters.
newtype Params a = Params (Optparse.Parser a)

-- |
-- Parameter parser.
--
-- Includes the description of the parameter.
newtype Param a = Param (Maybe Char -> Text -> Optparse.Parser a)

-- |
-- Parameter group, which gets identified by prefixing the names.
--
-- Should be used to define parameters, which only make sense in combination.
-- E.g., a server config can be defined by providing port and host together.
newtype ParamGroup a = ParamGroup (Text -> Optparse.Parser a)

-- |
-- Parameter value parser.
newtype Value a = Value (Attoparsec.Parser a)

-- |
-- Default value with its textual representation.
data Default a = SpecifiedDefault a Text | UnspecifiedDefault

-- |
-- Parameter description.
data ValueFormat a = EnumValueFormat [TextBuilder.Builder] | UnspecifiedFormat

-- * Instances

deriving instance Functor Params

deriving instance Applicative Params

deriving instance Alternative Params

deriving instance Functor ParamGroup

instance Applicative ParamGroup where
  pure :: forall a. a -> ParamGroup a
pure a
x = forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  <*> :: forall a b. ParamGroup (a -> b) -> ParamGroup a -> ParamGroup b
(<*>) (ParamGroup Text -> Parser (a -> b)
left) (ParamGroup Text -> Parser a
right) = forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\Text
prefix -> Text -> Parser (a -> b)
left Text
prefix forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser a
right Text
prefix)

instance Alternative ParamGroup where
  empty :: forall a. ParamGroup a
empty = forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\Text
_ -> forall (f :: * -> *) a. Alternative f => f a
empty)
  <|> :: forall a. ParamGroup a -> ParamGroup a -> ParamGroup a
(<|>) (ParamGroup Text -> Parser a
left) (ParamGroup Text -> Parser a
right) = forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\Text
prefix -> Text -> Parser a
left Text
prefix forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser a
right Text
prefix)
  many :: forall a. ParamGroup a -> ParamGroup [a]
many (ParamGroup Text -> Parser a
parser) = forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\Text
prefix -> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Text -> Parser a
parser Text
prefix))
  some :: forall a. ParamGroup a -> ParamGroup [a]
some (ParamGroup Text -> Parser a
parser) = forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\Text
prefix -> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Text -> Parser a
parser Text
prefix))

deriving instance Functor Param

deriving instance Functor Value

deriving instance Applicative Value

deriving instance Alternative Value

deriving instance Monad Value

deriving instance MonadPlus Value

deriving instance MonadFail Value

deriving instance Functor Default

deriving instance Functor ValueFormat

-- * Functions

-- ** IO

-- |
-- Execute the parameters parser in IO,
-- throwing an exception if anything goes wrong.
params ::
  -- | Description of the application
  Text ->
  Params a ->
  IO a
params :: forall a. Text -> Params a -> IO a
params Text
description (Params Parser a
parser) =
  forall a. ParserInfo a -> IO a
Optparse.execParser (forall a. Parser a -> InfoMod a -> ParserInfo a
Optparse.info (forall a. Parser (a -> a)
Optparse.helper forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
parser) InfoMod a
mods)
  where
    mods :: InfoMod a
mods = forall a. InfoMod a
Optparse.fullDesc forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
Optparse.progDesc (Text -> String
Text.unpack Text
description)

-- ** Params

-- |
-- Lift a single parameter parser.
param ::
  -- | Single-char name
  Maybe Char ->
  -- | Long name
  Text ->
  Param a ->
  Params a
param :: forall a. Maybe Char -> Text -> Param a -> Params a
param Maybe Char
shortName Text
longName (Param Maybe Char -> Text -> Parser a
parser) = forall a. Parser a -> Params a
Params (Maybe Char -> Text -> Parser a
parser Maybe Char
shortName Text
longName)

-- |
-- Lift a parameter group parser.
--
-- The param group cannot use short names, only long names.
group ::
  -- | Prefix for the long names of the parameters. If empty, then there'll be no prefixing
  Text ->
  ParamGroup a ->
  Params a
group :: forall a. Text -> ParamGroup a -> Params a
group Text
prefix (ParamGroup Text -> Parser a
parser) = forall a. Parser a -> Params a
Params (Text -> Parser a
parser Text
prefix)

-- ** ParamGroup

-- |
-- Lift a param parser into parameter group.
member ::
  -- | Long name of the parameter
  Text ->
  Param a ->
  ParamGroup a
member :: forall a. Text -> Param a -> ParamGroup a
member Text
name (Param Maybe Char -> Text -> Parser a
parser) = forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\Text
prefix -> Maybe Char -> Text -> Parser a
parser forall a. Maybe a
Nothing (Text -> Text -> Text
prefixIfMakesSense Text
prefix Text
name)) where

-- |
-- Unite a group by a shared prefix.
subgroup ::
  -- | Long name prefix
  Text ->
  ParamGroup a ->
  ParamGroup a
subgroup :: forall a. Text -> ParamGroup a -> ParamGroup a
subgroup Text
prefix (ParamGroup Text -> Parser a
parser) = forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\Text
higherPrefix -> Text -> Parser a
parser (Text -> Text -> Text
prefixIfMakesSense Text
higherPrefix Text
prefix))

-- ** Param

-- |
-- Create a single parameter parser from a value parser and meta information.
value ::
  -- | Description. Can be empty
  Text ->
  -- | Default value
  Default a ->
  -- | Value format
  ValueFormat a ->
  Value a ->
  Param a
value :: forall a. Text -> Default a -> ValueFormat a -> Value a -> Param a
value Text
description Default a
def ValueFormat a
format (Value Parser a
attoparsecParser) =
  forall a. (Maybe Char -> Text -> Parser a) -> Param a
Param (\Maybe Char
shortName Text
longName -> forall a. ReadM a -> Mod OptionFields a -> Parser a
Optparse.option ReadM a
readM (Maybe Char -> Text -> Mod OptionFields a
mods Maybe Char
shortName Text
longName))
  where
    readM :: ReadM a
readM = forall a. (String -> Either String a) -> ReadM a
Optparse.eitherReader (forall a. Parser a -> Text -> Either String a
Attoparsec.parseOnly Parser a
attoparsecParser forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
Text.pack)
    mods :: Maybe Char -> Text -> Mod OptionFields a
mods Maybe Char
shortName Text
longName =
      forall (f :: * -> *) a. HasName f => Text -> Mod f a
longParamName Text
longName
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (f :: * -> *) a. HasName f => Char -> Mod f a
Optparse.short Maybe Char
shortName
        forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *). Text -> ValueFormat a -> Mod f a
paramHelp Text
description ValueFormat a
format
        forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasValue f => Default a -> Mod f a
defaultValue Default a
def

-- |
-- A parameter with no value. Fails if it's not present.
-- Thus it can be composed using Alternative.
flag ::
  -- | Description. Can be empty
  Text ->
  Param ()
flag :: Text -> Param ()
flag Text
description =
  forall a. (Maybe Char -> Text -> Parser a) -> Param a
Param
    ( \Maybe Char
shortName Text
longName ->
        forall a. a -> Mod FlagFields a -> Parser a
Optparse.flag'
          ()
          (forall (f :: * -> *) a. HasName f => Text -> Mod f a
longParamName Text
longName forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (f :: * -> *) a. HasName f => Char -> Mod f a
Optparse.short Maybe Char
shortName forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *). Text -> ValueFormat a -> Mod f a
paramHelp Text
description forall a. ValueFormat a
UnspecifiedFormat)
    )

-- ** Value

-- |
-- Lift an Attoparsec parser into value parser.
explicitlyParsed :: Attoparsec.Parser a -> Value a
explicitlyParsed :: forall a. Parser a -> Value a
explicitlyParsed = forall a. Parser a -> Value a
Value

-- |
-- Lift an implicit lenient Attoparsec parser into value parser.
implicitlyParsed :: Attoparsec.LenientParser a => Value a
implicitlyParsed :: forall a. LenientParser a => Value a
implicitlyParsed = forall a. Parser a -> Value a
Value forall a. LenientParser a => Parser a
Attoparsec.lenientParser

-- ** Default

-- |
-- Provide a default value with explicit textual representation.
explicitlyRepresented :: (a -> Text) -> a -> Default a
explicitlyRepresented :: forall a. (a -> Text) -> a -> Default a
explicitlyRepresented a -> Text
render a
value = forall a. a -> Text -> Default a
SpecifiedDefault a
value (a -> Text
render a
value)

-- |
-- Provide a default value with textual representation formed using the implicit Show instance.
showable :: Show a => a -> Default a
showable :: forall a. Show a => a -> Default a
showable a
a = forall a. a -> Text -> Default a
SpecifiedDefault a
a (String -> Text
Text.pack (forall a. Show a => a -> String
show a
a))

-- |
-- Provide no default value.
defaultless :: Default a
defaultless :: forall a. Default a
defaultless = forall a. Default a
UnspecifiedDefault

-- ** Value spec

-- |
-- Derive value format specification from the Enum instance and
-- explicit mapping of values to their representations.
formattedByEnum :: (Bounded a, Enum a) => (a -> Text) -> ValueFormat a
formattedByEnum :: forall a. (Bounded a, Enum a) => (a -> Text) -> ValueFormat a
formattedByEnum a -> Text
valueRepresentation = forall a. (Bounded a, Enum a) => (a -> Builder) -> ValueFormat a
formattedByEnumUsingBuilderMapping (Text -> Builder
TextBuilder.text forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Text
valueRepresentation)

-- |
-- Derive value format specification from the Enum and Show instances.
formattedByEnumUsingShow :: (Bounded a, Enum a, Show a) => ValueFormat a
formattedByEnumUsingShow :: forall a. (Bounded a, Enum a, Show a) => ValueFormat a
formattedByEnumUsingShow = forall a. (Bounded a, Enum a) => (a -> Builder) -> ValueFormat a
formattedByEnumUsingBuilderMapping (String -> Builder
TextBuilder.string forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show)

-- |
-- Derive value format specification from the Enum instance and
-- explicit mapping of values to their representations.
formattedByEnumUsingBuilderMapping :: (Bounded a, Enum a) => (a -> TextBuilder.Builder) -> ValueFormat a
formattedByEnumUsingBuilderMapping :: forall a. (Bounded a, Enum a) => (a -> Builder) -> ValueFormat a
formattedByEnumUsingBuilderMapping a -> Builder
valueRepresentation =
  let values :: [a]
values = forall a. Enum a => a -> a -> [a]
enumFromTo forall a. Bounded a => a
minBound (forall a. a -> a -> a
asTypeOf forall a. Bounded a => a
maxBound (forall {a}. ValueFormat a -> a
descriptionToA ValueFormat a
description))
      descriptionToA :: ValueFormat a -> a
descriptionToA = forall a. HasCallStack => a
undefined :: ValueFormat a -> a
      description :: ValueFormat a
description = forall a. [Builder] -> ValueFormat a
EnumValueFormat (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Builder
valueRepresentation [a]
values)
   in ValueFormat a
description

-- |
-- Avoid specifying the format.
unformatted :: ValueFormat a
unformatted :: forall a. ValueFormat a
unformatted = forall a. ValueFormat a
UnspecifiedFormat

-- ** Rendering building

buildValueFormat :: ValueFormat a -> TextBuilder.Builder
buildValueFormat :: forall a. ValueFormat a -> Builder
buildValueFormat = \case
  EnumValueFormat [Builder]
values -> Builder
"(" forall a. Semigroup a => a -> a -> a
<> forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TextBuilder.intercalate Builder
", " [Builder]
values forall a. Semigroup a => a -> a -> a
<> Builder
")"
  ValueFormat a
UnspecifiedFormat -> forall a. Monoid a => a
mempty

buildHelp :: Text -> ValueFormat a -> TextBuilder.Builder
buildHelp :: forall a. Text -> ValueFormat a -> Builder
buildHelp Text
description ValueFormat a
valueFormat =
  forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TextBuilder.intercalate
    (Char -> Builder
TextBuilder.char Char
' ')
    (Builder -> [Builder]
notNull (Text -> Builder
TextBuilder.text Text
description) forall a. Semigroup a => a -> a -> a
<> Builder -> [Builder]
notNull (forall a. ValueFormat a -> Builder
buildValueFormat ValueFormat a
valueFormat))
  where
    notNull :: TextBuilder.Builder -> [TextBuilder.Builder]
    notNull :: Builder -> [Builder]
notNull = forall (m :: * -> *) a. Alternative m => (a -> Bool) -> a -> m a
validate (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> Bool
TextBuilder.null)

-- ** Rendering

renderIfNotEmpty :: TextBuilder.Builder -> Maybe Text
renderIfNotEmpty :: Builder -> Maybe Text
renderIfNotEmpty = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> Text
TextBuilder.run forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. Alternative m => (a -> Bool) -> a -> m a
validate (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> Bool
TextBuilder.null)

prefixIfMakesSense :: Text -> Text -> Text
prefixIfMakesSense :: Text -> Text -> Text
prefixIfMakesSense Text
prefix Text
text =
  if Text -> Bool
Text.null Text
prefix
    then Text
text
    else Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
text

-- ** Mods

paramHelp :: Text -> ValueFormat a -> Optparse.Mod f a
paramHelp :: forall a (f :: * -> *). Text -> ValueFormat a -> Mod f a
paramHelp Text
description ValueFormat a
format =
  forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (f :: * -> *) a. String -> Mod f a
Optparse.help forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
Text.unpack) (Builder -> Maybe Text
renderIfNotEmpty (forall a. Text -> ValueFormat a -> Builder
buildHelp Text
description ValueFormat a
format))

defaultValue :: Optparse.HasValue f => Default a -> Optparse.Mod f a
defaultValue :: forall (f :: * -> *) a. HasValue f => Default a -> Mod f a
defaultValue = \case
  SpecifiedDefault a
a Text
text -> forall (f :: * -> *) a. HasValue f => a -> Mod f a
Optparse.value a
a forall a. Semigroup a => a -> a -> a
<> forall a (f :: * -> *). (a -> String) -> Mod f a
Optparse.showDefaultWith (forall a b. a -> b -> a
const (Text -> String
Text.unpack Text
text))
  Default a
UnspecifiedDefault -> forall a. Monoid a => a
mempty

longParamName :: Optparse.HasName f => Text -> Optparse.Mod f a
longParamName :: forall (f :: * -> *) a. HasName f => Text -> Mod f a
longParamName Text
name =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (forall (f :: * -> *) a. HasName f => String -> Mod f a
Optparse.long forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
Text.unpack) (forall (m :: * -> *) a. Alternative m => (a -> Bool) -> a -> m a
validate (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Bool
Text.null) Text
name)