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