{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.JsonSpec.Encode (
HasJsonEncodingSpec(..),
StructureToJSON(..),
) where
import Data.Aeson (ToJSON(toJSON), Value)
import Data.JsonSpec.Spec (Field(Field), Rec(unRec),
Specification(JsonArray), JSONStructure, JStruct, Tag, sym)
import Data.Scientific (Scientific)
import Data.Set (Set)
import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.TypeLits (KnownSymbol)
import Prelude (Either(Left, Right), Functor(fmap), Monoid(mempty),
(.), Bool, Int, Maybe, maybe)
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Set as Set
class HasJsonEncodingSpec a where
type EncodingSpec a :: Specification
toJSONStructure :: a -> JSONStructure (EncodingSpec a)
instance (HasJsonEncodingSpec a) => HasJsonEncodingSpec (Set a) where
type EncodingSpec (Set a) = JsonArray (EncodingSpec a)
toJSONStructure :: Set a -> JSONStructure (EncodingSpec (Set a))
toJSONStructure = (a -> JStruct '[] (EncodingSpec a))
-> [a] -> [JStruct '[] (EncodingSpec a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> JStruct '[] (EncodingSpec a)
a -> JSONStructure (EncodingSpec a)
forall a.
HasJsonEncodingSpec a =>
a -> JSONStructure (EncodingSpec a)
toJSONStructure ([a] -> [JStruct '[] (EncodingSpec a)])
-> (Set a -> [a]) -> Set a -> [JStruct '[] (EncodingSpec a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList
class StructureToJSON a where
reprToJSON :: a -> Value
instance StructureToJSON () where
reprToJSON :: () -> Value
reprToJSON () = [Pair] -> Value
A.object []
instance StructureToJSON Bool where
reprToJSON :: Bool -> Value
reprToJSON = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON
instance StructureToJSON Text where
reprToJSON :: Text -> Value
reprToJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON
instance StructureToJSON Scientific where
reprToJSON :: Scientific -> Value
reprToJSON = Scientific -> Value
forall a. ToJSON a => a -> Value
toJSON
instance StructureToJSON Int where
reprToJSON :: Int -> Value
reprToJSON = Int -> Value
forall a. ToJSON a => a -> Value
toJSON
instance (ToJSONObject (a, b)) => StructureToJSON (a, b) where
reprToJSON :: (a, b) -> Value
reprToJSON = Object -> Value
A.Object (Object -> Value) -> ((a, b) -> Object) -> (a, b) -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject
instance (StructureToJSON left, StructureToJSON right) => StructureToJSON (Either left right) where
reprToJSON :: Either left right -> Value
reprToJSON = \case
Left left
val -> left -> Value
forall a. StructureToJSON a => a -> Value
reprToJSON left
val
Right right
val -> right -> Value
forall a. StructureToJSON a => a -> Value
reprToJSON right
val
instance (KnownSymbol const) => StructureToJSON (Tag const) where
reprToJSON :: Tag const -> Value
reprToJSON Tag const
_proxy = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @const @Text)
instance (StructureToJSON a) => StructureToJSON [a] where
reprToJSON :: [a] -> Value
reprToJSON = [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value) -> ([a] -> [Value]) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value
forall a. StructureToJSON a => a -> Value
reprToJSON
instance StructureToJSON UTCTime where
reprToJSON :: UTCTime -> Value
reprToJSON = UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON
instance (StructureToJSON a) => StructureToJSON (Maybe a) where
reprToJSON :: Maybe a -> Value
reprToJSON = Value -> (a -> Value) -> Maybe a -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
A.Null a -> Value
forall a. StructureToJSON a => a -> Value
reprToJSON
instance
(StructureToJSON (JStruct ('(name, Rec env name spec) : env) spec))
=>
StructureToJSON (Rec env name spec)
where
reprToJSON :: Rec env name spec -> Value
reprToJSON = JStruct ('(name, Rec env name spec) : env) spec -> Value
forall a. StructureToJSON a => a -> Value
reprToJSON (JStruct ('(name, Rec env name spec) : env) spec -> Value)
-> (Rec env name spec
-> JStruct ('(name, Rec env name spec) : env) spec)
-> Rec env name spec
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec env name spec
-> JStruct ('(name, Rec env name spec) : env) spec
forall (env :: [(Symbol, *)]) (name :: Symbol)
(spec :: Specification).
Rec env name spec
-> JStruct ('(name, Rec env name spec) : env) spec
unRec
class ToJSONObject a where
toJSONObject :: a -> A.Object
instance ToJSONObject () where
toJSONObject :: () -> Object
toJSONObject ()
_ = Object
forall a. Monoid a => a
mempty
instance (KnownSymbol key, StructureToJSON val, ToJSONObject more) => ToJSONObject (Field key val, more) where
toJSONObject :: (Field key val, more) -> Object
toJSONObject (Field val
val, more
more) =
Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert
(forall (a :: Symbol) b. (IsString b, KnownSymbol a) => b
sym @key)
(val -> Value
forall a. StructureToJSON a => a -> Value
reprToJSON val
val)
(more -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject more
more)