module Optima
(
params,
Params,
param,
group,
ParamGroup,
member,
subgroup,
Param,
value,
flag,
Value,
explicitlyParsed,
implicitlyParsed,
Default,
explicitlyRepresented,
showable,
defaultless,
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
newtype Params a = Params (Optparse.Parser a)
newtype Param a = Param (Maybe Char -> Text -> Optparse.Parser a)
newtype ParamGroup a = ParamGroup (Text -> Optparse.Parser a)
newtype Value a = Value (Attoparsec.Parser a)
data Default a = SpecifiedDefault a Text | UnspecifiedDefault
data ValueFormat a = EnumValueFormat [TextBuilder.Builder] | UnspecifiedFormat
deriving instance Functor Params
deriving instance Applicative Params
deriving instance Alternative Params
deriving instance Functor ParamGroup
instance Applicative ParamGroup where
pure x = ParamGroup (\ _ -> pure x)
(<*>) (ParamGroup left) (ParamGroup right) = ParamGroup (\ prefix -> left prefix <*> right prefix)
instance Alternative ParamGroup where
empty = ParamGroup (\ _ -> empty)
(<|>) (ParamGroup left) (ParamGroup right) = ParamGroup (\ prefix -> left prefix <|> right prefix)
many (ParamGroup parser) = ParamGroup (\ prefix -> many (parser prefix))
some (ParamGroup parser) = ParamGroup (\ prefix -> some (parser 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
params :: Text -> Params a -> IO a
params description (Params parser) =
Optparse.execParser (Optparse.info (Optparse.helper <*> parser) mods)
where
mods = Optparse.fullDesc <> Optparse.progDesc (Text.unpack description)
param :: Maybe Char -> Text -> Param a -> Params a
param shortName longName (Param parser) = Params (parser shortName longName)
group :: Text -> ParamGroup a -> Params a
group prefix (ParamGroup parser) = Params (parser prefix)
member :: Text -> Param a -> ParamGroup a
member name (Param parser) = ParamGroup (\ prefix -> parser Nothing (prefixIfMakesSense prefix name)) where
subgroup :: Text -> ParamGroup a -> ParamGroup a
subgroup prefix (ParamGroup parser) = ParamGroup (\ higherPrefix -> parser (prefixIfMakesSense higherPrefix prefix))
value :: Text -> Default a -> ValueFormat a -> Value a -> Param a
value description def format (Value attoparsecParser) =
Param (\ shortName longName -> Optparse.option readM (mods shortName longName))
where
readM = Optparse.eitherReader (Attoparsec.parseOnly attoparsecParser . Text.pack)
mods shortName longName =
longParamName longName <>
foldMap Optparse.short shortName <>
paramHelp description format <>
defaultValue def
flag :: Text -> Param ()
flag description =
Param (\ shortName longName ->
Optparse.flag' ()
(longParamName longName <> foldMap Optparse.short shortName <> paramHelp description UnspecifiedFormat))
explicitlyParsed :: Attoparsec.Parser a -> Value a
explicitlyParsed = Value
implicitlyParsed :: Attoparsec.LenientParser a => Value a
implicitlyParsed = Value Attoparsec.lenientParser
explicitlyRepresented :: (a -> Text) -> a -> Default a
explicitlyRepresented render value = SpecifiedDefault value (render value)
showable :: Show a => a -> Default a
showable a = SpecifiedDefault a (Text.pack (show a))
defaultless :: Default a
defaultless = UnspecifiedDefault
formattedByEnum :: (Bounded a, Enum a) => (a -> Text) -> ValueFormat a
formattedByEnum valueRepresentation = formattedByEnumUsingBuilderMapping (TextBuilder.text . valueRepresentation)
formattedByEnumUsingShow :: (Bounded a, Enum a, Show a) => ValueFormat a
formattedByEnumUsingShow = formattedByEnumUsingBuilderMapping (TextBuilder.string . show)
formattedByEnumUsingBuilderMapping :: (Bounded a, Enum a) => (a -> TextBuilder.Builder) -> ValueFormat a
formattedByEnumUsingBuilderMapping valueRepresentation = let
values = enumFromTo minBound (asTypeOf maxBound (descriptionToA description))
descriptionToA = undefined :: ValueFormat a -> a
description = EnumValueFormat (fmap valueRepresentation values)
in description
unformatted :: ValueFormat a
unformatted = UnspecifiedFormat
buildValueFormat :: ValueFormat a -> TextBuilder.Builder
buildValueFormat = \ case
EnumValueFormat values -> "(" <> TextBuilder.intercalate ", " values <> ")"
UnspecifiedFormat -> mempty
buildHelp :: Text -> ValueFormat a -> TextBuilder.Builder
buildHelp description valueFormat =
TextBuilder.intercalate (TextBuilder.char ' ')
(notNull (TextBuilder.text description) <> notNull (buildValueFormat valueFormat))
where
notNull :: TextBuilder.Builder -> [TextBuilder.Builder]
notNull = validate (not . TextBuilder.null)
renderIfNotEmpty :: TextBuilder.Builder -> Maybe Text
renderIfNotEmpty = fmap TextBuilder.run . validate (not . TextBuilder.null)
prefixIfMakesSense :: Text -> Text -> Text
prefixIfMakesSense prefix text = if Text.null prefix
then text
else prefix <> "-" <> text
paramHelp :: Text -> ValueFormat a -> Optparse.Mod f a
paramHelp description format =
foldMap (Optparse.help . Text.unpack) (renderIfNotEmpty (buildHelp description format))
defaultValue :: Optparse.HasValue f => Default a -> Optparse.Mod f a
defaultValue = \ case
SpecifiedDefault a text -> Optparse.value a <> Optparse.showDefaultWith (const (Text.unpack text))
UnspecifiedDefault -> mempty
longParamName :: Optparse.HasName f => Text -> Optparse.Mod f a
longParamName name =
maybe mempty (Optparse.long . Text.unpack) (validate (not . Text.null) name)