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 Optima.Prelude hiding (group)
import qualified Data.Text as Text
import qualified Data.Attoparsec.Text as Attoparsec
import qualified Options.Applicative as Optparse
import qualified Attoparsec.Data as Attoparsec
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 :: a -> ParamGroup a
pure a
x = (Text -> Parser a) -> ParamGroup a
forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\ Text
_ -> a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
  <*> :: ParamGroup (a -> b) -> ParamGroup a -> ParamGroup b
(<*>) (ParamGroup Text -> Parser (a -> b)
left) (ParamGroup Text -> Parser a
right) = (Text -> Parser b) -> ParamGroup b
forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\ Text
prefix -> Text -> Parser (a -> b)
left Text
prefix Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Parser a
right Text
prefix)
instance Alternative ParamGroup where
  empty :: ParamGroup a
empty = (Text -> Parser a) -> ParamGroup a
forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\ Text
_ -> Parser a
forall (f :: * -> *) a. Alternative f => f a
empty)
  <|> :: ParamGroup a -> ParamGroup a -> ParamGroup a
(<|>) (ParamGroup Text -> Parser a
left) (ParamGroup Text -> Parser a
right) = (Text -> Parser a) -> ParamGroup a
forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\ Text
prefix -> Text -> Parser a
left Text
prefix Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser a
right Text
prefix)
  many :: ParamGroup a -> ParamGroup [a]
many (ParamGroup Text -> Parser a
parser) = (Text -> Parser [a]) -> ParamGroup [a]
forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\ Text
prefix -> Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Text -> Parser a
parser Text
prefix))
  some :: ParamGroup a -> ParamGroup [a]
