{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.JsonSpec.Encode (
  HasJsonEncodingSpec(..),
  StructureToJSON(..),
  encode,
) where


import Data.Aeson (ToJSON(toJSON), Value)
import Data.JsonSpec.Spec
  ( Field(Field), Ref(unRef), Specification(JsonArray), JSONStructure, JStruct
  , Tag, sym
  )
import Data.Proxy (Proxy(Proxy))
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), Maybe(Just, Nothing), Monoid(mempty)
  , (.), Bool, Int, id, maybe
  )
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Set as Set


{- |
  Types of this class can be encoded to JSON according to a type-level
  'Specification'.
-}
class HasJsonEncodingSpec a where
  {- | The encoding specification. -}
  type EncodingSpec a :: Specification

  {- | Encode the value into the structure appropriate for the 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


{- |
  This is like 'ToJSON', but specialized for our custom "json
  representation" types (i.e. the 'JSONStructure' type family). It is
  also closed (i.e. not exported, so the user can't add instances),
  because our json representation is closed.

  see 'StructureFromJSON' for an explaination about why we don't just use
  'ToJSON'.
-}
class StructureToJSON a where
  reprToJSON :: a -> Value
instance StructureToJSON Value where
  reprToJSON :: Value -> Value
reprToJSON = Value -> Value
forall a. a -> a
id
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 env spec))
  =>
    StructureToJSON (Ref env spec)
  where
    reprToJSON :: Ref env spec -> Value
reprToJSON = JStruct env spec -> Value
forall a. StructureToJSON a => a -> Value
reprToJSON (JStruct env spec -> Value)
-> (Ref env spec -> JStruct env spec) -> Ref env spec -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref env spec -> JStruct env spec
forall (env :: Env) (spec :: Specification).
Ref env spec -> JStruct env spec
unRef


{- |
  This class is to help 'StructureToJSON' recursively encode objects, and
  is mutually recursive with 'StructureToJSON'. If we tried to "recurse
  on the rest of the object" directly in 'StructureToJSON' we would end
  up with a partial function, because 'reprToJSON' returns a 'Value'
  not an 'Object'. We would therefore have to pattern match on 'Value'
  to get the 'Object' back out, but we would have to call 'error' if the
  'Value' mysteriously somehow wasn't an 'Object' after all. Instead of
  calling error because "it can't ever happen", we use this helper so
  the compiler can prove it never happens.
-}
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)
instance (KnownSymbol key, StructureToJSON val, ToJSONObject more) => ToJSONObject (Maybe (Field key val), more) where
  toJSONObject :: (Maybe (Field key val), more) -> Object
toJSONObject (Maybe (Field key val)
mval, more
more) =
    case Maybe (Field key val)
mval of
      Maybe (Field key val)
Nothing -> more -> Object
forall a. ToJSONObject a => a -> Object
toJSONObject more
more
      Just (Field val
val) ->
        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)


{-|
  Given a raw Haskell structure, directly encode it directly into an
  aeson Value without having to go through any To/FromJSON instances.

  See also: `Data.JsonSpec.eitherDecode`.
-}
encode :: StructureToJSON (JSONStructure spec) => Proxy spec -> JSONStructure spec -> Value
encode :: forall (spec :: Specification).
StructureToJSON (JSONStructure spec) =>
Proxy spec -> JSONStructure spec -> Value
encode Proxy spec
Proxy = JStruct '[] spec -> Value
JSONStructure spec -> Value
forall a. StructureToJSON a => a -> Value
reprToJSON