{-# 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 qualified Data.Text as T
import Data.Text (Text)
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
class YamlSchema a where
{-# MINIMAL yamlSchema #-}
yamlSchema :: YamlParser a
yamlSchemaList :: YamlParser [a]
yamlSchemaList = V.toList <$> ParseArray Nothing (ParseList yamlSchema)
class YamlKeySchema a where
yamlKeySchema :: KeyParser a
instance YamlSchema () where
yamlSchema = pure ()
instance YamlSchema Bool where
yamlSchema = ParseBool Nothing ParseAny
instance YamlSchema Char where
yamlSchema =
ParseString Nothing $
maybeParser
( \cs -> case T.unpack cs of
[] -> Nothing
[c] -> Just c
_ -> Nothing
)
ParseAny
yamlSchemaList = T.unpack <$> yamlSchema
instance YamlSchema Text where
yamlSchema = ParseString Nothing ParseAny
instance YamlKeySchema Text where
yamlKeySchema = ParseAny
instance YamlKeySchema String where
yamlKeySchema = T.unpack <$> yamlKeySchema
instance YamlSchema Scientific where
yamlSchema = ParseNumber Nothing ParseAny
instance YamlSchema Int where
yamlSchema = boundedIntegerSchema
instance YamlSchema Int8 where
yamlSchema = boundedIntegerSchema
instance YamlSchema Int16 where
yamlSchema = boundedIntegerSchema
instance YamlSchema Int32 where
yamlSchema = boundedIntegerSchema
instance YamlSchema Int64 where
yamlSchema = boundedIntegerSchema
instance YamlSchema Word where
yamlSchema = boundedIntegerSchema
instance YamlSchema Word8 where
yamlSchema = boundedIntegerSchema
instance YamlSchema Word16 where
yamlSchema = boundedIntegerSchema
instance YamlSchema Word32 where
yamlSchema = boundedIntegerSchema
instance YamlSchema Word64 where
yamlSchema = boundedIntegerSchema
boundedIntegerSchema :: (Integral i, Bounded i) => YamlParser i
boundedIntegerSchema = maybeParser toBoundedInteger $ ParseNumber Nothing ParseAny
instance YamlSchema (Path Rel File) where
yamlSchema = maybeParser parseRelFile yamlSchema
instance YamlSchema (Path Rel Dir) where
yamlSchema = maybeParser parseRelDir yamlSchema
instance YamlSchema (Path Abs File) where
yamlSchema = maybeParser parseAbsFile yamlSchema
instance YamlSchema (Path Abs Dir) where
yamlSchema = maybeParser parseAbsDir yamlSchema
instance YamlSchema Yaml.Value where
yamlSchema = ParseAny
instance YamlSchema a => YamlSchema (Maybe a) where
yamlSchema = ParseMaybe yamlSchema
instance YamlSchema a => YamlSchema (Vector a) where
yamlSchema = ParseArray Nothing (ParseList yamlSchema)
instance YamlSchema a => YamlSchema [a] where
yamlSchema = yamlSchemaList
instance YamlSchema a => YamlSchema (NonEmpty a) where
yamlSchema = extraParser go yamlSchema
where
go :: [a] -> Yaml.Parser (NonEmpty a)
go as = case NE.nonEmpty as of
Nothing -> fail "Nonempty list expected, but got an empty list"
Just ne -> pure ne
instance (Ord a, YamlSchema a) => YamlSchema (Set a) where
yamlSchema = S.fromList <$> yamlSchema
instance (Ord k, YamlKeySchema k, YamlSchema v) => YamlSchema (Map k v) where
yamlSchema = ParseObject Nothing $ ParseMapKeys yamlKeySchema $ ParseMap yamlSchema
instance YamlSchema v => YamlSchema (HashMap Text v) where
yamlSchema = ParseObject Nothing $ ParseMap yamlSchema
requiredField :: YamlSchema a => Text -> Text -> ObjectParser a
requiredField k h = requiredFieldWith k h yamlSchema
requiredField' :: YamlSchema a => Text -> ObjectParser a
requiredField' k = requiredFieldWith' k yamlSchema
optionalField :: YamlSchema a => Text -> Text -> ObjectParser (Maybe a)
optionalField k h = optionalFieldWith k h yamlSchema
optionalField' :: YamlSchema a => Text -> ObjectParser (Maybe a)
optionalField' k = optionalFieldWith' k yamlSchema
optionalFieldWithDefault :: (Show a, YamlSchema a) => Text -> a -> Text -> ObjectParser a
optionalFieldWithDefault k d h = optionalFieldWithDefaultWith k d h yamlSchema
optionalFieldWithDefault' :: (Show a, YamlSchema a) => Text -> a -> ObjectParser a
optionalFieldWithDefault' k d = optionalFieldWithDefaultWith' k d yamlSchema
viaYamlSchema :: YamlSchema a => Yaml.Value -> Yaml.Parser a
viaYamlSchema = implementParser yamlSchema
newtype ViaYamlSchema a = ViaYamlSchema a
deriving (Show, Eq, Generic)
instance YamlSchema a => Yaml.FromJSON (ViaYamlSchema a) where
parseJSON = fmap ViaYamlSchema . viaYamlSchema