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.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 = 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
  FieldParserOptionalOrNull :: YamlParser o -> FieldParser (Maybe o)
  FieldParserOptionalOrNullWithDefault :: Show o => YamlParser o -> o -> FieldParser o

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 name = ParseObject (Just name)

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

-- | Parse a string-like thing by 'Read'-ing it
--
-- You probably don't want to use 'Read'.
viaRead :: Read a => YamlParser a
viaRead = maybeParser readMaybe $ T.unpack <$> ParseString Nothing 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 t = ParseString Nothing $ ParseEq t (T.pack $ show 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 $ FieldParserOptionalOrNull 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 $ FieldParserOptionalOrNull 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 $ FieldParserOptionalOrNullWithDefault 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 $ FieldParserOptionalOrNullWithDefault func 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 func = ParseExtra $ \o -> case func o of
  Nothing -> fail $ "Parsing of " <> show o <> " failed."
  Just u -> pure 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 func = ParseExtra $ \o -> case func o of
  Left err -> fail $ "Parsing of " <> show o <> " failed with error: " <> err <> "."
  Right u -> pure 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 = ParseExtra