{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PartialTypeSignatures #-}

-- | Common parsers for options
--
--    - 'option' specifies a named value on the command line
--    - 'flag' specifies a value derived from the presence of the flag
--    - 'named' specifies a value derived from the name of a flag
--    - 'switch' specifies a flag with a boolean value
--    - 'argument' specifies a value not delimited by an option name, the first string value is parsed
--    - 'positional' specifies an argument which is expected to be at a specific place in the list of arguments
module Data.Registry.Options.Parsers where

import Data.Dynamic
import Data.Either
import Data.Registry
import Data.Registry.Options.OptionDescription
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.Parser
import GHC.TypeLits
import Protolude

-- | Create an option:
--     - with a short/long name
--     - a metavar
--     - no active/default values
--
--   The OptionDescriptionUpdates list can be used to override values or provide a help
option :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _
option :: OptionDescriptionUpdates
-> Registry
     '[FieldConfiguration, DefaultValue s a, ActiveValue s a, Decoder a]
     '[Parser s a, DefaultValue s a, ActiveValue s a, OptionDescription]
option OptionDescriptionUpdates
os = do
  let fieldType :: Text
fieldType = forall {k} (a :: k). Typeable a => Text
showType @a
  forall a. Typeable a => a -> Typed a
fun (\FieldConfiguration
fieldOptions -> 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 @s @a FieldConfiguration
fieldOptions Positional
NonPositional Text
fieldType OptionDescriptionUpdates
os)
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
Registry
  '[] '[DefaultValue s a, ActiveValue s a, OptionDescription]
setNoDefaultValues @s @a

-- | Create a parser for a list of values
options :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _
options :: OptionDescriptionUpdates
-> Registry
     '[Parser s a, FieldConfiguration, DefaultValue s a,
       ActiveValue s a, Decoder a]
     '[Parser s [a], Parser s a, DefaultValue s a, ActiveValue s a,
       OptionDescription]
options OptionDescriptionUpdates
os = forall a. Typeable a => a -> Typed a
fun (forall (s :: Symbol) a. Parser s a -> Parser s [a]
listParser @s @a) forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a, Show a) =>
OptionDescriptionUpdates
-> Registry
     '[FieldConfiguration, DefaultValue s a, ActiveValue s a, Decoder a]
     '[Parser s a, DefaultValue s a, ActiveValue s a, OptionDescription]
option @s @a OptionDescriptionUpdates
os

-- | Create a parser for an optional value
optionMaybe :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _
optionMaybe :: OptionDescriptionUpdates
-> Registry
     '[Parser s a, FieldConfiguration, DefaultValue s a,
       ActiveValue s a, Decoder a]
     '[Parser s (Maybe a), Parser s a, DefaultValue s a,
       ActiveValue s a, OptionDescription]
optionMaybe OptionDescriptionUpdates
os = forall a. Typeable a => a -> Typed a
fun (forall (s :: Symbol) a. Parser s a -> Parser s (Maybe a)
maybeParser @s @a) forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a, Show a) =>
OptionDescriptionUpdates
-> Registry
     '[FieldConfiguration, DefaultValue s a, ActiveValue s a, Decoder a]
     '[Parser s a, DefaultValue s a, ActiveValue s a, OptionDescription]
option @s @a OptionDescriptionUpdates
os

-- | Create a flag:
--     - with a short/long name
--     - a metavar
--     - an active value
--     - an optional default value
--
--   The OptionDescriptionUpdates list can be used to override values or provide a help
flag :: forall s a. (KnownSymbol s, Typeable a, Show a) => a -> Maybe a -> OptionDescriptionUpdates -> Registry _ _
flag :: a
-> Maybe a
-> OptionDescriptionUpdates
-> Registry
     '[FieldConfiguration, DefaultValue s a, ActiveValue s a, Decoder a]
     '[Parser s a, DefaultValue s a, ActiveValue s a]
flag a
activeValue Maybe a
defaultValue OptionDescriptionUpdates
os = do
  let fieldType :: Text
fieldType = forall {k} (a :: k). Typeable a => Text
showType @a
  forall a. Typeable a => a -> Typed a
fun (\FieldConfiguration
fieldOptions -> 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 @s @a FieldConfiguration
fieldOptions Positional
NonPositional Text
fieldType OptionDescriptionUpdates
os)
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
Typed (DefaultValue s a)
noDefaultValue (forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
a -> Typed (DefaultValue s a)
setDefaultValue @s @a) Maybe a
defaultValue
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
a -> Typed (ActiveValue s a)
setActiveValue @s @a a
activeValue

-- | Create a flag where the name of the flag can be decoded as a value:
--   The OptionDescriptionUpdates list can be used to override values or provide a help
named :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _
named :: OptionDescriptionUpdates
-> Registry
     '[Decoder a, DefaultValue s a]
     '[Parser s a, DefaultValue s a, ActiveValue s a, OptionDescription]
named OptionDescriptionUpdates
os = do
  let fieldType :: Text
fieldType = forall {k} (a :: k). Typeable a => Text
showType @a
  let p :: Decoder a -> DefaultValue s a -> Parser s a
