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 :: 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
params :: Text -> 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)
param :: Maybe Char -> Text -> 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)
group :: Text -> 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)
member :: Text -> 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
subgroup :: Text -> 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))
value :: Text -> Default a -> ValueFormat a -> 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
flag :: Text -> 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))
explicitlyParsed :: Attoparsec.Parser a -> Value a
explicitlyParsed :: Parser a -> Value a
explicitlyParsed = Parser a -> Value a
forall a. Parser a -> Value a
Value
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
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)
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))
defaultless :: Default a
defaultless :: Default a
defaultless = Default a
forall a. Default a
UnspecifiedDefault
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)
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)
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
unformatted :: ValueFormat a
unformatted :: ValueFormat a
unformatted = ValueFormat a
forall a. ValueFormat a
UnspecifiedFormat
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)
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
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)