{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Jordan.ToJSON.Class
    where

import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import qualified Data.Map.Strict as Map
import qualified Data.Ratio as Ratio
import Data.Scientific (Scientific)
import qualified Data.Scientific as Sci
import qualified Data.Semigroup as Semi
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Proxy(..), Typeable, tyConModule, tyConName, typeRep, typeRepTyCon)
import Data.Void (Void, absurd)
import GHC.Generics
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

-- | 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) => JSONObjectSerializer f where
  writeField
    :: Text
    -- ^ Label for the field to write
    -> (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a)
    -- ^ How to write the field.
    -- The forall ensures that JSON serialization is kept completely abstract.
    -- You can only use the methods of 'JSONSerializer' here.
    -> f a

class (Divisible f) => JSONTupleSerializer f where
  writeItem
    :: (forall jsonSerializer. JSONSerializer jsonSerializer => jsonSerializer a)
    -- ^ Write a single item into the tuple.
    -- The forall keeps things abstract.
    -> f a

-- | An abstract representation of how to serialize a Haskell value into JSON.
class (Selectable f) => JSONSerializer f where
  serializeObject
    :: Text
    -- ^ A name for the object. Should be "globally unique" as much as possible.
    -> (forall objSerializer. JSONObjectSerializer objSerializer => objSerializer a)
    -- ^ How to serialize the object.
    -- The forall here keeps things abstract: you are only allowed to use the methods of 'JSONObjectSerializer' here.
    -> 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]