p = \(Decoder a
decoder :: Decoder a) (DefaultValue s a
defaultValue :: DefaultValue s a) -> forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser @s @a (OptionDescription -> Help
fromCliOption forall a b. (a -> b) -> a -> b
$ OptionDescriptionUpdates -> OptionDescription
makeOptionDescription OptionDescriptionUpdates
os) forall a b. (a -> b) -> a -> b
$ \Lexemes
ls -> do
        case forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ (\Text
n -> (Text
n,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Decoder a -> Text -> Either Text a
decode Decoder a
decoder Text
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lexemes -> [Text]
getFlagNames Lexemes
ls of
          ([Text]
_, (Text
f, a
a) : [(Text, a)]
_) -> forall a b. b -> Either a b
Right (a
a, Text -> Lexemes -> Lexemes
popFlag Text
f Lexemes
ls)
          ([Text], [(Text, a)])
_ -> 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, Lexemes
ls)
            Maybe a
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Flag not found for data type `" forall a. Semigroup a => a -> a -> a
<> Text
fieldType forall a. Semigroup a => a -> a -> a
<> Text
"`"
  forall a. Typeable a => a -> Typed a
fun Decoder a -> DefaultValue s a -> Parser s a
p
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
Registry
  '[] '[DefaultValue s a, ActiveValue s a, OptionDescription]
setNoDefaultValues @s @a

-- | Create a switch:
--     - with a short/long name
--     - a metavar
--     - an active value: True
--     - an default value: False
--
--   The OptionDescriptionUpdates list can be used to override values or provide a help
switch :: forall s. (KnownSymbol s) => OptionDescriptionUpdates -> Registry _ _
switch :: OptionDescriptionUpdates
-> Registry
     '[FieldConfiguration, DefaultValue s Bool, ActiveValue s Bool,
       Decoder Bool]
     '[Parser s Bool, DefaultValue s Bool, ActiveValue s Bool]
switch OptionDescriptionUpdates
os = do
  let fieldType :: Text
fieldType = forall {k} (a :: k). Typeable a => Text
showType @Bool
  forall a. Typeable a => a -> Typed a
fun (\FieldConfiguration
fieldOptions -> 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 @s @Bool FieldConfiguration
fieldOptions Positional
NonPositional Text
fieldType OptionDescriptionUpdates
os)
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
a -> Typed (DefaultValue s a)
setDefaultValue @s Bool
False
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
a -> Typed (ActiveValue s a)
setActiveValue @s Bool
True

-- | Create an argument:
--     - with no short/long names
--     - a metavar
--     - no active/default values
--
--   The OptionDescriptionUpdates list can be used to override values or provide a help
--
--   When the argument is read, its value is removed from the list of lexed values
argument :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _
argument :: OptionDescriptionUpdates
-> Registry
     '[FieldConfiguration, DefaultValue s a, ActiveValue s a, Decoder a]
     '[Parser s a, DefaultValue s a, ActiveValue s a, OptionDescription]
argument OptionDescriptionUpdates
os = do
  let fieldType :: Text
fieldType = forall {k} (a :: k). Typeable a => Text
showType @a
  forall a. Typeable a => a -> Typed a
fun (\FieldConfiguration
fieldOptions -> 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 @s @a FieldConfiguration
fieldOptions Positional
Positional Text
fieldType OptionDescriptionUpdates
os)
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
Registry
  '[] '[DefaultValue s a, ActiveValue s a, OptionDescription]
setNoDefaultValues @s @a

-- | Create a parser for a list of arguments
arguments :: forall s a. (KnownSymbol s, Typeable a, Show a) => OptionDescriptionUpdates -> Registry _ _
arguments :: OptionDescriptionUpdates
-> Registry
     '[Parser s a, FieldConfiguration, DefaultValue s a,
       ActiveValue s a, Decoder a]
     '[Parser s [a], Parser s a, DefaultValue s a, ActiveValue s a,
       OptionDescription]
arguments OptionDescriptionUpdates
os = forall a. Typeable a => a -> Typed a
fun (forall (s :: Symbol) a. Parser s a -> Parser s [a]
listParser @s @a) forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a, Show a) =>
OptionDescriptionUpdates
-> Registry
     '[FieldConfiguration, DefaultValue s a, ActiveValue s a, Decoder a]
     '[Parser s a, DefaultValue s a, ActiveValue s a, OptionDescription]
argument @s @a OptionDescriptionUpdates
os

-- | Create a positional argument, to parse the nth value (starting from 0):
--     - with no short/long names
--     - a metavar
--     - no active/default values
--
--   The OptionDescriptionUpdates list can be used to override values or provide a help
--
--   When the argument is read, its value is left in the list of lexed values
positional :: forall s a. (KnownSymbol s, Typeable a, Show a) => Int -> OptionDescriptionUpdates -> Registry _ _
positional :: Int
-> OptionDescriptionUpdates
-> Registry
     '[FieldConfiguration, Decoder a]
     '[Parser s a, DefaultValue s a, ActiveValue s a, OptionDescription]