some (ParamGroup Text -> Parser a
parser) = (Text -> Parser [a]) -> ParamGroup [a]
forall a. (Text -> Parser a) -> ParamGroup a
ParamGroup (\ Text
prefix -> Parser a -> Parser [a]
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 :: Text {-^ Description of the application -} -> Params a -> IO a
params :: Text -> Params a -> IO a
params Text
description (Params Parser a
parser) =
  ParserInfo a -> IO a
forall a. ParserInfo a -> IO a
Optparse.execParser (Parser a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
Optparse.info (Parser (a -> a)
forall a. Parser (a -> a)
Optparse.helper Parser (a -> a) -> Parser a -> Parser a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
parser) InfoMod a
mods)
  where
    mods :: InfoMod a
mods = InfoMod a
forall a. InfoMod a
Optparse.fullDesc InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
Optparse.progDesc (Text -> String
Text.unpack Text
description)


-- ** Params
-------------------------

{-|
Lift a single parameter parser.
-}
param :: Maybe Char {-^ Single-char name -} -> Text {-^ Long name -} -> Param a -> Params a
param :: Maybe Char -> Text -> Param a -> Params a
param Maybe Char
shortName Text
longName (Param Maybe Char -> Text -> Parser a
parser) = Parser a -> Params a
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 :: Text {-^ Prefix for the long names of the parameters. If empty, then there'll be no prefixing -} -> ParamGroup a -> Params a
group :: Text -> ParamGroup a -> Params a
group Text
prefix (ParamGroup Text -> Parser a
parser) = Parser a -> Params a
forall a. Parser a -> Params a
Params (Text -> Parser a
parser Text
prefix)


-- ** ParamGroup
-------------------------

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

{-|
Unite a group by a shared prefix.
-}
subgroup :: Text {-^ Long name prefix -} -> ParamGroup a -> ParamGroup a
subgroup :: Text -> ParamGroup a -> ParamGroup a
subgroup Text
prefix (ParamGroup Text -> Parser a
parser) = (Text -> Parser a) -> ParamGroup a
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 :: Text {-^ Description. Can be empty -} -> Default a {-^ Default value -} -> ValueFormat a {-^ Value format -} -> Value a -> Param a
value :: Text -> Default a -> ValueFormat a -> Value a -> Param a
value Text
description Default a
def ValueFormat a
format (Value Parser a
attoparsecParser) =
  (Maybe Char -> Text -> Parser a) -> Param a
forall a. (Maybe Char -> Text -> Parser a) -> Param a
Param (\ Maybe Char
shortName Text
longName -> ReadM a -> Mod OptionFields a -> Parser a
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 = (String -> Either String a) -> ReadM a
forall a. (String -> Either String a) -> ReadM a
Optparse.eitherReader (Parser a -> Text -> Either String a
forall a. Parser a -> Text -> Either String a
Attoparsec.parseOnly Parser a
attoparsecParser (Text -> Either String a)
-> (String -> Text) -> String -> Either String a
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 =
      Text -> Mod OptionFields a
forall (f :: * -> *) a. HasName f => Text -> Mod f a
longParamName Text
longName Mod OptionFields a -> Mod OptionFields a -> Mod OptionFields a
forall a. Semigroup a => a -> a -> a
<>
      (Char -> Mod OptionFields a) -> Maybe Char -> Mod OptionFields a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> Mod OptionFields a
forall (f :: * -> *) a. HasName f => Char -> Mod f a
Optparse.short Maybe Char
shortName Mod OptionFields a -> Mod OptionFields a -> Mod OptionFields a
forall a. Semigroup a => a -> a -> a
<>
      Text -> ValueFormat a -> Mod OptionFields a
forall a (f :: * -> *). Text -> ValueFormat a -> Mod f a
paramHelp Text
description ValueFormat a
format Mod OptionFields a -> Mod OptionFields a -> Mod OptionFields a
forall a. Semigroup a => a -> a -> a
<>
      Default a -> Mod OptionFields 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 :: Text {-^ Description. Can be empty -} -> Param ()
flag :: Text -> Param ()
flag Text
description =
  (Maybe Char -> Text -> Parser ()) -> Param ()
forall a. (Maybe Char -> Text -> Parser a) -> Param a
Param (\ Maybe Char
shortName Text
longName ->
    () -> Mod FlagFields () -> Parser ()
forall a. a -> Mod FlagFields a -> Parser a
Optparse.flag' ()
      (Text -> Mod FlagFields ()
forall (f :: * -> *) a. HasName f => Text -> Mod f a
longParamName Text
longName Mod FlagFields () -> Mod FlagFields () -> Mod FlagFields ()
forall a. Semigroup a => a -> a -> a
<> (Char -> Mod FlagFields ()) -> Maybe Char -> Mod FlagFields ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> Mod FlagFields ()
forall (f :: * -> *) a. HasName f => Char -> Mod f a
Optparse.short Maybe Char
shortName Mod FlagFields () -> Mod FlagFields () -> Mod FlagFields ()
forall a. Semigroup a => a -> a -> a
<> Text -> ValueFormat () -> Mod FlagFields ()
forall a (f :: * -> *). Text -> ValueFormat a -> Mod f a
paramHelp Text
description ValueFormat ()
forall a. ValueFormat a
UnspecifiedFormat))


-- ** Value
-------------------------

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

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


-- ** Default
-------------------------

{-|
Provide a default value with explicit textual representation.
-}
explicitlyRepresented :: (a -> Text) -> a -> Default a
explicitlyRepresented :: (a -> Text) -> a -> Default a
explicitlyRepresented a -> Text
render a
value = a -> Text -> Default a
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 :: a -> Default a
showable a
a = a -> Text -> Default a
forall a. a -> Text -> Default a
SpecifiedDefault a
a (String -> Text
Text.pack (a -> String
forall a. Show a => a -> String
show a
a))

{-|
Provide no default value.
-}
defaultless :: Default a
defaultless :: Default a
defaultless = Default a
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 :: (a -> Text) -> ValueFormat a
formattedByEnum a -> Text
valueRepresentation = (a -> Builder) -> ValueFormat a
forall a. (Bounded a, Enum a) => (a -> Builder) -> ValueFormat a
formattedByEnumUsingBuilderMapping (Text -> Builder
TextBuilder.text (Text -> Builder) -> (a -> Text) -> a -> Builder
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 :: ValueFormat a
formattedByEnumUsingShow = (a -> Builder) -> ValueFormat a
forall a. (Bounded a, Enum a) => (a -> Builder) -> ValueFormat a
formattedByEnumUsingBuilderMapping (String -> Builder
TextBuilder.string (String -> Builder) -> (a -> String) -> a -> Builder
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> String
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 :: (a -> Builder) -> ValueFormat a
formattedByEnumUsingBuilderMapping a -> Builder
valueRepresentation = let
  values :: [a]
values = a -> a -> [a]
forall a. Enum a => a -> a -> [a]
enumFromTo a
forall a. Bounded a => a
minBound (a -> a -> a
forall a. a -> a -> a
asTypeOf a
forall a. Bounded a => a
maxBound (ValueFormat a -> a
forall a. ValueFormat a -> a
descriptionToA ValueFormat a
description))
  descriptionToA :: ValueFormat a -> a
descriptionToA = forall a. ValueFormat a -> a
forall a. HasCallStack => a
undefined :: ValueFormat a -> a
  description :: ValueFormat a
description = [Builder] -> ValueFormat a
forall a. [Builder] -> ValueFormat a
EnumValueFormat ((a -> Builder) -> [a] -> [Builder]
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 :: ValueFormat a
unformatted = ValueFormat a
forall a. ValueFormat a
UnspecifiedFormat


-- ** Rendering building
-------------------------

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

buildHelp :: Text -> ValueFormat a -> TextBuilder.Builder
buildHelp :: Text -> ValueFormat a -> Builder
buildHelp Text
description ValueFormat a
valueFormat =
  Builder -> [Builder] -> Builder
forall (foldable :: * -> *).
Foldable foldable =>
Builder -> foldable Builder -> Builder
TextBuilder.intercalate (Char -> Builder
TextBuilder.char Char
' ')
    (Builder -> [Builder]
notNull (Text -> Builder
TextBuilder.text Text
description) [Builder] -> [Builder] -> [Builder]
forall a. Semigroup a => a -> a -> a
<> Builder -> [Builder]
notNull (ValueFormat a -> Builder
forall a. ValueFormat a -> Builder
buildValueFormat ValueFormat a
valueFormat))
  where
    notNull :: TextBuilder.Builder -> [TextBuilder.Builder]
    notNull :: Builder -> [Builder]
notNull = (Builder -> Bool) -> Builder -> [Builder]
forall (m :: * -> *) a. Alternative m => (a -> Bool) -> a -> m a
validate (Bool -> Bool
not (Bool -> Bool) -> (Builder -> Bool) -> Builder -> Bool
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 = (Builder -> Text) -> Maybe Builder -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Builder -> Text
TextBuilder.run (Maybe Builder -> Maybe Text)
-> (Builder -> Maybe Builder) -> Builder -> Maybe Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Builder -> Bool) -> Builder -> Maybe Builder
forall (m :: * -> *) a. Alternative m => (a -> Bool) -> a -> m a
validate (Bool -> Bool
not (Bool -> Bool) -> (Builder -> Bool) -> Builder -> Bool
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text


-- ** Mods
-------------------------

paramHelp :: Text -> ValueFormat a -> Optparse.Mod f a
paramHelp :: Text -> ValueFormat a -> Mod f a
paramHelp Text
description ValueFormat a
format =
  (Text -> Mod f a) -> Maybe Text -> Mod f a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String -> Mod f a
forall (f :: * -> *) a. String -> Mod f a
Optparse.help (String -> Mod f a) -> (Text -> String) -> Text -> Mod f a
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 (Text -> ValueFormat a -> Builder
forall a. Text -> ValueFormat a -> Builder
buildHelp Text
description ValueFormat a
format))

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

longParamName :: Optparse.HasName f => Text -> Optparse.Mod f a
longParamName :: Text -> Mod f a
longParamName Text
name =
  Mod f a -> (Text -> Mod f a) -> Maybe Text -> Mod f a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Mod f a
forall a. Monoid a => a
mempty (String -> Mod f a
forall (f :: * -> *) a. HasName f => String -> Mod f a
Optparse.long (String -> Mod f a) -> (Text -> String) -> Text -> Mod f a
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) ((Text -> Bool) -> Text -> Maybe Text
forall (m :: * -> *) a. Alternative m => (a -> Bool) -> a -> m a
validate (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
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)