{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Jordan.ToJSON.Class where

import Data.Foldable (fold)
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Ratio as Ratio
import Data.Scientific
import qualified Data.Scientific as Sci
import qualified Data.Semigroup as Semi
import qualified Data.Set as Set
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Typeable (Proxy (..), TypeRep, Typeable, splitTyConApp, tyConModule, tyConName, typeRep, typeRepTyCon)
import Data.Void (Void, absurd)
import GHC.Generics
import GHC.TypeLits (KnownSymbol, symbolVal)
import Jordan.Generic.Options

-- | Basically just 'Data.Functor.Contravariant.Divisible.Decidable' but without
-- a superclass constraint that we cannot implement for JSON.
--
-- More specifically, we can quite easily serialize some object into either a string or a number
-- as a top-level JSON value, but we cannot serialize both a string and a number as a top level key.
-- This means that we cannot implement 'Data.Functor.Contravariant.Divisible', but we can implement
-- all the operations from 'Data.Functor.Contravariant.Divisible.Decidable'.
--
-- This class lets us decide without being able to divide, which is fun to say.
class (Contravariant f) => Selectable f where
  -- | Give up trying to decide.
  giveUp :: (arg -> Void) -> f arg

  -- | Pick one thing, or another, as long as you can serialize both options.
  select :: (arg -> Either lhs rhs) -> f lhs -> f rhs -> f arg

selected :: (Selectable f) => f lhs -> f rhs -> f (Either lhs rhs)
selected :: f lhs -> f rhs -> f (Either lhs rhs)
selected = (Either lhs rhs -> Either lhs rhs)
-> f lhs -> f rhs -> f (Either lhs rhs)
forall (f :: * -> *) arg lhs rhs.
Selectable f =>
(arg -> Either lhs rhs) -> f lhs -> f rhs -> f arg
select Either lhs rhs -> Either lhs rhs
forall a. a -> a
id

-- | An abstract representation of how to serialize a JSON object.
-- Since serializing is the exact opposite of parsing, we have to be
-- 'Data.Functor.Contravariant.Decidable' instead of 'Control.Applicative.Alternative'.
--
-- That is, if we are serializing a JSON object, we need to be able to break things apart.
--
-- Unfortunately the combinators for breaking things apart are more annoying to use than
-- the combinators for putting things together, and involve a lot of tuples everywhere.
--
-- Thankfully we provide a good interface to derive these classes generically!
class (Divisible f, Representational f) => JSONObjectSerializer f where
  serializeFieldWith ::
    -- | Label for the field to serialize
    Text ->
    -- | How to serialize the field.
    -- The forall ensures that JSON serialization is kept completely abstract.
    -- You can only use the methods of 'JSONSerializer' here.
    (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) ->
    f a
  serializeField :: (ToJSON a) => Text -> f a
  serializeField Text
t = Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
serializeFieldWith Text
t forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
toJSON
  serializeDescribeFieldWith ::
    -- | Field key to serialize.
    Text ->
    -- | Field description.
    Text ->
    -- | Serializer for the field.
    (forall valueSerializer. JSONSerializer valueSerializer => valueSerializer a) ->
    f a
  serializeDescribeFieldWith Text
t Text
_ = Text
-> (forall (valueSerializer :: * -> *).
    JSONSerializer valueSerializer =>
    valueSerializer a)
-> f a
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
serializeFieldWith Text
t

  -- | Write if we have Just a value. Do not add the field otherwise.
  serializeJust ::
    -- | Label for the field to serialize
    Text ->
    -- | Serializer for Just
    (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) ->
    f (Maybe a)

class (Divisible f, Representational f) => JSONTupleSerializer f where
  serializeItemWith ::
    -- | Write a single item into the tuple.
    -- The forall keeps things abstract.
    (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) ->
    f a
  serializeItem ::
    (ToJSON a) => f a
  serializeItem = (forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> f a
forall (f :: * -> *) a.
JSONTupleSerializer f =>
(forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> f a
serializeItemWith forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
toJSON

-- | An abstract representation of how to serialize a Haskell value into JSON.
class (Selectable f, Representational f) => JSONSerializer f where
  serializeObject ::
    -- | How to serialize the object.
    -- The forall here keeps things abstract: you are only allowed to use the methods of 'JSONObjectSerializer' here.
    (forall objSerializer. JSONObjectSerializer objSerializer => objSerializer a) ->
    f a
  serializeDictionary ::
    (Foldable t) =>
    (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a) ->
    f (t (Text, a))
  serializeText ::
    f Text

  -- | Serialize some text constant.
  -- Note that this returns a serializer of anything: if you are always going to serialize out the same string,
  -- we don't need to even look at the thing we\'re serializing!
  serializeTextConstant ::
    Text ->
    f a

  serializeNull ::
    f any
  serializeNumber ::
    f Scientific
  serializeBool ::
    f Bool
  serializeTuple ::
    (forall tupleSerializer. JSONTupleSerializer tupleSerializer => tupleSerializer a) ->
    f a
  serializeArray ::
    (ToJSON a) =>
    f [a]

  -- | Give a name to a serializer.
  -- Should be globally unique, if possible.
  nameSerializer ::
    Text ->
    f a ->
    f a
  nameSerializer Text
_ f a
a = f a
a

-- | A class to provide the canonical way to encode a JSON.
--
-- This class uses finally tagless style to keep the instructions for serializing abstract.
-- This allows us to automatically generate documentation, and to generate serializers that always avoid the need for intermediate structures.
--
-- This class is derivable generically, and will generate a \"nice\" format.
-- In my opinion, at least.
--
-- If you want to customize this JSON, the newtype 'WithOptions' can be helpful, as it allows you to specify options for the generic serialization.
-- Unfortunately, due to a weird GHC quirk, you need to use it with @ -XStandaloneDeriving @ as well as @ -XDerivingVia @.
-- That is, you should write:
--
--
-- @
-- data PersonFilter = PersonFilter { filterFirstName :: Maybe Text, filterLastName :: Maybe Text }
--   deriving (Show, Read, Eq, Ord, Generic)
--
-- deriving via (WithOptions '[KeepNothingFields] PersonFilter) instance (ToJSON PersonFilter)
-- @

---- === __Laws__
--
-- This instance is lawless, unless 'Jordan.FromJSON.Class.FromJSON' is also defined for this type.
-- In that case, the representation serialized by 'ToJSON' should match that of the representation parsed by
-- 'Jordan.FromJSON.Class.FromJSON'.
class ToJSON v where
  toJSON :: (forall f. (JSONSerializer f) => f v)
  default toJSON :: (Generic v, GToJSON (Rep v), Typeable v) => (JSONSerializer f) => f v
  toJSON = (v -> Rep v Any) -> f (Rep v Any) -> f v
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap v -> Rep v Any
forall a x. Generic a => a -> Rep a x
from (f (Rep v Any) -> f v) -> f (Rep v Any) -> f v
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> f (Rep v Any)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
defaultToJSONOptions {toJSONBaseName :: String
toJSONBaseName = String
fq}
    where
      fq :: String
fq = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TypeRep -> Text
fullyQualifyName (TypeRep -> Text) -> TypeRep -> Text
forall a b. (a -> b) -> a -> b
$ Proxy v -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy v
forall k (t :: k). Proxy t
Proxy :: Proxy v)

instance (Generic a, GToJSON (Rep a), Typeable a, SpecifiesToJSONOptions options) => ToJSON (WithOptions options a) where
  toJSON :: f (WithOptions options a)
toJSON = (WithOptions options a -> a) -> f a -> f (WithOptions options a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap WithOptions options a -> a
forall (options :: [*]) a. WithOptions options a -> a
getWithOptions (f a -> f (WithOptions options a))
-> (f (Rep a Any) -> f a)
-> f (Rep a Any)
-> f (WithOptions options a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Rep a Any) -> f (Rep a Any) -> f a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from (f (Rep a Any) -> f (WithOptions options a))
-> f (Rep a Any) -> f (WithOptions options a)
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> f (Rep a Any)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON (SpecifiesToJSONOptions options => ToJSONOptions
forall (a :: [*]). SpecifiesToJSONOptions a => ToJSONOptions
specifiedToJSONOptions @options) {toJSONBaseName :: String
toJSONBaseName = String
fq}
    where
      fq :: String
fq = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TypeRep -> Text
fullyQualifyName (TypeRep -> Text) -> TypeRep -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

instance ToJSON () where
  toJSON :: f ()
toJSON = f ()
forall (f :: * -> *) any. JSONSerializer f => f any
serializeNull

instance ToJSON Text where
  toJSON :: f Text
toJSON = f Text
forall (f :: * -> *). JSONSerializer f => f Text
serializeText

instance ToJSON Scientific where
  toJSON :: f Scientific
toJSON = f Scientific
forall (f :: * -> *). JSONSerializer f => f Scientific
serializeNumber

instance {-# OVERLAPPABLE #-} (ToJSON a) => ToJSON [a] where
  toJSON :: f [a]
toJSON = f [a]
forall (f :: * -> *) a. (JSONSerializer f, ToJSON a) => f [a]
serializeArray

-- | Nothings get serialized as null.
instance (ToJSON a) => ToJSON (Maybe a) where
  toJSON :: f (Maybe a)
toJSON = (Maybe a -> Either () a) -> f () -> f a -> f (Maybe a)
forall (f :: * -> *) arg lhs rhs.
Selectable f =>
(arg -> Either lhs rhs) -> f lhs -> f rhs -> f arg
select Maybe a -> Either () a
forall b. Maybe b -> Either () b
find f ()
forall (f :: * -> *) any. JSONSerializer f => f any
serializeNull f a
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON
    where
      find :: Maybe b -> Either () b
find Maybe b
Nothing = () -> Either () b
forall a b. a -> Either a b
Left ()
      find (Just b
a) = b -> Either () b
forall a b. b -> Either a b
Right b
a

instance (ToJSON lhs, ToJSON rhs) => ToJSON (Either lhs rhs) where
  toJSON :: f (Either lhs rhs)
toJSON = (Either lhs rhs -> Either lhs rhs)
-> f lhs -> f rhs -> f (Either lhs rhs)
forall (f :: * -> *) arg lhs rhs.
Selectable f =>
(arg -> Either lhs rhs) -> f lhs -> f rhs -> f arg
select Either lhs rhs -> Either lhs rhs
forall a. a -> a
id f lhs
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON f rhs
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

instance ToJSON Bool where
  toJSON :: f Bool
toJSON = f Bool
forall (f :: * -> *). JSONSerializer f => f Bool
serializeBool

instance ToJSON Int where
  toJSON :: f Int
toJSON = (Int -> Scientific) -> f Scientific -> f Int
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral f Scientific
forall (f :: * -> *). JSONSerializer f => f Scientific
serializeNumber

instance ToJSON Integer where
  toJSON :: f Integer
toJSON = (Integer -> Scientific) -> f Scientific -> f Integer
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger f Scientific
forall (f :: * -> *). JSONSerializer f => f Scientific
serializeNumber

instance ToJSON Float where
  toJSON :: f Float
toJSON = (Float -> Scientific) -> f Scientific -> f Float
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Float -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac f Scientific
forall (f :: * -> *). JSONSerializer f => f Scientific
serializeNumber

instance ToJSON Double where
  toJSON :: f Double
toJSON = (Double -> Scientific) -> f Scientific -> f Double
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Double -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac f Scientific
forall (f :: * -> *). JSONSerializer f => f Scientific
serializeNumber

instance {-# OVERLAPPING #-} ToJSON String where
  toJSON :: f String
toJSON = (String -> Text) -> f Text -> f String
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap String -> Text
T.pack f Text
forall (f :: * -> *). JSONSerializer f => f Text
serializeText

instance forall a. (ToJSON a, Typeable a) => ToJSON (Ratio.Ratio a) where
  toJSON :: f (Ratio a)
toJSON =
    (forall (objSerializer :: * -> *).
 JSONObjectSerializer objSerializer =>
 objSerializer (Ratio a))
-> f (Ratio a)
forall (f :: * -> *) a.
JSONSerializer f =>
(forall (objSerializer :: * -> *).
 JSONObjectSerializer objSerializer =>
 objSerializer a)
-> f a
serializeObject ((forall (objSerializer :: * -> *).
  JSONObjectSerializer objSerializer =>
  objSerializer (Ratio a))
 -> f (Ratio a))
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer (Ratio a))
-> f (Ratio a)
forall a b. (a -> b) -> a -> b
$
      (Ratio a -> (a, a))
-> objSerializer a -> objSerializer a -> objSerializer (Ratio a)
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide Ratio a -> (a, a)
divider (Text -> objSerializer a
forall (f :: * -> *) a.
(JSONObjectSerializer f, ToJSON a) =>
Text -> f a
serializeField Text
"num") (Text -> objSerializer a
forall (f :: * -> *) a.
(JSONObjectSerializer f, ToJSON a) =>
Text -> f a
serializeField Text
"denom")
    where
      divider :: Ratio.Ratio a -> (a, a)
      divider :: Ratio a -> (a, a)
divider = (,) (a -> a -> (a, a)) -> (Ratio a -> a) -> Ratio a -> a -> (a, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ratio a -> a
forall a. Ratio a -> a
Ratio.numerator (Ratio a -> a -> (a, a)) -> (Ratio a -> a) -> Ratio a -> (a, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ratio a -> a
forall a. Ratio a -> a
Ratio.denominator
      objName :: Text
objName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
tyName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".Ratio"
      tyName :: String
tyName = (TyCon -> String
tyConModule (TyCon -> String) -> (TyCon -> String) -> TyCon -> String
forall a. Semigroup a => a -> a -> a
<> String -> TyCon -> String
forall a b. a -> b -> a
const String
"." (TyCon -> String) -> (TyCon -> String) -> TyCon -> String
forall a. Semigroup a => a -> a -> a
<> TyCon -> String
tyConName) (TyCon -> String) -> TyCon -> String
forall a b. (a -> b) -> a -> b
$ TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

instance (ToJSON a) => ToJSON (Semi.Min a) where
  toJSON :: f (Min a)
toJSON = (Min a -> a) -> f a -> f (Min a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Min a -> a
forall a. Min a -> a
Semi.getMin f a
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

instance (ToJSON a) => ToJSON (Semi.Max a) where
  toJSON :: f (Max a)
toJSON = (Max a -> a) -> f a -> f (Max a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Max a -> a
forall a. Max a -> a
Semi.getMax f a
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

instance (ToJSON a) => ToJSON (Semi.First a) where
  toJSON :: f (First a)
toJSON = (First a -> a) -> f a -> f (First a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap First a -> a
forall a. First a -> a
Semi.getFirst f a
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

instance (ToJSON a) => ToJSON (Semi.Last a) where
  toJSON :: f (Last a)
toJSON = (Last a -> a) -> f a -> f (Last a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Last a -> a
forall a. Last a -> a
Semi.getLast f a
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

instance (ToJSON a) => ToJSON (Semi.Dual a) where
  toJSON :: f (Dual a)
toJSON = (Dual a -> a) -> f a -> f (Dual a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Dual a -> a
forall a. Dual a -> a
Semi.getDual f a
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

instance ToJSON Semi.All where
  toJSON :: f All
toJSON = (All -> Bool) -> f Bool -> f All
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap All -> Bool
Semi.getAll f Bool
forall (f :: * -> *). JSONSerializer f => f Bool
serializeBool

instance ToJSON Semi.Any where
  toJSON :: f Any
toJSON = (Any -> Bool) -> f Bool -> f Any
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Any -> Bool
Semi.getAny f Bool
forall (f :: * -> *). JSONSerializer f => f Bool
serializeBool

instance (ToJSON a) => ToJSON (Semi.Sum a) where
  toJSON :: f (Sum a)
toJSON = (Sum a -> a) -> f a -> f (Sum a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Sum a -> a
forall a. Sum a -> a
Semi.getSum f a
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

instance (ToJSON a) => ToJSON (Semi.Product a) where
  toJSON :: f (Product a)
toJSON = (Product a -> a) -> f a -> f (Product a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Product a -> a
forall a. Product a -> a
Semi.getProduct f a
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

instance (ToJSON a) => ToJSON (Map.Map Text a) where
  toJSON :: f (Map Text a)
toJSON = (Map Text a -> [(Text, a)]) -> f [(Text, a)] -> f (Map Text a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Map Text a -> [(Text, a)]
forall k a. Map k a -> [(k, a)]
Map.toList (f [(Text, a)] -> f (Map Text a))
-> f [(Text, a)] -> f (Map Text a)
forall a b. (a -> b) -> a -> b
$ (forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> f [(Text, a)]
forall (f :: * -> *) (t :: * -> *) a.
(JSONSerializer f, Foldable t) =>
(forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> f (t (Text, a))
serializeDictionary forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
toJSON

instance (ToJSON a) => ToJSON (Map.Map Integer a) where
  toJSON :: f (Map Integer a)
toJSON = (Map Integer a -> [(Text, a)])
-> f [(Text, a)] -> f (Map Integer a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (((Integer, a) -> (Text, a)) -> [(Integer, a)] -> [(Text, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer, a) -> (Text, a)
forall a b. Show a => (a, b) -> (Text, b)
toTextKey ([(Integer, a)] -> [(Text, a)])
-> (Map Integer a -> [(Integer, a)])
-> Map Integer a
-> [(Text, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Integer a -> [(Integer, a)]
forall k a. Map k a -> [(k, a)]
Map.toList) (f [(Text, a)] -> f (Map Integer a))
-> f [(Text, a)] -> f (Map Integer a)
forall a b. (a -> b) -> a -> b
$ (forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> f [(Text, a)]
forall (f :: * -> *) (t :: * -> *) a.
(JSONSerializer f, Foldable t) =>
(forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> f (t (Text, a))
serializeDictionary forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
toJSON
    where
      toTextKey :: (a, b) -> (Text, b)
toTextKey (a
key, b
value) = (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
key, b
value)

instance (ToJSON a) => ToJSON (NE.NonEmpty a) where
  toJSON :: f (NonEmpty a)
toJSON = (NonEmpty a -> [a]) -> f [a] -> f (NonEmpty a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList f [a]
forall (f :: * -> *) a. (JSONSerializer f, ToJSON a) => f [a]
serializeArray

instance (ToJSON a) => ToJSON (Set.Set a) where
  toJSON :: f (Set a)
toJSON = (Set a -> [a]) -> f [a] -> f (Set a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap Set a -> [a]
forall a. Set a -> [a]
Set.toList f [a]
forall (f :: * -> *) a. (JSONSerializer f, ToJSON a) => f [a]
serializeArray

data ToJSONOptions = ToJSONOptions
  { ToJSONOptions -> SumTypeEncoding
toJSONEncodeSums :: SumTypeEncoding,
    ToJSONOptions -> String
toJSONBaseName :: String,
    ToJSONOptions -> String -> String
toJSONRenderEnum :: String -> String,
    ToJSONOptions -> Bool
toJSONOmitNothingFields :: Bool
  }

defaultToJSONOptions :: ToJSONOptions
defaultToJSONOptions :: ToJSONOptions
defaultToJSONOptions =
  SumTypeEncoding
-> String -> (String -> String) -> Bool -> ToJSONOptions
ToJSONOptions SumTypeEncoding
TagInField String
"" String -> String
forall a. a -> a
id Bool
True

class SpecifiesToJSONOptions (a :: [*]) where
  specifiedToJSONOptions :: ToJSONOptions

instance SpecifiesToJSONOptions '[] where
  specifiedToJSONOptions :: ToJSONOptions
specifiedToJSONOptions = ToJSONOptions
defaultToJSONOptions

instance
  (SpecifiesToJSONOptions xs) =>
  SpecifiesToJSONOptions (OmitNothingFields ': xs)
  where
  specifiedToJSONOptions :: ToJSONOptions
specifiedToJSONOptions = (SpecifiesToJSONOptions xs => ToJSONOptions
forall (a :: [*]). SpecifiesToJSONOptions a => ToJSONOptions
specifiedToJSONOptions @xs) {toJSONOmitNothingFields :: Bool
toJSONOmitNothingFields = Bool
True}

instance
  (SpecifiesToJSONOptions xs) =>
  SpecifiesToJSONOptions (KeepNothingFields ': xs)
  where
  specifiedToJSONOptions :: ToJSONOptions
specifiedToJSONOptions =
    (SpecifiesToJSONOptions xs => ToJSONOptions
forall (a :: [*]). SpecifiesToJSONOptions a => ToJSONOptions
specifiedToJSONOptions @xs) {toJSONOmitNothingFields :: Bool
toJSONOmitNothingFields = Bool
False}

class GToJSON v where
  gToJSON :: (JSONSerializer s) => ToJSONOptions -> s (v a)

-- | Top-level metadata is ignored.
instance (ToJSON c) => GToJSON (K1 i c) where
  gToJSON :: ToJSONOptions -> s (K1 i c a)
gToJSON ToJSONOptions
_ = (K1 i c a -> c) -> s c -> s (K1 i c a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(K1 c
a) -> c
a) s c
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

-- | Datatype metadata: we name the overall datatype with the baseName
-- passed in the options, then serialize the inner information.
instance (GToJSON f, Datatype t) => GToJSON (D1 t f) where
  gToJSON :: ToJSONOptions -> s (D1 t f a)
gToJSON ToJSONOptions
opts = Text -> s (D1 t f a) -> s (D1 t f a)
forall (f :: * -> *) a. JSONSerializer f => Text -> f a -> f a
nameSerializer (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> String
toJSONBaseName ToJSONOptions
opts) (s (D1 t f a) -> s (D1 t f a)) -> s (D1 t f a) -> s (D1 t f a)
forall a b. (a -> b) -> a -> b
$ (D1 t f a -> f a) -> s (f a) -> s (D1 t f a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(M1 f a
a) -> f a
a) (s (f a) -> s (D1 t f a)) -> s (f a) -> s (D1 t f a)
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> s (f a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
opts

-- | Serialize out a no-argument constructor via a string value of its name.
-- This allows us to serialize out enum keys more easily.
--
-- This does not get a unique name as recursion cannot happen.
instance {-# OVERLAPS #-} (KnownSymbol name) => GToJSON (C1 (MetaCons name fixity 'False) U1) where
  gToJSON :: ToJSONOptions -> s (C1 ('MetaCons name fixity 'False) U1 a)
gToJSON ToJSONOptions
opts =
    Text -> s (C1 ('MetaCons name fixity 'False) U1 a)
forall (f :: * -> *) a. JSONSerializer f => Text -> f a
serializeTextConstant (String -> Text
T.pack String
connNameS)
    where
      connNameS :: String
connNameS = Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name)

instance {-# OVERLAPS #-} (KnownSymbol name) => GToJSON (PartOfSum (C1 (MetaCons name fixity 'False) U1)) where
  gToJSON :: ToJSONOptions
-> s (PartOfSum (C1 ('MetaCons name fixity 'False) U1) a)
gToJSON = (PartOfSum (C1 ('MetaCons name fixity 'False) U1) a
 -> C1 ('MetaCons name fixity 'False) U1 a)
-> s (C1 ('MetaCons name fixity 'False) U1 a)
-> s (PartOfSum (C1 ('MetaCons name fixity 'False) U1) a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap PartOfSum (C1 ('MetaCons name fixity 'False) U1) a
-> C1 ('MetaCons name fixity 'False) U1 a
forall (f :: * -> *) a. PartOfSum f a -> f a
getPartOfSum (s (C1 ('MetaCons name fixity 'False) U1 a)
 -> s (PartOfSum (C1 ('MetaCons name fixity 'False) U1) a))
-> (ToJSONOptions -> s (C1 ('MetaCons name fixity 'False) U1 a))
-> ToJSONOptions
-> s (PartOfSum (C1 ('MetaCons name fixity 'False) U1) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToJSONOptions -> s (C1 ('MetaCons name fixity 'False) U1 a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON

-- | IF we have a constructor with arguments, but not selectors, then
-- we serialize as a tuple.
instance {-# OVERLAPPABLE #-} (GToJSONTuple inner, Constructor (MetaCons n s 'False)) => GToJSON (C1 (MetaCons n s 'False) inner) where
  gToJSON :: ToJSONOptions -> s (C1 ('MetaCons n s 'False) inner a)
gToJSON ToJSONOptions
opts =
    (C1 ('MetaCons n s 'False) inner a -> inner a)
-> s (inner a) -> s (C1 ('MetaCons n s 'False) inner a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(M1 inner a
a) -> inner a
a) (s (inner a) -> s (C1 ('MetaCons n s 'False) inner a))
-> s (inner a) -> s (C1 ('MetaCons n s 'False) inner a)
forall a b. (a -> b) -> a -> b
$
      (forall (tupleSerializer :: * -> *).
 JSONTupleSerializer tupleSerializer =>
 tupleSerializer (inner a))
-> s (inner a)
forall (f :: * -> *) a.
JSONSerializer f =>
(forall (tupleSerializer :: * -> *).
 JSONTupleSerializer tupleSerializer =>
 tupleSerializer a)
-> f a
serializeTuple ((forall (tupleSerializer :: * -> *).
  JSONTupleSerializer tupleSerializer =>
  tupleSerializer (inner a))
 -> s (inner a))
-> (forall (tupleSerializer :: * -> *).
    JSONTupleSerializer tupleSerializer =>
    tupleSerializer (inner a))
-> s (inner a)
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> tupleSerializer (inner a)
forall (v :: * -> *) (f :: * -> *) a.
(GToJSONTuple v, JSONTupleSerializer f) =>
ToJSONOptions -> f (v a)
gToJSONTuple ToJSONOptions
opts

-- | If we have a constructor with arguments AND selectors (IE, a record), then
-- we serialize out a JSON object.
instance {-# OVERLAPPABLE #-} (GToJSONObject inner, Constructor (MetaCons n s 'True)) => GToJSON (C1 (MetaCons n s 'True) inner) where
  gToJSON :: ToJSONOptions -> s (C1 ('MetaCons n s 'True) inner a)
gToJSON ToJSONOptions
opts =
    (C1 ('MetaCons n s 'True) inner a -> inner a)
-> s (inner a) -> s (C1 ('MetaCons n s 'True) inner a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(M1 inner a
a) -> inner a
a) (s (inner a) -> s (C1 ('MetaCons n s 'True) inner a))
-> s (inner a) -> s (C1 ('MetaCons n s 'True) inner a)
forall a b. (a -> b) -> a -> b
$
      (forall (objSerializer :: * -> *).
 JSONObjectSerializer objSerializer =>
 objSerializer (inner a))
-> s (inner a)
forall (f :: * -> *) a.
JSONSerializer f =>
(forall (objSerializer :: * -> *).
 JSONObjectSerializer objSerializer =>
 objSerializer a)
-> f a
serializeObject ((forall (objSerializer :: * -> *).
  JSONObjectSerializer objSerializer =>
  objSerializer (inner a))
 -> s (inner a))
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer (inner a))
-> s (inner a)
forall a b. (a -> b) -> a -> b
$
        ToJSONOptions -> objSerializer (inner a)
forall (v :: * -> *) (f :: * -> *) a.
(GToJSONObject v, JSONObjectSerializer f) =>
ToJSONOptions -> f (v a)
gToJSONObject ToJSONOptions
opts
    where
      name :: Text
name = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> String
toJSONBaseName ToJSONOptions
opts String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> M1 C ('MetaCons n s 'True) inner Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (forall a. M1 C ('MetaCons n s 'True) inner a
forall a. HasCallStack => a
undefined :: C1 (MetaCons n s 'True) inner a)

-- | If we have a single-argument constructor with no selectors, we want to just parse it directly.
instance {-# OVERLAPS #-} (ToJSON i) => GToJSON (C1 (MetaCons n s 'False) (S1 (MetaSel 'Nothing su ss ds) (Rec0 i))) where
  gToJSON :: ToJSONOptions
-> s (C1
        ('MetaCons n s 'False)
        (S1 ('MetaSel 'Nothing su ss ds) (Rec0 i))
        a)
gToJSON ToJSONOptions
_ = (C1
   ('MetaCons n s 'False) (S1 ('MetaSel 'Nothing su ss ds) (Rec0 i)) a
 -> i)
-> s i
-> s (C1
        ('MetaCons n s 'False)
        (S1 ('MetaSel 'Nothing su ss ds) (Rec0 i))
        a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(M1 (M1 (K1 i
s))) -> i
s) s i
forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
toJSON

-- | When rendering a sum type, and this is NOT an enum value, render via
-- the sum encoding option the user provided.
instance {-# OVERLAPPABLE #-} (Constructor t, GToJSON (C1 t f)) => GToJSON (PartOfSum (C1 t f)) where
  gToJSON :: ToJSONOptions -> s (PartOfSum (C1 t f) a)
gToJSON ToJSONOptions
opts = (PartOfSum (C1 t f) a -> C1 t f a)
-> s (C1 t f a) -> s (PartOfSum (C1 t f) a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap PartOfSum (C1 t f) a -> C1 t f a
forall (f :: * -> *) a. PartOfSum f a -> f a
getPartOfSum s (C1 t f a)
encoded
    where
      encoded :: s (C1 t f a)
encoded = case ToJSONOptions -> SumTypeEncoding
toJSONEncodeSums ToJSONOptions
opts of
        SumTypeEncoding
TagVal -> s (C1 t f a)
tagged
        SumTypeEncoding
TagInField -> s (C1 t f a)
field
      field :: s (C1 t f a)
field =
        (forall (objSerializer :: * -> *).
 JSONObjectSerializer objSerializer =>
 objSerializer (C1 t f a))
-> s (C1 t f a)
forall (f :: * -> *) a.
JSONSerializer f =>
(forall (objSerializer :: * -> *).
 JSONObjectSerializer objSerializer =>
 objSerializer a)
-> f a
serializeObject ((forall (objSerializer :: * -> *).
  JSONObjectSerializer objSerializer =>
  objSerializer (C1 t f a))
 -> s (C1 t f a))
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer (C1 t f a))
-> s (C1 t f a)
forall a b. (a -> b) -> a -> b
$
          Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer (C1 t f a))
-> objSerializer (C1 t f a)
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
serializeFieldWith Text
cn (ToJSONOptions -> jsonSerializer (C1 t f a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
opts)
      tagged :: s (C1 t f a)
tagged =
        (forall (objSerializer :: * -> *).
 JSONObjectSerializer objSerializer =>
 objSerializer (C1 t f a))
-> s (C1 t f a)
forall (f :: * -> *) a.
JSONSerializer f =>
(forall (objSerializer :: * -> *).
 JSONObjectSerializer objSerializer =>
 objSerializer a)
-> f a
serializeObject ((forall (objSerializer :: * -> *).
  JSONObjectSerializer objSerializer =>
  objSerializer (C1 t f a))
 -> s (C1 t f a))
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer (C1 t f a))
-> s (C1 t f a)
forall a b. (a -> b) -> a -> b
$
          (C1 t f a -> ((), C1 t f a))
-> objSerializer ((), C1 t f a) -> objSerializer (C1 t f a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((),) (objSerializer ((), C1 t f a) -> objSerializer (C1 t f a))
-> objSerializer ((), C1 t f a) -> objSerializer (C1 t f a)
forall a b. (a -> b) -> a -> b
$
            objSerializer ()
-> objSerializer (C1 t f a) -> objSerializer ((), C1 t f a)
forall (f :: * -> *) a b. Divisible f => f a -> f b -> f (a, b)
divided
              (Text
-> (forall (f :: * -> *). JSONSerializer f => f ())
-> objSerializer ()
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
serializeFieldWith Text
"key" ((forall (f :: * -> *). JSONSerializer f => f ())
 -> objSerializer ())
-> (forall (f :: * -> *). JSONSerializer f => f ())
-> objSerializer ()
forall a b. (a -> b) -> a -> b
$ Text -> jsonSerializer ()
forall (f :: * -> *) a. JSONSerializer f => Text -> f a
serializeTextConstant Text
cn)
              (Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer (C1 t f a))
-> objSerializer (C1 t f a)
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
serializeFieldWith Text
"value" ((forall (jsonSerializer :: * -> *).
  JSONSerializer jsonSerializer =>
  jsonSerializer (C1 t f a))
 -> objSerializer (C1 t f a))
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer (C1 t f a))
-> objSerializer (C1 t f a)
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> jsonSerializer (C1 t f a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
opts)
      objName :: Text
objName = String -> Text
T.pack (ToJSONOptions -> String
toJSONBaseName ToJSONOptions
opts) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cn Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".Output"
      cn :: Text
cn = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 C t f Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (forall a. M1 C t f a
forall a. HasCallStack => a
undefined :: C1 t f a)

sumToEither :: (l :+: r) a -> Either (l a) (r a)
sumToEither :: (:+:) l r a -> Either (l a) (r a)
sumToEither (:+:) l r a
f = case (:+:) l r a
f of
  L1 l a
a -> l a -> Either (l a) (r a)
forall a b. a -> Either a b
Left l a
a
  R1 r a
a -> r a -> Either (l a) (r a)
forall a b. b -> Either a b
Right r a
a

-- | If we can serialize out both sides of a sum-type, we can serialize out the sum type.
instance forall l r. (GToJSON (PartOfSum l), GToJSON (PartOfSum r)) => GToJSON (l :+: r) where
  gToJSON :: forall f a. (JSONSerializer f) => ToJSONOptions -> f ((l :+: r) a)
  gToJSON :: ToJSONOptions -> f ((:+:) l r a)
gToJSON ToJSONOptions
opts =
    ((:+:) l r a -> Either (l a) (r a))
-> f (l a) -> f (r a) -> f ((:+:) l r a)
forall (f :: * -> *) arg lhs rhs.
Selectable f =>
(arg -> Either lhs rhs) -> f lhs -> f rhs -> f arg
select
      (:+:) l r a -> Either (l a) (r a)
forall (l :: * -> *) (r :: * -> *) a.
(:+:) l r a -> Either (l a) (r a)
sumToEither
      ((l a -> PartOfSum l a) -> f (PartOfSum l a) -> f (l a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap l a -> PartOfSum l a
forall (f :: * -> *) a. f a -> PartOfSum f a
MkPartOfSum (f (PartOfSum l a) -> f (l a)) -> f (PartOfSum l a) -> f (l a)
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> f (PartOfSum l a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
opts)
      ((r a -> PartOfSum r a) -> f (PartOfSum r a) -> f (r a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap r a -> PartOfSum r a
forall (f :: * -> *) a. f a -> PartOfSum f a
MkPartOfSum (f (PartOfSum r a) -> f (r a)) -> f (PartOfSum r a) -> f (r a)
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> f (PartOfSum r a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
opts)

instance (GToJSON (PartOfSum l), GToJSON (PartOfSum r)) => GToJSON (PartOfSum (l :+: r)) where
  gToJSON :: ToJSONOptions -> s (PartOfSum (l :+: r) a)
gToJSON ToJSONOptions
opts = (PartOfSum (l :+: r) a -> (:+:) l r a)
-> s ((:+:) l r a) -> s (PartOfSum (l :+: r) a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap PartOfSum (l :+: r) a -> (:+:) l r a
forall (f :: * -> *) a. PartOfSum f a -> f a
getPartOfSum (ToJSONOptions -> s ((:+:) l r a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
opts)

instance GToJSON V1 where
  gToJSON :: ToJSONOptions -> s (V1 a)
gToJSON ToJSONOptions
_ = (V1 a -> Void) -> s (V1 a)
forall (f :: * -> *) arg. Selectable f => (arg -> Void) -> f arg
giveUp (String -> V1 a -> Void
forall a. HasCallStack => String -> a
error String
"how the hell did you construct a void data type?")

-- | Type class for generically converting to a JSON object.
-- We can do this if all the fields under a constructor are named.
class GToJSONObject v where
  gToJSONObject :: (JSONObjectSerializer f) => ToJSONOptions -> f (v a)

instance {-# OVERLAPPABLE #-} (GToJSON f, KnownSymbol selector) => GToJSONObject (S1 (MetaSel (Just selector) su ss ds) f) where
  gToJSONObject :: ToJSONOptions -> f (S1 ('MetaSel ('Just selector) su ss ds) f a)
gToJSONObject ToJSONOptions
o =
    (S1 ('MetaSel ('Just selector) su ss ds) f a -> f a)
-> f (f a) -> f (S1 ('MetaSel ('Just selector) su ss ds) f a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(M1 f a
a) -> f a
a) (f (f a) -> f (S1 ('MetaSel ('Just selector) su ss ds) f a))
-> f (f a) -> f (S1 ('MetaSel ('Just selector) su ss ds) f a)
forall a b. (a -> b) -> a -> b
$
      Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer (f a))
-> f (f a)
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
serializeFieldWith (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy selector -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy selector
forall k (t :: k). Proxy t
Proxy :: Proxy selector)) (ToJSONOptions -> jsonSerializer (f a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
o)

instance {-# OVERLAPS #-} (ToJSON a, KnownSymbol selector) => GToJSONObject (S1 (MetaSel (Just selector) su ss ds) (Rec0 (Maybe a))) where
  gToJSONObject :: ToJSONOptions
-> f (S1 ('MetaSel ('Just selector) su ss ds) (Rec0 (Maybe a)) a)
gToJSONObject ToJSONOptions
o = (S1 ('MetaSel ('Just selector) su ss ds) (Rec0 (Maybe a)) a
 -> Maybe a)
-> f (Maybe a)
-> f (S1 ('MetaSel ('Just selector) su ss ds) (Rec0 (Maybe a)) a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap S1 ('MetaSel ('Just selector) su ss ds) (Rec0 (Maybe a)) a
-> Maybe a
forall i (c :: Meta) i c p. M1 i c (K1 i c) p -> c
map f (Maybe a)
fieldWriter
    where
      fieldWriter :: f (Maybe a)
fieldWriter
        | ToJSONOptions -> Bool
toJSONOmitNothingFields ToJSONOptions
o = Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f (Maybe a)
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f (Maybe a)
serializeJust Text
name forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
toJSON
        | Bool
otherwise = Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer (Maybe a))
-> f (Maybe a)
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
serializeFieldWith Text
name forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer (Maybe a)
toJSON
      map :: M1 i c (K1 i c) p -> c
map (M1 (K1 c
a)) = c
a
      name :: Text
name = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy selector -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy selector
forall k (t :: k). Proxy t
Proxy :: Proxy selector)

instance (GToJSONObject lhs, GToJSONObject rhs) => GToJSONObject (lhs :*: rhs) where
  gToJSONObject :: ToJSONOptions -> f ((:*:) lhs rhs a)
gToJSONObject ToJSONOptions
o = ((:*:) lhs rhs a -> (lhs a, rhs a))
-> f (lhs a) -> f (rhs a) -> f ((:*:) lhs rhs a)
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (:*:) lhs rhs a -> (lhs a, rhs a)
forall (f :: * -> *) (g :: * -> *) p. (:*:) f g p -> (f p, g p)
div (ToJSONOptions -> f (lhs a)
forall (v :: * -> *) (f :: * -> *) a.
(GToJSONObject v, JSONObjectSerializer f) =>
ToJSONOptions -> f (v a)
gToJSONObject ToJSONOptions
o) (ToJSONOptions -> f (rhs a)
forall (v :: * -> *) (f :: * -> *) a.
(GToJSONObject v, JSONObjectSerializer f) =>
ToJSONOptions -> f (v a)
gToJSONObject ToJSONOptions
o)
    where
      div :: (:*:) f g p -> (f p, g p)
div (f p
a :*: g p
b) = (f p
a, g p
b)

class GToJSONTuple v where
  gToJSONTuple :: (JSONTupleSerializer f) => ToJSONOptions -> f (v a)

instance (GToJSONTuple lhs, GToJSONTuple rhs) => GToJSONTuple (lhs :*: rhs) where
  gToJSONTuple :: ToJSONOptions -> f ((:*:) lhs rhs a)
gToJSONTuple ToJSONOptions
o = ((:*:) lhs rhs a -> (lhs a, rhs a))
-> f (lhs a) -> f (rhs a) -> f ((:*:) lhs rhs a)
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (:*:) lhs rhs a -> (lhs a, rhs a)
forall (f :: * -> *) (g :: * -> *) p. (:*:) f g p -> (f p, g p)
div (ToJSONOptions -> f (lhs a)
forall (v :: * -> *) (f :: * -> *) a.
(GToJSONTuple v, JSONTupleSerializer f) =>
ToJSONOptions -> f (v a)
gToJSONTuple ToJSONOptions
o) (ToJSONOptions -> f (rhs a)
forall (v :: * -> *) (f :: * -> *) a.
(GToJSONTuple v, JSONTupleSerializer f) =>
ToJSONOptions -> f (v a)
gToJSONTuple ToJSONOptions
o)
    where
      div :: (:*:) f g p -> (f p, g p)
div (f p
a :*: g p
b) = (f p
a, g p
b)

instance (GToJSON f) => GToJSONTuple (S1 (MetaSel Nothing su ss ds) f) where
  gToJSONTuple :: ToJSONOptions -> f (S1 ('MetaSel 'Nothing su ss ds) f a)
gToJSONTuple ToJSONOptions
o =
    (S1 ('MetaSel 'Nothing su ss ds) f a -> f a)
-> f (f a) -> f (S1 ('MetaSel 'Nothing su ss ds) f a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(M1 f a
a) -> f a
a) (f (f a) -> f (S1 ('MetaSel 'Nothing su ss ds) f a))
-> f (f a) -> f (S1 ('MetaSel 'Nothing su ss ds) f a)
forall a b. (a -> b) -> a -> b
$
      (forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer (f a))
-> f (f a)
forall (f :: * -> *) a.
JSONTupleSerializer f =>
(forall (jsonSerializer :: * -> *).
 JSONSerializer jsonSerializer =>
 jsonSerializer a)
-> f a
serializeItemWith (ToJSONOptions -> jsonSerializer (f a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
o)