{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PartialTypeSignatures #-}
module Data.Registry.Options.Parser where
import Data.Coerce
import Data.Dynamic
import Data.Registry (ApplyVariadic, Typed, funTo)
import Data.Registry.Options.Decoder
import Data.Registry.Options.DefaultValues
import Data.Registry.Options.FieldConfiguration
import Data.Registry.Options.Help
import Data.Registry.Options.Lexemes
import Data.Registry.Options.OptionDescription
import Data.Registry.Options.Text
import Data.Text qualified as T
import GHC.TypeLits
import Protolude
import Type.Reflection
data Parser (s :: Symbol) a = Parser
{ forall (s :: Symbol) a. Parser s a -> Help
parserHelp :: Help,
forall (s :: Symbol) a.
Parser s a -> Lexemes -> Either Text (a, Lexemes)
parseLexed :: Lexemes -> Either Text (a, Lexemes)
}
deriving (forall a b. a -> Parser s b -> Parser s a
forall a b. (a -> b) -> Parser s a -> Parser s b
forall (s :: Symbol) a b. a -> Parser s b -> Parser s a
forall (s :: Symbol) a b. (a -> b) -> Parser s a -> Parser s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Parser s b -> Parser s a
$c<$ :: forall (s :: Symbol) a b. a -> Parser s b -> Parser s a
fmap :: forall a b. (a -> b) -> Parser s a -> Parser s b
$cfmap :: forall (s :: Symbol) a b. (a -> b) -> Parser s a -> Parser s b
Functor)
instance Applicative (Parser s) where
pure :: forall a. a -> Parser s a
pure a
a = forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser Help
noHelp (\Lexemes
ls -> forall a b. b -> Either a b
Right (a
a, Lexemes
ls))
Parser Help
h1 Lexemes -> Either Text (a -> b, Lexemes)
f <*> :: forall a b. Parser s (a -> b) -> Parser s a -> Parser s b
<*> Parser Help
h2 Lexemes -> Either Text (a, Lexemes)
fa = forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser (Help
h1 forall a. Semigroup a => a -> a -> a
<> Help
h2) forall a b. (a -> b) -> a -> b
$ \Lexemes
ls -> do
(a -> b
l, Lexemes
ls1) <- Lexemes -> Either Text (a -> b, Lexemes)
f Lexemes
ls
(a
a, Lexemes
ls2) <- Lexemes -> Either Text (a, Lexemes)
fa Lexemes
ls1
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
l a
a, Lexemes
ls2)
instance Alternative (Parser s) where
empty :: forall a. Parser s a
empty = forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser Help
noHelp (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"nothing to parse")
Parser Help
h1 Lexemes -> Either Text (a, Lexemes)
p1 <|> :: forall a. Parser s a -> Parser s a -> Parser s a
<|> Parser Help
h2 Lexemes -> Either Text (a, Lexemes)
p2 = forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser (Help
h1 Help -> Help -> Help
`alt` Help
h2) forall a b. (a -> b) -> a -> b
$ \Lexemes
lexemes ->
case Lexemes -> Either Text (a, Lexemes)
p1 Lexemes
lexemes of
Right (a, Lexemes)
a -> forall a b. b -> Either a b
Right (a, Lexemes)
a
Either Text (a, Lexemes)
_ -> Lexemes -> Either Text (a, Lexemes)
p2 Lexemes
lexemes
data Positional = Positional | NonPositional deriving (Positional -> Positional -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Positional -> Positional -> Bool
$c/= :: Positional -> Positional -> Bool
== :: Positional -> Positional -> Bool
$c== :: Positional -> Positional -> Bool
Eq, Int -> Positional -> ShowS
[Positional] -> ShowS
Positional -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Positional] -> ShowS
$cshowList :: [Positional] -> ShowS
show :: Positional -> String
$cshow :: Positional -> String
showsPrec :: Int -> Positional -> ShowS
$cshowsPrec :: Int -> Positional -> ShowS
Show)
unitParser :: Parser s ()
unitParser :: forall (s :: Symbol). Parser s ()
unitParser = forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser Help
noHelp forall a b. (a -> b) -> a -> b
$ \Lexemes
ls -> forall a b. b -> Either a b
Right ((), Lexemes
ls)
addParserHelp :: Help -> Parser s a -> Parser s a
addParserHelp :: forall (s :: Symbol) a. Help -> Parser s a -> Parser s a
addParserHelp Help
h Parser s a
p = forall (s :: Symbol) a. Help -> Parser s a -> Parser s a
setParserHelp (forall (s :: Symbol) a. Parser s a -> Help
parserHelp Parser s a
p forall a. Semigroup a => a -> a -> a
<> Help
h) Parser s a
p
setParserHelp :: Help -> Parser s a -> Parser s a
setParserHelp :: forall (s :: Symbol) a. Help -> Parser s a -> Parser s a
setParserHelp Help
h Parser s a
p = Parser s a
p {parserHelp :: Help
parserHelp = Help
h}
getOptionNames :: Parser s a -> [Text]
getOptionNames :: forall (s :: Symbol) a. Parser s a -> [Text]
getOptionNames Parser s a
p =
Help -> [Text]
go (forall (s :: Symbol) a. Parser s a -> Help
parserHelp Parser s a
p)
where
go :: Help -> [Text]
go (Help Maybe Text
_ Maybe Text
_ Maybe Text
_ Maybe Text
_ [OptionDescription]
os [Help]
cs Bool
_) =
forall a. [Maybe a] -> [a]
catMaybes (OptionDescription -> Maybe Text
_name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OptionDescription]
os) forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (OptionDescription -> [Text]
_aliases forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OptionDescription]
os) forall a. Semigroup a => a -> a -> a
<>
(Help -> [Text]
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Help]
cs)
type Command = "Command"
coerceParser :: Parser s a -> Parser t a
coerceParser :: forall (s :: Symbol) a (t :: Symbol). Parser s a -> Parser t a
coerceParser = coerce :: forall a b. Coercible a b => a -> b
coerce
parseArgs :: Parser s a -> [Text] -> Either Text a
parseArgs :: forall (s :: Symbol) a. Parser s a -> [Text] -> Either Text a
parseArgs Parser s a
p = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Symbol) a.
Parser s a -> Lexemes -> Either Text (a, Lexemes)
parseLexed Parser s a
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Lexemes
lexArgs
parse :: Parser s a -> Text -> Either Text a
parse :: forall (s :: Symbol) a. Parser s a -> Text -> Either Text a
parse Parser s a
p = forall (s :: Symbol) a. Parser s a -> [Text] -> Either Text a
parseArgs Parser s a
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
" "
parserOf :: forall a b. (ApplyVariadic (Parser Command) a b, Typeable a, Typeable b) => a -> Typed b
parserOf :: forall a b.
(ApplyVariadic (Parser Command) a b, Typeable a, Typeable b) =>
a -> Typed b
parserOf = forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo @(Parser Command)
maybeParser :: Parser s a -> Parser s (Maybe a)
maybeParser :: forall (s :: Symbol) a. Parser s a -> Parser s (Maybe a)
maybeParser (Parser Help
h Lexemes -> Either Text (a, Lexemes)
p) = forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser Help
h forall a b. (a -> b) -> a -> b
$ \Lexemes
lexemes ->
case Lexemes -> Either Text (a, Lexemes)
p Lexemes
lexemes of
Right (a
a, Lexemes
ls) -> forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just a
a, Lexemes
ls)
Left Text
_ -> forall a b. b -> Either a b
Right (forall a. Maybe a
Nothing, Lexemes
lexemes)
listParser :: Parser s a -> Parser s [a]
listParser :: forall (s :: Symbol) a. Parser s a -> Parser s [a]
listParser parser :: Parser s a
parser@(Parser Help
h Lexemes -> Either Text (a, Lexemes)
p) = forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser Help
h forall a b. (a -> b) -> a -> b
$ \Lexemes
lexemes ->
case Lexemes -> Either Text (a, Lexemes)
p Lexemes
lexemes of
Right (a
a, Lexemes
ls) ->
case forall (s :: Symbol) a.
Parser s a -> Lexemes -> Either Text (a, Lexemes)
parseLexed (forall (s :: Symbol) a. Parser s a -> Parser s [a]
listParser Parser s a
parser) Lexemes
ls of
Right ([a]
as, Lexemes
ls') -> forall a b. b -> Either a b
Right (a
a forall a. a -> [a] -> [a]
: [a]
as, Lexemes
ls')
Left Text
e -> forall a b. a -> Either a b
Left Text
e
Left Text
_ -> forall a b. b -> Either a b
Right ([], Lexemes
lexemes)
list1Parser :: Parser s a -> Parser s [a]
list1Parser :: forall (s :: Symbol) a. Parser s a -> Parser s [a]
list1Parser = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Symbol) a. Parser s a -> Parser s (NonEmpty a)
nonEmptyParser
nonEmptyParser :: Parser s a -> Parser s (NonEmpty a)
nonEmptyParser :: forall (s :: Symbol) a. Parser s a -> Parser s (NonEmpty a)
nonEmptyParser parser :: Parser s a
parser@(Parser Help
h Lexemes -> Either Text (a, Lexemes)
p) = forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser Help
h forall a b. (a -> b) -> a -> b
$ \Lexemes
lexemes ->
case Lexemes -> Either Text (a, Lexemes)
p Lexemes
lexemes of
Right (a
a, Lexemes
ls) ->
case forall (s :: Symbol) a.
Parser s a -> Lexemes -> Either Text (a, Lexemes)
parseLexed (forall (s :: Symbol) a. Parser s a -> Parser s [a]
listParser Parser s a
parser) Lexemes
ls of
Right ([a]
as, Lexemes
ls') -> forall a b. b -> Either a b
Right (a
a forall a. a -> [a] -> NonEmpty a
:| [a]
as, Lexemes
ls')
Left Text
e -> forall a b. a -> Either a b
Left Text
e
Left Text
e -> forall a b. a -> Either a b
Left Text
e
parseField :: forall s a. (KnownSymbol s, Typeable a, Show a) => FieldConfiguration -> Positional -> Text -> OptionDescriptionUpdates -> DefaultValue s a -> ActiveValue s a -> Decoder a -> Parser s a
parseField :: forall (s :: Symbol) a.
(KnownSymbol s, Typeable a, Show a) =>
FieldConfiguration
-> Positional
-> Text
-> OptionDescriptionUpdates
-> DefaultValue s a
-> ActiveValue s a
-> Decoder a
-> Parser s a
parseField FieldConfiguration
fieldOptions Positional
pos Text
fieldType OptionDescriptionUpdates
os = do
let fieldName :: Maybe Text
fieldName = if Positional
pos forall a. Eq a => a -> a -> Bool
== Positional
Positional then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol). KnownSymbol s => Text
getSymbol @s
let shortName :: OptionDescription -> OptionDescription
shortName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
identity (\Text
f -> Char -> OptionDescription -> OptionDescription
short forall a b. (a -> b) -> a -> b
$ FieldConfiguration -> Text -> Char
makeShortName FieldConfiguration
fieldOptions Text
f) Maybe Text
fieldName
let longName :: OptionDescription -> OptionDescription
longName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
identity (Text -> OptionDescription -> OptionDescription
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldConfiguration -> Text -> Text
makeLongName FieldConfiguration
fieldOptions) Maybe Text
fieldName
forall (s :: Symbol) a.
(KnownSymbol s, Typeable a, Show a) =>
OptionDescriptionUpdates
-> DefaultValue s a -> ActiveValue s a -> Decoder a -> Parser s a
parseWith ([OptionDescription -> OptionDescription
shortName, OptionDescription -> OptionDescription
longName, Text -> OptionDescription -> OptionDescription
metavar (FieldConfiguration -> Text -> Text
makeMetavar FieldConfiguration
fieldOptions Text
fieldType)] forall a. Semigroup a => a -> a -> a
<> OptionDescriptionUpdates
os)
parseWith :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> DefaultValue s a -> ActiveValue s a -> Decoder a -> Parser s a
parseWith :: forall (s :: Symbol) a.
(KnownSymbol s, Typeable a, Show a) =>
OptionDescriptionUpdates
-> DefaultValue s a -> ActiveValue s a -> Decoder a -> Parser s a
parseWith OptionDescriptionUpdates
os DefaultValue s a
defaultValue ActiveValue s a
activeValue Decoder a
d = do
forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser (OptionDescription -> Help
fromCliOption OptionDescription
cliOption) forall a b. (a -> b) -> a -> b
$ \Lexemes
ls ->
case OptionDescription -> [Text]
getNames OptionDescription
cliOption of
ns :: [Text]
ns@(Text
_:[Text]
_) ->
case [Text] -> Lexemes -> Maybe (Text, Maybe Text, Lexemes)
takeOptionValue [Text]
ns Lexemes
ls of
Maybe (Text, Maybe Text, Lexemes)
Nothing ->
(,Lexemes
ls) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text a
returnDefaultValue
Just (Text
_, Maybe Text
Nothing, Lexemes
ls') ->
(,Lexemes
ls') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text a
returnActiveValue
Just (Text
k, Just Text
v, Lexemes
ls') ->
case forall a (s :: Symbol).
(Typeable a, KnownSymbol s) =>
ActiveValue s a -> Maybe a
getActiveValue ActiveValue s a
activeValue of
Just a
active -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
active, Text -> Lexemes -> Lexemes
popFlag Text
k Lexemes
ls)
Maybe a
Nothing -> (,Lexemes
ls') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Decoder a -> Text -> Either Text a
decode Decoder a
d Text
v
[] ->
case Lexemes -> Maybe (Text, Lexemes)
takeArgumentValue Lexemes
ls of
Maybe (Text, Lexemes)
Nothing -> (,Lexemes
ls) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text a
returnDefaultValue
Just (Text
a, Lexemes
ls') -> (,Lexemes
ls') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Decoder a -> Text -> Either Text a
decode Decoder a
d Text
a
where
cliOption :: OptionDescription
cliOption = OptionDescriptionUpdates -> OptionDescription
makeOptionDescription OptionDescriptionUpdates
os
returnActiveValue :: Either Text a
returnActiveValue = case forall a (s :: Symbol).
(Typeable a, KnownSymbol s) =>
ActiveValue s a -> Maybe a
getActiveValue ActiveValue s a
activeValue of
Just a
def -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
Maybe a
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"missing active value for argument: " forall a. Semigroup a => a -> a -> a
<> OptionDescription -> Text
displayCliOptionName OptionDescription
cliOption
returnDefaultValue :: Either Text a
returnDefaultValue = case forall a (s :: Symbol).
(Typeable a, KnownSymbol s) =>
DefaultValue s a -> Maybe a
getDefaultValue DefaultValue s a
defaultValue of
Just a
def -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def
Maybe a
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"missing default value for argument: " forall a. Semigroup a => a -> a -> a
<> OptionDescription -> Text
displayCliOptionName OptionDescription
cliOption
takeOptionValue :: [Text] -> Lexemes -> Maybe (Text, Maybe Text, Lexemes)
takeOptionValue :: [Text] -> Lexemes -> Maybe (Text, Maybe Text, Lexemes)
takeOptionValue [Text]
names Lexemes
lexemes = do
forall a. [a] -> Maybe a
headMay forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (Text, Maybe Text, Lexemes)
takeValue (Text -> Text
camelCaseToHyphenated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
names)
where
takeValue :: Text -> Maybe (Text, Maybe Text, Lexemes)
takeValue :: Text -> Maybe (Text, Maybe Text, Lexemes)
takeValue Text
key =
case Text -> Lexemes -> Maybe (Maybe Text)
getValue Text
key Lexemes
lexemes of
Maybe (Maybe Text)
Nothing -> forall a. Maybe a
Nothing
Just Maybe Text
v -> forall a. a -> Maybe a
Just (Text
key, Maybe Text
v, Text -> Lexemes -> Lexemes
popOptionValue Text
key Lexemes
lexemes)
takeArgumentValue :: Lexemes -> Maybe (Text, Lexemes)
takeArgumentValue :: Lexemes -> Maybe (Text, Lexemes)
takeArgumentValue Lexemes
lexemes = do
case Lexemes -> [Text]
getArguments Lexemes
lexemes of
[] -> forall a. Maybe a
Nothing
(Text
a : [Text]
_) -> forall a. a -> Maybe a
Just (Text
a, Lexemes -> Lexemes
popArgumentValue Lexemes
lexemes)
getSymbol :: forall s. (KnownSymbol s) => Text
getSymbol :: forall (s :: Symbol). KnownSymbol s => Text
getSymbol = forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @s forall {k} (t :: k). Proxy t
Proxy
showType :: forall a. Typeable a => Text
showType :: forall {k} (a :: k). Typeable a => Text
showType = forall a b. (Show a, StringConv String b) => a -> b
show forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)