Parser.hs

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

module YamlParse.Applicative.Parser where

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

-- | 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 a parser function
  ParseMaybe :: (o -> Maybe 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 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 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 = 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 = ParsePure
  (<*>) = ParseAp

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

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

type YamlParser a = Parser Yaml.Value a

type ObjectParser a = Parser Yaml.Object a

-- | Declare a parser of a named object
object :: Text -> ObjectParser o -> YamlParser o
object name = ParseObject (Just name)

-- | Declare a parser of an unnamed object
--
-- Prefer 'object' if you can.
unnamedObject :: ObjectParser o -> YamlParser o
unnamedObject = ParseObject Nothing

-- | 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 t = ParseString Nothing $ ParseEq t t 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 v = v <$ literalString (T.pack $ show 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 v = v <$ ParseEq (Yaml.toJSON v) (TE.decodeUtf8 $ LB.toStrict $ JSON.encode v) 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 = 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
(<?>) = flip 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
(<??>) p ts = p <?> T.unlines 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 k h func = ParseComment h $ ParseField k $ FieldParserRequired 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' k func = ParseField k $ FieldParserRequired 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 k h func = ParseComment h $ ParseField k $ FieldParserOptional 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' k func = ParseField k $ FieldParserOptional 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 k d h func = ParseComment h $ ParseField k $ FieldParserOptionalWithDefault func 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' k d func = ParseField k $ FieldParserOptionalWithDefault func d