positional Int
n OptionDescriptionUpdates
os = do
  let p :: FieldConfiguration -> Decoder a -> Parser s a
p FieldConfiguration
fieldOptions = \Decoder a
d -> do
        let o :: OptionDescription
o = OptionDescriptionUpdates -> OptionDescription
makeOptionDescription forall a b. (a -> b) -> a -> b
$ Text -> OptionDescriptionUpdate
metavar (FieldConfiguration -> Text -> Text
makeMetavar FieldConfiguration
fieldOptions (forall {k} (a :: k). Typeable a => Text
showType @a)) forall a. a -> [a] -> [a]
: OptionDescriptionUpdates
os
        forall (s :: Symbol) a.
Help -> (Lexemes -> Either Text (a, Lexemes)) -> Parser s a
Parser @s @a (OptionDescription -> Help
fromCliOption OptionDescription
o) forall a b. (a -> b) -> a -> b
$ \Lexemes
ls -> do
          -- take element at position n and make sure to keep all the other
          -- arguments intact because we need their position to parse them
          case forall a. [a] -> Maybe a
headMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
n forall a b. (a -> b) -> a -> b
$ Lexemes -> [Text]
getArguments Lexemes
ls of
            Maybe Text
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"No argument to parse at position " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n
            Just Text
arg ->
              case forall a. Decoder a -> Text -> Either Text a
decode Decoder a
d Text
arg of
                Left Text
e -> forall a b. a -> Either a b
Left Text
e
                Right a
v -> forall a b. b -> Either a b
Right (a
v, Lexemes
ls)

  forall a. Typeable a => a -> Typed a
fun FieldConfiguration -> Decoder a -> Parser s a
p
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
Registry
  '[] '[DefaultValue s a, ActiveValue s a, OptionDescription]
setNoDefaultValues @s @a

-- | Set an active value for a given field name and field type
setActiveValue :: forall s a. (KnownSymbol s, Typeable a) => a -> Typed (ActiveValue s a)
setActiveValue :: forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
a -> Typed (ActiveValue s a)
setActiveValue = forall a. Typeable a => a -> Typed a
fun forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Symbol) a.
(Typeable a, KnownSymbol s) =>
a -> ActiveValue s a
createActiveValue @s @a

-- | Set a default value for a given field name and field type
setDefaultValue :: forall s a. (KnownSymbol s, Typeable a) => a -> Typed (DefaultValue s a)
setDefaultValue :: forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
a -> Typed (DefaultValue s a)
setDefaultValue = forall a. Typeable a => a -> Typed a
fun forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Symbol) a.
(Typeable a, KnownSymbol s) =>
a -> DefaultValue s a
createDefaultValue @s @a

-- | Allow to specify that a given field name and type has some default/active values
setDefaultValues :: forall s a. (KnownSymbol s, Typeable a) => Maybe a -> Maybe a -> Registry _ _
setDefaultValues :: Maybe a
-> Maybe a -> Registry '[] '[DefaultValue s a, ActiveValue s a]
setDefaultValues Maybe a
defaultValue Maybe a
activeValue =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
Typed (DefaultValue s a)
noDefaultValue @s) (forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
a -> Typed (DefaultValue s a)
setDefaultValue @s) Maybe a
defaultValue
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
Typed (ActiveValue s a)
noActiveValue @s) (forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
a -> Typed (ActiveValue s a)
setActiveValue @s) Maybe a
activeValue

-- | Allow to specify that a given field name and type has no default/active values
setNoDefaultValues :: forall s a. (KnownSymbol s, Typeable a) => Registry _ _
setNoDefaultValues :: Registry
  '[] '[DefaultValue s a, ActiveValue s a, OptionDescription]
setNoDefaultValues =
  forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
Typed (DefaultValue s a)
noDefaultValue @s @a
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall (s :: Symbol) a.
(KnownSymbol s, Typeable a) =>
Typed (ActiveValue s a)
noActiveValue @s @a
    forall a b c. AddRegistryUncheckedLike a b c => a -> b -> c
<+ forall a. (Typeable a, Show a) => a -> Typed a
val (forall a. Monoid a => a
mempty :: OptionDescription)

-- * Template Haskell

-- | This function is used by the TH module to parse a command name at the beginning
--   of a list of arguments
commandNameParser :: Text -> Parser Command ()
commandNameParser :: Text -> Parser Command ()
commandNameParser Text
cn = 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 ->
  case Lexemes -> [Text]
lexedArguments Lexemes
ls of
    [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"no arguments found, expected command: " forall a. Semigroup a => a -> a -> a
<> Text
cn
    Text
n : [Text]
_ ->
      if Text
n forall a. Eq a => a -> a -> Bool
== Text
cn
        then forall a b. b -> Either a b
Right ((), Lexemes -> Lexemes
popArgumentValue Lexemes
ls)
        else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected command: " forall a. Semigroup a => a -> a -> a
<> Text
cn forall a. Semigroup a => a -> a -> a
<> Text
", found: " forall a. Semigroup a => a -> a -> a
<> Text
n