{-# 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), Maybe(Just, Nothing),
  Monoid(mempty), (.), Bool, Int, 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 () 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


{- |
  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)