-- | 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.
class ToJSON v where
  toJSON :: (JSONSerializer f) => f v
  default toJSON :: (Generic v, GToJSON (Rep 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

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 = Text
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer (Ratio a))
-> f (Ratio a)
forall (f :: * -> *) a.
JSONSerializer f =>
Text
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer a)
-> f a
serializeObject Text
objName ((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
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> objSerializer a
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
writeField Text
"num" forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
toJSON) (Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> objSerializer a
forall (f :: * -> *) a.
JSONObjectSerializer f =>
Text
-> (forall (jsonSerializer :: * -> *).
    JSONSerializer jsonSerializer =>
    jsonSerializer a)
-> f a
writeField Text
"denom" forall v (f :: * -> *). (ToJSON v, JSONSerializer f) => f v
forall (jsonSerializer :: * -> *).
JSONSerializer jsonSerializer =>
jsonSerializer a
toJSON)
    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

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

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

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

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

instance (GToJSON f, Datatype t) => GToJSON (D1 t f) where
  gToJSON :: ToJSONOptions -> s (D1 t f a)
gToJSON = (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))
-> (ToJSONOptions -> s (f a)) -> ToJSONOptions -> s (D1 t f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToJSONOptions -> s (f a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON (ToJSONOptions -> s (f a))
-> (ToJSONOptions -> ToJSONOptions) -> ToJSONOptions -> s (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToJSONOptions -> ToJSONOptions
addName
    where
      addName :: ToJSONOptions -> ToJSONOptions
addName ToJSONOptions
b = ToJSONOptions
b { toJSONBaseName :: String
toJSONBaseName = ToJSONOptions -> String
toJSONBaseName ToJSONOptions
b String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dtname }
      dtname :: String
dtname = M1 D t f Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
moduleName M1 D t f Any
forall a. D1 t f a
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> M1 D t f Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName M1 D t f Any
forall a. D1 t f a
s
      s :: D1 t f a
      s :: D1 t f a
s = D1 t f a
forall a. HasCallStack => a
undefined

instance {-# OVERLAPS #-} (Constructor t) => GToJSON (PartOfSum (C1 t U1)) where
  gToJSON :: ToJSONOptions -> s (PartOfSum (C1 t U1) a)
gToJSON ToJSONOptions
opts = (PartOfSum (C1 t U1) a -> C1 t U1 a)
-> s (C1 t U1 a) -> s (PartOfSum (C1 t U1) a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap PartOfSum (C1 t U1) a -> C1 t U1 a
forall (f :: * -> *) a. PartOfSum f a -> f a
getPartOfSum (s (C1 t U1 a) -> s (PartOfSum (C1 t U1) a))
-> s (C1 t U1 a) -> s (PartOfSum (C1 t U1) a)
forall a b. (a -> b) -> a -> b
$ Text -> s (C1 t U1 a)
forall (f :: * -> *) a. JSONSerializer f => Text -> f a
serializeTextConstant Text
enumValue
    where
      enumValue :: Text
enumValue = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ToJSONOptions -> String -> String
toJSONRenderEnum ToJSONOptions
opts (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ M1 C t U1 Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (forall f. M1 C t U1 f
forall a. HasCallStack => a
undefined :: C1 t U1 f)

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)
forall a. 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)
forall a. s (C1 t f a)
tagged
        SumTypeEncoding
TagInField -> s (C1 t f a)
forall a. s (C1 t f a)
field
      field :: s (C1 t f a)
field = Text
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer (C1 t f a))
-> s (C1 t f a)
forall (f :: * -> *) a.
JSONSerializer f =>
Text
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer a)
-> f a
serializeObject Text
objName ((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
writeField 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 = Text
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer (C1 t f a))
-> s (C1 t f a)
forall (f :: * -> *) a.
JSONSerializer f =>
Text
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer a)
-> f a
serializeObject Text
objName ((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
writeField 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
writeField 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

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
PartOfSum (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
PartOfSum (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 s) => GToJSON (S1 whatever s) where
  gToJSON :: ToJSONOptions -> s (S1 whatever s a)
gToJSON = (S1 whatever s a -> s a) -> s (s a) -> s (S1 whatever s a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (\(M1 s a
a) -> s a
a) (s (s a) -> s (S1 whatever s a))
-> (ToJSONOptions -> s (s a))
-> ToJSONOptions
-> s (S1 whatever s a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToJSONOptions -> s (s a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON

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?")

class GToJSONObject v where
  gToJSONObject :: (JSONObjectSerializer f) => ToJSONOptions -> f (v a)

instance (GToJSON f, Selector t) => GToJSONObject (S1 t f) where
  gToJSONObject :: ToJSONOptions -> f (S1 t f a)
gToJSONObject ToJSONOptions
o
    = (S1 t f a -> f a) -> f (f a) -> f (S1 t 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 t f a)) -> f (f a) -> f (S1 t 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
writeField (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 S t f Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S t f Any
forall a. M1 S t f a
v) (ToJSONOptions -> jsonSerializer (f a)
forall (v :: * -> *) (s :: * -> *) a.
(GToJSON v, JSONSerializer s) =>
ToJSONOptions -> s (v a)
gToJSON ToJSONOptions
o)
      where
        v :: M1 S t f a
        v :: M1 S t f a
v = M1 S t f a
forall a. HasCallStack => a
undefined

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)

instance {-# OVERLAPPABLE #-} (GToJSONObject inner, Constructor t) => GToJSON (C1 t inner) where
  gToJSON :: ToJSONOptions -> s (C1 t inner a)
gToJSON ToJSONOptions
opts
    = (C1 t inner a -> inner a) -> s (inner a) -> s (C1 t 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 t inner a))
-> s (inner a) -> s (C1 t inner a)
forall a b. (a -> b) -> a -> b
$ Text
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer (inner a))
-> s (inner a)
forall (f :: * -> *) a.
JSONSerializer f =>
Text
-> (forall (objSerializer :: * -> *).
    JSONObjectSerializer objSerializer =>
    objSerializer a)
-> f a
serializeObject Text
name
    ((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 t 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 t inner a
forall a. HasCallStack => a
undefined :: C1 t inner a) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".Output"

instance {-# OVERLAPS #-} (ToJSON i) => GToJSON (C1 c (S1 (MetaSel 'Nothing su ss ds) (Rec0 i))) where
  gToJSON :: ToJSONOptions
-> s (C1 c (S1 ('MetaSel 'Nothing su ss ds) (Rec0 i)) a)
gToJSON ToJSONOptions
_ = (C1 c (S1 ('MetaSel 'Nothing su ss ds) (Rec0 i)) a -> i)
-> s i -> s (C1 c (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