{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module YamlParse.Applicative.Parser where

import Control.Applicative
import Control.Monad
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as LB
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Data.Scientific
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Validity.Text ()
import Data.Vector (Vector)
import qualified Data.Yaml as Yaml
import Text.Read

-- | A parser that takes values of type 'i' as input and parses them into values of type 'o'
--
-- Note that there is no 'Monad' instance.
data Parser i o where
  -- | Return the input
  ParseAny :: Parser i i
  -- | Parse via an extra parsing function
  ParseExtra :: (o -> Yaml.Parser u) -> Parser i o -> Parser i u
  -- | Match an exact value
  ParseEq ::
    (Show o, Eq o) =>
    o ->
    -- | Shown version of the o in the previous argument
    Text ->
    Parser i o ->
    Parser i o
  -- | Parse 'null' only.
  ParseNull :: Parser Yaml.Value ()
  -- | Parse 'null' as 'Nothing' and the rest as 'Just'.
  ParseMaybe :: Parser Yaml.Value o -> Parser Yaml.Value (Maybe o)
  -- | Parse a boolean value
  ParseBool :: Maybe Text -> Parser Bool o -> Parser Yaml.Value o
  -- | Parse a String value
  ParseString ::
    -- | Extra info about what the string represents
    -- This info will be used during parsing for error messages and in the schema for documentation.
    Maybe Text ->
    Parser Text o ->
    Parser Yaml.Value o
  -- | Parse a numeric value
  ParseNumber ::
    -- | Extra info about what the number represents
    -- This info will be used during parsing for error messages and in the schema for documentation.
    Maybe Text ->
    Parser Scientific o ->
    Parser Yaml.Value o
  -- | Parse an array
  ParseArray ::
    -- | Extra info about what the array represents
    -- This info will be used during parsing for error messages and in the schema for documentation.
    Maybe Text ->
    Parser Yaml.Array o ->
    Parser Yaml.Value o
  -- | Parse an object
  ParseObject ::
    -- | Extra info about what the object represents
    -- This info will be used during parsing for error messages and in the schema for documentation.
    Maybe Text ->
    Parser Yaml.Object a ->
    Parser Yaml.Value a
  -- | Parse a list of elements all in the same way
  ParseList ::
    Parser Yaml.Value o ->
    Parser Yaml.Array (Vector o)
  -- | Parse a map where the keys are the yaml keys
  ParseMap ::
    Parser Yaml.Value v ->
    Parser Yaml.Object (HashMap Text v)
  -- | Parse a map's keys via a given parser
  ParseMapKeys ::
    Ord k =>
    Parser Text k ->
    Parser Yaml.Object (HashMap Text v) ->
    Parser Yaml.Object (Map k v) -- Once we get out of a HashMap, we'll want to stay out.

  -- | Parse a field of an object
  ParseField ::
    -- | The key of the field
    Text ->
    FieldParser o ->
    Parser Yaml.Object o
  -- | A pure value
  ParsePure :: a -> Parser i a
  -- | To implement Functor
  ParseFmap :: (a -> b) -> Parser i a -> Parser i b
  -- | To implement Applicative
  ParseAp :: Parser i (a -> b) -> Parser i a -> Parser i b
  -- | To implement Alternative
  ParseAlt :: [Parser i o] -> Parser i o
  -- | Add comments to the parser.
  -- This info will be used in the schema for documentation.
  ParseComment :: Text -> Parser i o -> Parser i o

instance Functor (Parser i) where
  fmap :: (a -> b) -> Parser i a -> Parser i b
fmap = (a -> b) -> Parser i a -> Parser i b
forall a b i. (a -> b) -> Parser i a -> Parser i b
ParseFmap

-- Realy only makes sense for 'Parser Yaml.Object', but we need 'Parser i' here to get the 'Alternative' instance to work
instance Applicative (Parser i) where
  pure :: a -> Parser i a
pure = a -> Parser i a
forall a i. a -> Parser i a
ParsePure
  <*> :: Parser i (a -> b) -> Parser i a -> Parser i b
(<*>) = Parser i (a -> b) -> Parser i a -> Parser i b
forall i a b. Parser i (a -> b) -> Parser i a -> Parser i b
ParseAp

instance Alternative (Parser i) where
  empty :: Parser i a
empty = [Parser i a] -> Parser i a
forall i o. [Parser i o] -> Parser i o
ParseAlt []
  Parser i a
l <|> :: Parser i a -> Parser i a -> Parser i a
<|> Parser i a
r = [Parser i a] -> Parser i a
forall i o. [Parser i o] -> Parser i o
ParseAlt [Parser i a
l, Parser i a
r]
  some :: Parser i a -> Parser i [a]
some = Parser i a -> Parser i [a]
forall a. HasCallStack => a
undefined -- TODO figure out what to do here
  many :: Parser i a -> Parser i [a]
many = Parser i a -> Parser i [a]
forall a. HasCallStack => a
undefined

data FieldParser o where
  FieldParserFmap :: (a -> b) -> FieldParser a -> FieldParser b
  FieldParserRequired :: YamlParser o -> FieldParser o
  FieldParserOptional :: YamlParser o -> FieldParser (Maybe o)
  FieldParserOptionalWithDefault :: Show o => YamlParser o -> o -> FieldParser o

instance Functor FieldParser where
  fmap :: (a -> b) -> FieldParser a -> FieldParser b
fmap = (a -> b) -> FieldParser a -> FieldParser b
forall a b. (a -> b) -> FieldParser a -> FieldParser b
FieldParserFmap

type YamlParser a = Parser Yaml.Value a

type ObjectParser a = Parser Yaml.Object a

type KeyParser a = Parser Text a

-- | Declare a parser of a named object
objectParser :: Text -> ObjectParser o -> YamlParser o
objectParser :: Text -> ObjectParser o -> YamlParser o
objectParser Text
name = Maybe Text -> ObjectParser o -> YamlParser o
forall a. Maybe Text -> Parser Object a -> Parser Value a
ParseObject (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name)

-- | Declare a parser of an unnamed object
--
-- Prefer 'objectParser' if you can.
unnamedObjectParser :: ObjectParser o -> YamlParser o
unnamedObjectParser :: ObjectParser o -> YamlParser o
unnamedObjectParser = Maybe Text -> ObjectParser o -> YamlParser o
forall a. Maybe Text -> Parser Object a -> Parser Value a
ParseObject Maybe Text
forall a. Maybe a
Nothing

-- | Parse a string-like thing by 'Read'-ing it
--
-- You probably don't want to use 'Read'.
viaRead :: Read a => YamlParser a
viaRead :: YamlParser a
viaRead = (String -> Maybe a) -> Parser Value String -> YamlParser a
forall o u i. Show o => (o -> Maybe u) -> Parser i o -> Parser i u
maybeParser String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (Parser Value String -> YamlParser a)
-> Parser Value String -> YamlParser a
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Parser Value Text -> Parser Value String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> Parser Text Text -> Parser Value Text
forall o. Maybe Text -> Parser Text o -> Parser Value o
ParseString Maybe Text
forall a. Maybe a
Nothing Parser Text Text
forall i. Parser i i
ParseAny

-- | Declare a parser for an exact string.
--
-- You can use this to parse a constructor in an enum for example:
--
-- > data Fruit = Apple | Banana
-- >
-- > instance YamlSchema Fruit where
-- >   yamlSchema = Apple <$ literalString "Apple" <|> Banana <$ literalString "Banana"
literalString :: Text -> YamlParser Text
literalString :: Text -> Parser Value Text
literalString Text
t = Maybe Text -> Parser Text Text -> Parser Value Text
forall o. Maybe Text -> Parser Text o -> Parser Value o
ParseString Maybe Text
forall a. Maybe a
Nothing (Parser Text Text -> Parser Value Text)
-> Parser Text Text -> Parser Value Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Parser Text Text -> Parser Text Text
forall o i. (Show o, Eq o) => o -> Text -> Parser i o -> Parser i o
ParseEq Text
t (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
t) Parser Text Text
forall i. Parser i i
ParseAny

-- | Declare a parser for a value using its show instance
--
-- Note that no value is read. The parsed string is just compared to the shown given value.
--
-- You can use this to parse a constructor in an enum when it has a 'Show' instance.
--
-- For example:
--
-- > data Fruit = Apple | Banana | Melon
-- >   deriving (Show, Eq)
-- >
-- > instance YamlSchema Fruit where
-- >   yamlSchema = alternatives
-- >      [ literalShowString Apple
-- >      , literalShowString Banana
-- >      , literalShowString Melon
-- >      ]
literalShowValue :: Show a => a -> YamlParser a
literalShowValue :: a -> YamlParser a
literalShowValue a
v = a
v a -> Parser Value Text -> YamlParser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Parser Value Text
literalString (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
v)

-- | Declare a parser for a value using its show instance
--
-- Note that no value is read. The parsed string is just compared to the shown given value.
--
-- You can use this to parse a constructor in an enum when it has a 'ToJSON' instance.
--
-- For example
--
-- > data Fruit = Apple | Banana | Melon
-- >   deriving (Eq, Generic)
-- >
-- > instance ToJSON Fruit
-- >
-- > instance YamlSchema Fruit where
-- >   yamlSchema = alternatives
-- >      [ literalValue Apple
-- >      , literalValue Banana
-- >      , literalValue Melon
-- >      ]
literalValue :: Yaml.ToJSON a => a -> YamlParser a
literalValue :: a -> YamlParser a
literalValue a
v = a
v a -> Parser Value Value -> YamlParser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Value -> Text -> Parser Value Value -> Parser Value Value
forall o i. (Show o, Eq o) => o -> Text -> Parser i o -> Parser i o
ParseEq (a -> Value
forall a. ToJSON a => a -> Value
Yaml.toJSON a
v) (ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode a
v) Parser Value Value
forall i. Parser i i
ParseAny

-- | Use the first parser of the given list that succeeds
--
-- You can use this to parse a constructor in an enum.
--
-- For example:
--
-- > data Fruit = Apple | Banana | Melon
-- >
-- > instance YamlSchema Fruit where
-- >   yamlSchema = alternatives
-- >      [ Apple <$ literalString "Apple"
-- >      , Banana <$ literalString "Banana"
-- >      , Melon <$ literalString "Melon"
-- >      ]
alternatives :: [Parser i o] -> Parser i o
alternatives :: [Parser i o] -> Parser i o
alternatives = [Parser i o] -> Parser i o
forall i o. [Parser i o] -> Parser i o
ParseAlt

-- | Add a comment to a parser
--
-- This info will be used in the schema for documentation.
--
-- For example:
--
-- > data Result = Error | Ok
-- > instance YamlSchema Result where
-- >   yamlSchema = alternatives
-- >     [ Error <$ literalString "Error" <?> "An error"
-- >     , Ok <$ literalString "Ok" <?> "Oll Klear"
-- >     ]
(<?>) :: Parser i a -> Text -> Parser i a
<?> :: Parser i a -> Text -> Parser i a
(<?>) = (Text -> Parser i a -> Parser i a)
-> Parser i a -> Text -> Parser i a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Parser i a -> Parser i a
forall i o. Text -> Parser i o -> Parser i o
ParseComment

-- | Add a list of lines of comments to a parser
--
-- This info will be used in the schema for documentation.
--
-- For example:
--
-- > data Result = Error | Ok
-- > instance YamlSchema Result where
-- >   yamlSchema = alternatives
-- >     [ Error <$ literalString "Error" <??> ["Just an error", "but I've got a lot to say about this"]
-- >     , Ok <$ literalString "Ok" <??> ["Oll Klear", "I really don't know where 'OK' comes from?!"]
-- >     ]
(<??>) :: Parser i a -> [Text] -> Parser i a
<??> :: Parser i a -> [Text] -> Parser i a
(<??>) Parser i a
p [Text]
ts = Parser i a
p Parser i a -> Text -> Parser i a
forall i a. Parser i a -> Text -> Parser i a
<?> [Text] -> Text
T.unlines [Text]
ts

-- | A parser for a required field at a given key with a parser for what is found at that key
requiredFieldWith :: Text -> Text -> YamlParser a -> ObjectParser a
requiredFieldWith :: Text -> Text -> YamlParser a -> ObjectParser a
requiredFieldWith Text
k Text
h YamlParser a
func = Text -> ObjectParser a -> ObjectParser a
forall i o. Text -> Parser i o -> Parser i o
ParseComment Text
h (ObjectParser a -> ObjectParser a)
-> ObjectParser a -> ObjectParser a
forall a b. (a -> b) -> a -> b
$ Text -> FieldParser a -> ObjectParser a
forall o. Text -> FieldParser o -> Parser Object o
ParseField Text
k (FieldParser a -> ObjectParser a)
-> FieldParser a -> ObjectParser a
forall a b. (a -> b) -> a -> b
$ YamlParser a -> FieldParser a
forall o. YamlParser o -> FieldParser o
FieldParserRequired YamlParser a
func

-- | A parser for a required field at a given key with a parser for what is found at that key without a help text
requiredFieldWith' :: Text -> YamlParser a -> ObjectParser a
requiredFieldWith' :: Text -> YamlParser a -> ObjectParser a
requiredFieldWith' Text
k YamlParser a
func = Text -> FieldParser a -> ObjectParser a
forall o. Text -> FieldParser o -> Parser Object o
ParseField Text
k (FieldParser a -> ObjectParser a)
-> FieldParser a -> ObjectParser a
forall a b. (a -> b) -> a -> b
$ YamlParser a -> FieldParser a
forall o. YamlParser o -> FieldParser o
FieldParserRequired YamlParser a
func

-- | A parser for an optional field at a given key with a parser for what is found at that key
optionalFieldWith :: Text -> Text -> YamlParser a -> ObjectParser (Maybe a)
optionalFieldWith :: Text -> Text -> YamlParser a -> ObjectParser (Maybe a)
optionalFieldWith Text
k Text
h YamlParser a
func = Text -> ObjectParser (Maybe a) -> ObjectParser (Maybe a)
forall i o. Text -> Parser i o -> Parser i o
ParseComment Text
h (ObjectParser (Maybe a) -> ObjectParser (Maybe a))
-> ObjectParser (Maybe a) -> ObjectParser (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> FieldParser (Maybe a) -> ObjectParser (Maybe a)
forall o. Text -> FieldParser o -> Parser Object o
ParseField Text
k (FieldParser (Maybe a) -> ObjectParser (Maybe a))
-> FieldParser (Maybe a) -> ObjectParser (Maybe a)
forall a b. (a -> b) -> a -> b
$ (Maybe (Maybe a) -> Maybe a)
-> FieldParser (Maybe (Maybe a)) -> FieldParser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (FieldParser (Maybe (Maybe a)) -> FieldParser (Maybe a))
-> FieldParser (Maybe (Maybe a)) -> FieldParser (Maybe a)
forall a b. (a -> b) -> a -> b
$ YamlParser (Maybe a) -> FieldParser (Maybe (Maybe a))
forall o. YamlParser o -> FieldParser (Maybe o)
FieldParserOptional (YamlParser (Maybe a) -> FieldParser (Maybe (Maybe a)))
-> YamlParser (Maybe a) -> FieldParser (Maybe (Maybe a))
forall a b. (a -> b) -> a -> b
$ YamlParser a -> YamlParser (Maybe a)
forall o. Parser Value o -> Parser Value (Maybe o)
ParseMaybe YamlParser a
func

-- | A parser for an optional field at a given key with a parser for what is found at that key without a help text
optionalFieldWith' :: Text -> YamlParser a -> ObjectParser (Maybe a)
optionalFieldWith' :: Text -> YamlParser a -> ObjectParser (Maybe a)
optionalFieldWith' Text
k YamlParser a
func = Text -> FieldParser (Maybe a) -> ObjectParser (Maybe a)
forall o. Text -> FieldParser o -> Parser Object o
ParseField Text
k (FieldParser (Maybe a) -> ObjectParser (Maybe a))
-> FieldParser (Maybe a) -> ObjectParser (Maybe a)
forall a b. (a -> b) -> a -> b
$ (Maybe (Maybe a) -> Maybe a)
-> FieldParser (Maybe (Maybe a)) -> FieldParser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (FieldParser (Maybe (Maybe a)) -> FieldParser (Maybe a))
-> FieldParser (Maybe (Maybe a)) -> FieldParser (Maybe a)
forall a b. (a -> b) -> a -> b
$ YamlParser (Maybe a) -> FieldParser (Maybe (Maybe a))
forall o. YamlParser o -> FieldParser (Maybe o)
FieldParserOptional (YamlParser (Maybe a) -> FieldParser (Maybe (Maybe a)))
-> YamlParser (Maybe a) -> FieldParser (Maybe (Maybe a))
forall a b. (a -> b) -> a -> b
$ YamlParser a -> YamlParser (Maybe a)
forall o. Parser Value o -> Parser Value (Maybe o)
ParseMaybe YamlParser a
func

-- | A parser for an optional field at a given key with a default value and a parser for what is found at that key
--
-- For the sake of documentation, the default value needs to be showable.
optionalFieldWithDefaultWith :: Show a => Text -> a -> Text -> YamlParser a -> ObjectParser a
optionalFieldWithDefaultWith :: Text -> a -> Text -> YamlParser a -> ObjectParser a
optionalFieldWithDefaultWith Text
k a
d Text
h YamlParser a
func = Text -> ObjectParser a -> ObjectParser a
forall i o. Text -> Parser i o -> Parser i o
ParseComment Text
h (ObjectParser a -> ObjectParser a)
-> ObjectParser a -> ObjectParser a
forall a b. (a -> b) -> a -> b
$ Text -> FieldParser a -> ObjectParser a
forall o. Text -> FieldParser o -> Parser Object o
ParseField Text
k (FieldParser a -> ObjectParser a)
-> FieldParser a -> ObjectParser a
forall a b. (a -> b) -> a -> b
$ YamlParser a -> a -> FieldParser a
forall o. Show o => YamlParser o -> o -> FieldParser o
FieldParserOptionalWithDefault YamlParser a
func a
d

-- | A parser for an optional field at a given key with a default value and a parser for what is found at that key without a help text
--
-- For the sake of documentation, the default value needs to be showable.
optionalFieldWithDefaultWith' :: Show a => Text -> a -> YamlParser a -> ObjectParser a
optionalFieldWithDefaultWith' :: Text -> a -> YamlParser a -> ObjectParser a
optionalFieldWithDefaultWith' Text
k a
d YamlParser a
func = Text -> FieldParser a -> ObjectParser a
forall o. Text -> FieldParser o -> Parser Object o
ParseField Text
k (FieldParser a -> ObjectParser a)
-> FieldParser a -> ObjectParser a
forall a b. (a -> b) -> a -> b
$ YamlParser a -> a -> FieldParser a
forall o. Show o => YamlParser o -> o -> FieldParser o
FieldParserOptionalWithDefault YamlParser a
func a
d

-- | Make a parser that parses a value using the given extra parsing function
--
-- You can use this to make a parser for a type with a smart constructor.
-- Prefer 'eitherParser' if you can so you get better error messages.
--
-- Example:
--
-- > parseUsername :: Text -> Maybe Username
-- >
-- > instance YamlSchema Username where
-- >   yamlSchema = maybeParser parseUsername yamlSchema
maybeParser :: Show o => (o -> Maybe u) -> Parser i o -> Parser i u
maybeParser :: (o -> Maybe u) -> Parser i o -> Parser i u
maybeParser o -> Maybe u
func = (o -> Parser u) -> Parser i o -> Parser i u
forall o u i. (o -> Parser u) -> Parser i o -> Parser i u
ParseExtra ((o -> Parser u) -> Parser i o -> Parser i u)
-> (o -> Parser u) -> Parser i o -> Parser i u
forall a b. (a -> b) -> a -> b
$ \o
o -> case o -> Maybe u
func o
o of
  Maybe u
Nothing -> String -> Parser u
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser u) -> String -> Parser u
forall a b. (a -> b) -> a -> b
$ String
"Parsing of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> o -> String
forall a. Show a => a -> String
show o
o String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" failed."
  Just u
u -> u -> Parser u
forall (f :: * -> *) a. Applicative f => a -> f a
pure u
u

-- | Make a parser that parses a value using the given extra parsing function
--
-- You can use this to make a parser for a type with a smart constructor.
-- If you don't have a 'Show' instance for your 'o', then you can use 'extraParser' instead.
--
-- Example:
--
-- > parseUsername :: Text -> Either String Username
-- >
-- > instance YamlSchema Username where
-- >   yamlSchema = eitherParser parseUsername yamlSchema
eitherParser :: Show o => (o -> Either String u) -> Parser i o -> Parser i u
eitherParser :: (o -> Either String u) -> Parser i o -> Parser i u
eitherParser o -> Either String u
func = (o -> Parser u) -> Parser i o -> Parser i u
forall o u i. (o -> Parser u) -> Parser i o -> Parser i u
ParseExtra ((o -> Parser u) -> Parser i o -> Parser i u)
-> (o -> Parser u) -> Parser i o -> Parser i u
forall a b. (a -> b) -> a -> b
$ \o
o -> case o -> Either String u
func o
o of
  Left String
err -> String -> Parser u
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser u) -> String -> Parser u
forall a b. (a -> b) -> a -> b
$ String
"Parsing of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> o -> String
forall a. Show a => a -> String
show o
o String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" failed with error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
  Right u
u -> u -> Parser u
forall (f :: * -> *) a. Applicative f => a -> f a
pure u
u

-- | Make a parser that parses a value using the given extra parsing function
--
-- You can use this to make a parser for a type with a smart constructor.
-- Prefer 'eitherParser' if you can, use this if you don't have a 'Show' instance for your 'o'.
extraParser :: (o -> Yaml.Parser u) -> Parser i o -> Parser i u
extraParser :: (o -> Parser u) -> Parser i o -> Parser i u
extraParser = (o -> Parser u) -> Parser i o -> Parser i u
forall o u i. (o -> Parser u) -> Parser i o -> Parser i u
ParseExtra