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

module YamlParse.Applicative.Class where

import qualified Data.Aeson as JSON
import Data.HashMap.Strict (HashMap)
import Data.Int
import Data.List.NonEmpty as NE
import Data.Map (Map)
import Data.Scientific
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Word
import qualified Data.Yaml as Yaml
import GHC.Generics (Generic)
import Path
import YamlParse.Applicative.Implement
import YamlParse.Applicative.Parser

-- | A class of types for which a schema is defined.
--
-- Note that you do not have to use this class and can just use your own parser values.
-- Note also that the parsing of a type of this class should correspond to the parsing of the type in the FromJSON class.
class YamlSchema a where
  {-# MINIMAL yamlSchema #-}

  -- | A yamlschema for one value
  --
  -- See the sections on helper functions for implementing this for plenty of examples.
  yamlSchema :: YamlParser a

  -- | A yamlschema for a list of values
  --
  -- This is really only useful for cases like 'Char' and 'String'
  yamlSchemaList :: YamlParser [a]
  yamlSchemaList = Vector a -> [a]
forall a. Vector a -> [a]
V.toList (Vector a -> [a]) -> Parser Value (Vector a) -> YamlParser [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> Parser Array (Vector a) -> Parser Value (Vector a)
forall o. Maybe Text -> Parser Array o -> Parser Value o
ParseArray Maybe Text
forall a. Maybe a
Nothing (Parser Value a -> Parser Array (Vector a)
forall o. Parser Value o -> Parser Array (Vector o)
ParseList Parser Value a
forall a. YamlSchema a => Parser Value a
yamlSchema)

-- | A class of types for which a schema for keys is defined.
class YamlKeySchema a where
  yamlKeySchema :: KeyParser a

instance YamlSchema () where
  yamlSchema :: YamlParser ()
yamlSchema = () -> YamlParser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance YamlSchema Bool where
  yamlSchema :: YamlParser Bool
yamlSchema = Maybe Text -> Parser Bool Bool -> YamlParser Bool
forall o. Maybe Text -> Parser Bool o -> Parser Value o
ParseBool Maybe Text
forall a. Maybe a
Nothing Parser Bool Bool
forall i. Parser i i
ParseAny

instance YamlSchema Char where
  yamlSchema :: YamlParser Char
yamlSchema =
    Maybe Text -> Parser Text Char -> YamlParser Char
forall o. Maybe Text -> Parser Text o -> Parser Value o
ParseString Maybe Text
forall a. Maybe a
Nothing (Parser Text Char -> YamlParser Char)
-> Parser Text Char -> YamlParser Char
forall a b. (a -> b) -> a -> b
$
      (Text -> Maybe Char) -> Parser Text Text -> Parser Text Char
forall o u i. Show o => (o -> Maybe u) -> Parser i o -> Parser i u
maybeParser
        ( \Text
cs -> case Text -> [Char]
T.unpack Text
cs of
            [] -> Maybe Char
forall a. Maybe a
Nothing
            [Char
c] -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
            [Char]
_ -> Maybe Char
forall a. Maybe a
Nothing
        )
        Parser Text Text
forall i. Parser i i
ParseAny
  yamlSchemaList :: YamlParser [Char]
yamlSchemaList = Text -> [Char]
T.unpack (Text -> [Char]) -> Parser Value Text -> YamlParser [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Value Text
forall a. YamlSchema a => Parser Value a
yamlSchema

instance YamlSchema Text where
  yamlSchema :: Parser Value Text
yamlSchema = 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

instance YamlKeySchema Text where
  yamlKeySchema :: Parser Text Text
yamlKeySchema = Parser Text Text
forall i. Parser i i
ParseAny

instance YamlKeySchema String where
  yamlKeySchema :: KeyParser [Char]
yamlKeySchema = Text -> [Char]
T.unpack (Text -> [Char]) -> Parser Text Text -> KeyParser [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text
forall a. YamlKeySchema a => KeyParser a
yamlKeySchema

instance YamlSchema Scientific where
  yamlSchema :: YamlParser Scientific
yamlSchema = Maybe Text -> Parser Scientific Scientific -> YamlParser Scientific
forall o. Maybe Text -> Parser Scientific o -> Parser Value o
ParseNumber Maybe Text
forall a. Maybe a
Nothing Parser Scientific Scientific
forall i. Parser i i
ParseAny

instance YamlSchema Int where
  yamlSchema :: YamlParser Int
yamlSchema = YamlParser Int
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

instance YamlSchema Int8 where
  yamlSchema :: YamlParser Int8
yamlSchema = YamlParser Int8
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

instance YamlSchema Int16 where
  yamlSchema :: YamlParser Int16
yamlSchema = YamlParser Int16
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

instance YamlSchema Int32 where
  yamlSchema :: YamlParser Int32
yamlSchema = YamlParser Int32
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

instance YamlSchema Int64 where
  yamlSchema :: YamlParser Int64
yamlSchema = YamlParser Int64
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

instance YamlSchema Word where
  yamlSchema :: YamlParser Word
yamlSchema = YamlParser Word
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

instance YamlSchema Word8 where
  yamlSchema :: YamlParser Word8
yamlSchema = YamlParser Word8
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

instance YamlSchema Word16 where
  yamlSchema :: YamlParser Word16
yamlSchema = YamlParser Word16
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

instance YamlSchema Word32 where
  yamlSchema :: YamlParser Word32
yamlSchema = YamlParser Word32
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

instance YamlSchema Word64 where
  yamlSchema :: YamlParser Word64
yamlSchema = YamlParser Word64
forall i. (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema

boundedIntegerSchema :: (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema :: YamlParser i
boundedIntegerSchema = (Scientific -> Maybe i) -> YamlParser Scientific -> YamlParser i
forall o u i. Show o => (o -> Maybe u) -> Parser i o -> Parser i u
maybeParser Scientific -> Maybe i
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger (YamlParser Scientific -> YamlParser i)
-> YamlParser Scientific -> YamlParser i
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Parser Scientific Scientific -> YamlParser Scientific
forall o. Maybe Text -> Parser Scientific o -> Parser Value o
ParseNumber Maybe Text
forall a. Maybe a
Nothing Parser Scientific Scientific
forall i. Parser i i
ParseAny

instance YamlSchema (Path Rel File) where
  yamlSchema :: YamlParser (Path Rel File)
yamlSchema = ([Char] -> Maybe (Path Rel File))
-> YamlParser [Char] -> YamlParser (Path Rel File)
forall o u i. Show o => (o -> Maybe u) -> Parser i o -> Parser i u
maybeParser [Char] -> Maybe (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile YamlParser [Char]
forall a. YamlSchema a => Parser Value a
yamlSchema

instance YamlSchema (Path Rel Dir) where
  yamlSchema :: YamlParser (Path Rel Dir)
yamlSchema = ([Char] -> Maybe (Path Rel Dir))
-> YamlParser [Char] -> YamlParser (Path Rel Dir)
forall o u i. Show o => (o -> Maybe u) -> Parser i o -> Parser i u
maybeParser [Char] -> Maybe (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir YamlParser [Char]
forall a. YamlSchema a => Parser Value a
yamlSchema

instance YamlSchema (Path Abs File) where
  yamlSchema :: YamlParser (Path Abs File)
yamlSchema = ([Char] -> Maybe (Path Abs File))
-> YamlParser [Char] -> YamlParser (Path Abs File)
forall o u i. Show o => (o -> Maybe u) -> Parser i o -> Parser i u
maybeParser [Char] -> Maybe (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile YamlParser [Char]
forall a. YamlSchema a => Parser Value a
yamlSchema

instance YamlSchema (Path Abs Dir) where
  yamlSchema :: YamlParser (Path Abs Dir)
yamlSchema = ([Char] -> Maybe (Path Abs Dir))
-> YamlParser [Char] -> YamlParser (Path Abs Dir)
forall o u i. Show o => (o -> Maybe u) -> Parser i o -> Parser i u
maybeParser [Char] -> Maybe (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs Dir)
parseAbsDir YamlParser [Char]
forall a. YamlSchema a => Parser Value a
yamlSchema

instance YamlSchema Yaml.Value where
  yamlSchema :: YamlParser Value
yamlSchema = YamlParser Value
forall i. Parser i i
ParseAny

instance YamlSchema a => YamlSchema (Maybe a) where
  yamlSchema :: YamlParser (Maybe a)
yamlSchema = Parser Value a -> YamlParser (Maybe a)
forall o. Parser Value o -> Parser Value (Maybe o)
ParseMaybe Parser Value a
forall a. YamlSchema a => Parser Value a
yamlSchema

instance YamlSchema a => YamlSchema (Vector a) where
  yamlSchema :: YamlParser (Vector a)
yamlSchema = Maybe Text -> Parser Array (Vector a) -> YamlParser (Vector a)
forall o. Maybe Text -> Parser Array o -> Parser Value o
ParseArray Maybe Text
forall a. Maybe a
Nothing (Parser Value a -> Parser Array (Vector a)
forall o. Parser Value o -> Parser Array (Vector o)
ParseList Parser Value a
forall a. YamlSchema a => Parser Value a
yamlSchema)

instance YamlSchema a => YamlSchema [a] where
  yamlSchema :: YamlParser [a]
yamlSchema = YamlParser [a]
forall a. YamlSchema a => YamlParser [a]
yamlSchemaList

instance YamlSchema a => YamlSchema (NonEmpty a) where
  yamlSchema :: YamlParser (NonEmpty a)
yamlSchema = ([a] -> Parser (NonEmpty a))
-> Parser Value [a] -> YamlParser (NonEmpty a)
forall o u i. (o -> Parser u) -> Parser i o -> Parser i u
extraParser [a] -> Parser (NonEmpty a)
go Parser Value [a]
forall a. YamlSchema a => Parser Value a
yamlSchema
    where
      go :: [a] -> Yaml.Parser (NonEmpty a)
      go :: [a] -> Parser (NonEmpty a)
go [a]
as = case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [a]
as of
        Maybe (NonEmpty a)
Nothing -> [Char] -> Parser (NonEmpty a)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Nonempty list expected, but got an empty list"
        Just NonEmpty a
ne -> NonEmpty a -> Parser (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty a
ne

instance (Ord a, YamlSchema a) => YamlSchema (Set a) where
  yamlSchema :: YamlParser (Set a)
yamlSchema = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> Parser Value [a] -> YamlParser (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Value [a]
forall a. YamlSchema a => Parser Value a
yamlSchema

instance (Ord k, YamlKeySchema k, YamlSchema v) => YamlSchema (Map k v) where
  yamlSchema :: YamlParser (Map k v)
yamlSchema = Maybe Text -> Parser Object (Map k v) -> YamlParser (Map k v)
forall a. Maybe Text -> Parser Object a -> Parser Value a
ParseObject Maybe Text
forall a. Maybe a
Nothing (Parser Object (Map k v) -> YamlParser (Map k v))
-> Parser Object (Map k v) -> YamlParser (Map k v)
forall a b. (a -> b) -> a -> b
$ Parser Text k
-> Parser Object (HashMap Text v) -> Parser Object (Map k v)
forall k v.
Ord k =>
Parser Text k
-> Parser Object (HashMap Text v) -> Parser Object (Map k v)
ParseMapKeys Parser Text k
forall a. YamlKeySchema a => KeyParser a
yamlKeySchema (Parser Object (HashMap Text v) -> Parser Object (Map k v))
-> Parser Object (HashMap Text v) -> Parser Object (Map k v)
forall a b. (a -> b) -> a -> b
$ Parser Value v -> Parser Object (HashMap Text v)
forall v. Parser Value v -> Parser Object (HashMap Text v)
ParseMap Parser Value v
forall a. YamlSchema a => Parser Value a
yamlSchema

-- | There is no instance using YamlKeySchema k yet.
-- Ideally there wouldn't be one for HashMap Text either because it's insecure,
-- but the yaml arrives in a HashMap anyway so we might as well expose this.
instance YamlSchema v => YamlSchema (HashMap Text v) where
  yamlSchema :: YamlParser (HashMap Text v)
yamlSchema = Maybe Text
-> Parser Object (HashMap Text v) -> YamlParser (HashMap Text v)
forall a. Maybe Text -> Parser Object a -> Parser Value a
ParseObject Maybe Text
forall a. Maybe a
Nothing (Parser Object (HashMap Text v) -> YamlParser (HashMap Text v))
-> Parser Object (HashMap Text v) -> YamlParser (HashMap Text v)
forall a b. (a -> b) -> a -> b
$ Parser Value v -> Parser Object (HashMap Text v)
forall v. Parser Value v -> Parser Object (HashMap Text v)
ParseMap Parser Value v
forall a. YamlSchema a => Parser Value a
yamlSchema

-- | A parser for a required field in an object at a given key
requiredField :: YamlSchema a => Text -> Text -> ObjectParser a
requiredField :: Text -> Text -> ObjectParser a
requiredField Text
k Text
h = Text -> Text -> YamlParser a -> ObjectParser a
forall a. Text -> Text -> YamlParser a -> ObjectParser a
requiredFieldWith Text
k Text
h YamlParser a
forall a. YamlSchema a => Parser Value a
yamlSchema

-- | A parser for a required field in an object at a given key without a help text
requiredField' :: YamlSchema a => Text -> ObjectParser a
requiredField' :: Text -> ObjectParser a
requiredField' Text
k = Text -> YamlParser a -> ObjectParser a
forall a. Text -> YamlParser a -> ObjectParser a
requiredFieldWith' Text
k YamlParser a
forall a. YamlSchema a => Parser Value a
yamlSchema

-- | A parser for an optional field in an object at a given key
optionalField :: YamlSchema a => Text -> Text -> ObjectParser (Maybe a)
optionalField :: Text -> Text -> ObjectParser (Maybe a)
optionalField Text
k Text
h = Text -> Text -> YamlParser a -> ObjectParser (Maybe a)
forall a. Text -> Text -> YamlParser a -> ObjectParser (Maybe a)
optionalFieldWith Text
k Text
h YamlParser a
forall a. YamlSchema a => Parser Value a
yamlSchema

-- | A parser for an optional field in an object at a given key without a help text
optionalField' :: YamlSchema a => Text -> ObjectParser (Maybe a)
optionalField' :: Text -> ObjectParser (Maybe a)
optionalField' Text
k = Text -> YamlParser a -> ObjectParser (Maybe a)
forall a. Text -> YamlParser a -> ObjectParser (Maybe a)
optionalFieldWith' Text
k YamlParser a
forall a. YamlSchema a => Parser Value a
yamlSchema

-- | A parser for an optional field in an object at a given key with a default value
optionalFieldWithDefault :: (Show a, YamlSchema a) => Text -> a -> Text -> ObjectParser a
optionalFieldWithDefault :: Text -> a -> Text -> ObjectParser a
optionalFieldWithDefault Text
k a
d Text
h = Text -> a -> Text -> YamlParser a -> ObjectParser a
forall a.
Show a =>
Text -> a -> Text -> YamlParser a -> ObjectParser a
optionalFieldWithDefaultWith Text
k a
d Text
h YamlParser a
forall a. YamlSchema a => Parser Value a
yamlSchema

-- | A parser for an optional field in an object at a given key with a default value without a help text
optionalFieldWithDefault' :: (Show a, YamlSchema a) => Text -> a -> ObjectParser a
optionalFieldWithDefault' :: Text -> a -> ObjectParser a
optionalFieldWithDefault' Text
k a
d = Text -> a -> YamlParser a -> ObjectParser a
forall a. Show a => Text -> a -> YamlParser a -> ObjectParser a
optionalFieldWithDefaultWith' Text
k a
d YamlParser a
forall a. YamlSchema a => Parser Value a
yamlSchema

-- | Helper function to implement 'FromJSON' via 'YamlSchema'
--
-- Example:
--
-- > instance FromJSON Config where
-- >   parseJSON = viaYamlSchema
viaYamlSchema :: YamlSchema a => Yaml.Value -> Yaml.Parser a
viaYamlSchema :: Value -> Parser a
viaYamlSchema = Parser Value a -> Value -> Parser a
forall i o. Parser i o -> i -> Parser o
implementParser Parser Value a
forall a. YamlSchema a => Parser Value a
yamlSchema

-- | A helper newtype to parse a yaml value using the YamlSchema parser.
--
-- Example:
--
-- > case Data.Yaml.decodeEither' contents of
-- >   Left e -> die $ show e
-- >   Right (ViaYamlSchema res) -> print res
--
-- This only helps you when you really don't want to implement a 'FromJSON' instance.
-- See 'viaYamlSchema' if you do.
newtype ViaYamlSchema a = ViaYamlSchema a
  deriving (Int -> ViaYamlSchema a -> ShowS
[ViaYamlSchema a] -> ShowS
ViaYamlSchema a -> [Char]
(Int -> ViaYamlSchema a -> ShowS)
-> (ViaYamlSchema a -> [Char])
-> ([ViaYamlSchema a] -> ShowS)
-> Show (ViaYamlSchema a)
forall a. Show a => Int -> ViaYamlSchema a -> ShowS
forall a. Show a => [ViaYamlSchema a] -> ShowS
forall a. Show a => ViaYamlSchema a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ViaYamlSchema a] -> ShowS
$cshowList :: forall a. Show a => [ViaYamlSchema a] -> ShowS
show :: ViaYamlSchema a -> [Char]
$cshow :: forall a. Show a => ViaYamlSchema a -> [Char]
showsPrec :: Int -> ViaYamlSchema a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ViaYamlSchema a -> ShowS
Show, ViaYamlSchema a -> ViaYamlSchema a -> Bool
(ViaYamlSchema a -> ViaYamlSchema a -> Bool)
-> (ViaYamlSchema a -> ViaYamlSchema a -> Bool)
-> Eq (ViaYamlSchema a)
forall a. Eq a => ViaYamlSchema a -> ViaYamlSchema a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ViaYamlSchema a -> ViaYamlSchema a -> Bool
$c/= :: forall a. Eq a => ViaYamlSchema a -> ViaYamlSchema a -> Bool
== :: ViaYamlSchema a -> ViaYamlSchema a -> Bool
$c== :: forall a. Eq a => ViaYamlSchema a -> ViaYamlSchema a -> Bool
Eq, (forall x. ViaYamlSchema a -> Rep (ViaYamlSchema a) x)
-> (forall x. Rep (ViaYamlSchema a) x -> ViaYamlSchema a)
-> Generic (ViaYamlSchema a)
forall x. Rep (ViaYamlSchema a) x -> ViaYamlSchema a
forall x. ViaYamlSchema a -> Rep (ViaYamlSchema a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ViaYamlSchema a) x -> ViaYamlSchema a
forall a x. ViaYamlSchema a -> Rep (ViaYamlSchema a) x
$cto :: forall a x. Rep (ViaYamlSchema a) x -> ViaYamlSchema a
$cfrom :: forall a x. ViaYamlSchema a -> Rep (ViaYamlSchema a) x
Generic)

instance YamlSchema a => Yaml.FromJSON (ViaYamlSchema a) where
  parseJSON :: Value -> Parser (ViaYamlSchema a)
parseJSON = (a -> ViaYamlSchema a) -> Parser a -> Parser (ViaYamlSchema a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ViaYamlSchema a
forall a. a -> ViaYamlSchema a
ViaYamlSchema (Parser a -> Parser (ViaYamlSchema a))
-> (Value -> Parser a) -> Value -> Parser (ViaYamlSchema a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser a
forall a. YamlSchema a => Value -> Parser a
viaYamlSchema