{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE UndecidableInstances #-}

module DomainDriven.Internal.NamedJsonFields where

import Control.Applicative
import Control.Monad.State
import Data.Aeson
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Types
import Data.Generics.Product
import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import qualified Data.OpenApi as O
import Data.OpenApi.Declare
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable
import DomainDriven.Internal.HasFieldName
import GHC.Generics
import Lens.Micro hiding (to)
import Prelude

import qualified Lens.Micro as Lens

packed :: Getting r String Text
packed :: forall r. Getting r String Text
packed = forall s a. (s -> a) -> SimpleGetter s a
Lens.to String -> Text
T.pack

newtype NamedJsonFields a = NamedJsonFields a

instance (GNamedToJSON (Rep a), Generic a) => ToJSON (NamedJsonFields a) where
    toJSON :: NamedJsonFields a -> Value
toJSON (NamedJsonFields a
a) = forall a.
(GNamedToJSON (Rep a), Generic a) =>
NamedJsonOptions -> a -> Value
gNamedToJson NamedJsonOptions
defaultNamedJsonOptions a
a

instance (GNamedFromJSON (Rep a), Generic a) => FromJSON (NamedJsonFields a) where
    parseJSON :: Value -> Parser (NamedJsonFields a)
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> NamedJsonFields a
NamedJsonFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(GNamedFromJSON (Rep a), Generic a) =>
NamedJsonOptions -> Value -> Parser a
gNamedParseJson NamedJsonOptions
defaultNamedJsonOptions

instance (Typeable a, GNamedToSchema (Rep a)) => O.ToSchema (NamedJsonFields a) where
    declareNamedSchema :: Proxy (NamedJsonFields a)
-> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (NamedJsonFields a)
_ = forall a.
GNamedToSchema (Rep a) =>
NamedJsonOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
gNamedDeclareNamedSchema NamedJsonOptions
defaultNamedJsonOptions (forall {k} (t :: k). Proxy t
Proxy @a)

-- evalStateT (gDeclareNamedSchema defaultNamedJsonOptions $ Proxy @(Rep a)) []

gNamedToJson :: (GNamedToJSON (Rep a), Generic a) => NamedJsonOptions -> a -> Value
gNamedToJson :: forall a.
(GNamedToJSON (Rep a), Generic a) =>
NamedJsonOptions -> a -> Value
gNamedToJson NamedJsonOptions
opts a
a = Object -> Value
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. [(UsedName, v)] -> KeyMap v
KM.fromList forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> a
evalState (forall {k} (a :: k -> *) (x :: k).
GNamedToJSON a =>
NamedJsonOptions -> a x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts forall a b. (a -> b) -> a -> b
$ forall a x. Generic a => a -> Rep a x
from a
a) []

gNamedParseJson
    :: (GNamedFromJSON (Rep a), Generic a) => NamedJsonOptions -> Value -> Parser a
gNamedParseJson :: forall a.
(GNamedFromJSON (Rep a), Generic a) =>
NamedJsonOptions -> Value -> Parser a
gNamedParseJson NamedJsonOptions
opts Value
v = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall {k} (a :: k -> *) (x :: k).
GNamedFromJSON a =>
NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)
gNamedFromJSON NamedJsonOptions
opts Value
v) []

gNamedDeclareNamedSchema
    :: forall a
     . (GNamedToSchema (Rep a))
    => NamedJsonOptions
    -> Proxy a
    -> Declare (O.Definitions O.Schema) O.NamedSchema
gNamedDeclareNamedSchema :: forall a.
GNamedToSchema (Rep a) =>
NamedJsonOptions
-> Proxy a -> Declare (Definitions Schema) NamedSchema
gNamedDeclareNamedSchema NamedJsonOptions
opts Proxy a
_ =
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall (f :: * -> *).
GNamedToSchema f =>
NamedJsonOptions
-> Proxy f
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts (forall {k} (t :: k). Proxy t
Proxy @(Rep a))) []

-----------------------------------------Options------------------------------------------

data NamedJsonOptions = NamedJsonOptions
    { NamedJsonOptions -> String -> String
constructorTagModifier :: String -> String
    , NamedJsonOptions -> String
tagFieldName :: String
    , NamedJsonOptions -> Bool
skipTagField :: Bool
    , NamedJsonOptions -> String -> String
datatypeNameModifier :: String -> String
    }
    deriving (forall x. Rep NamedJsonOptions x -> NamedJsonOptions
forall x. NamedJsonOptions -> Rep NamedJsonOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NamedJsonOptions x -> NamedJsonOptions
$cfrom :: forall x. NamedJsonOptions -> Rep NamedJsonOptions x
Generic)

defaultNamedJsonOptions :: NamedJsonOptions
defaultNamedJsonOptions :: NamedJsonOptions
defaultNamedJsonOptions =
    NamedJsonOptions
        { $sel:constructorTagModifier:NamedJsonOptions :: String -> String
constructorTagModifier = forall a. a -> a
id
        , $sel:tagFieldName:NamedJsonOptions :: String
tagFieldName = String
"tag"
        , $sel:skipTagField:NamedJsonOptions :: Bool
skipTagField = Bool
False
        , $sel:datatypeNameModifier:NamedJsonOptions :: String -> String
datatypeNameModifier = forall a. a -> a
id
        }

-----------------------------------------O.ToSchema-----------------------------------------
data Proxy3 a b c = Proxy3

class GNamedToSchema (f :: Type -> Type) where
    gDeclareNamedSchema
        :: NamedJsonOptions
        -> Proxy f
        -> StateT [UsedName] (Declare (O.Definitions O.Schema)) O.NamedSchema

-- Grab the name of the datatype
instance (Datatype d, GNamedToSchema f) => GNamedToSchema (D1 d f) where
    gDeclareNamedSchema :: NamedJsonOptions
-> Proxy (D1 d f)
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts Proxy (D1 d f)
_ = do
        let dtName :: String
            dtName :: String
dtName = NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"datatypeNameModifier" forall a b. (a -> b) -> a -> b
$ forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName (forall {k} {k} {k} (a :: k) (b :: k) (c :: k). Proxy3 a b c
Proxy3 @d @f)
        O.NamedSchema Maybe Text
_ Schema
rest <- forall (f :: * -> *).
GNamedToSchema f =>
NamedJsonOptions
-> Proxy f
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts (forall {k} (t :: k). Proxy t
Proxy @f)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
O.NamedSchema (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
dtName) Schema
rest

-- Grab the name of the constructor to use for the `tag` field content.
instance (GNamedToSchema f, Constructor c) => GNamedToSchema (C1 c f) where
    gDeclareNamedSchema :: NamedJsonOptions
-> Proxy (C1 c f)
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts Proxy (C1 c f)
_ = do
        O.NamedSchema Maybe Text
_ Schema
s <- forall (f :: * -> *).
GNamedToSchema f =>
NamedJsonOptions
-> Proxy f
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts (forall {k} (t :: k). Proxy t
Proxy @f)
        if NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"skipTagField"
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
O.NamedSchema forall a. Maybe a
Nothing Schema
s
            else do
                let tagName :: Key
                    tagName :: UsedName
tagName = Text -> UsedName
Key.fromText forall a b. (a -> b) -> a -> b
$ NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"tagFieldName" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Getting r String Text
packed
                forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall a b. (a -> b) -> a -> b
$ \[UsedName]
ss -> ((), UsedName
tagName forall a. a -> [a] -> [a]
: [UsedName]
ss)
                let constructorName :: Text
                    constructorName :: Text
constructorName =
                        String -> Text
T.pack
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"constructorTagModifier")
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName
                            forall a b. (a -> b) -> a -> b
$ forall {k} {k} {k} (a :: k) (b :: k) (c :: k). Proxy3 a b c
Proxy3 @c @f

                    tagFieldSchema :: O.Schema
                    tagFieldSchema :: Schema
tagFieldSchema =
                        forall a. Monoid a => a
mempty
                            forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
O.properties
                                forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [
                                        ( UsedName -> Text
Key.toText UsedName
tagName
                                        , forall a. a -> Referenced a
O.Inline forall a b. (a -> b) -> a -> b
$
                                            forall a. Monoid a => a
mempty
                                                forall a b. a -> (a -> b) -> b
& forall s a. HasType s a => Lens' s a
O.type_
                                                    forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
O.OpenApiString
                                                forall a b. a -> (a -> b) -> b
& forall s a. HasEnum s a => Lens' s a
O.enum_
                                                    forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Text -> Value
String Text
constructorName]
                                        )
                                    ]
                            forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
O.required
                                forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [UsedName -> Text
Key.toText UsedName
tagName]
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
O.NamedSchema forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Schema
tagFieldSchema forall a. Semigroup a => a -> a -> a
<> Schema
s

-- Grab the name of the field, but not not set it as O.required
instance
    {-# OVERLAPPING #-}
    (O.ToSchema f, HasFieldName f)
    => GNamedToSchema (S1 s (Rec0 (Maybe f)))
    where
    gDeclareNamedSchema :: NamedJsonOptions
-> Proxy (S1 s (Rec0 (Maybe f)))
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
_opts Proxy (S1 s (Rec0 (Maybe f)))
_ = do
        let fName :: UsedName
fName = Text -> UsedName
Key.fromText forall a b. (a -> b) -> a -> b
$ forall t. HasFieldName t => Text
fieldName @(Maybe f)
        [UsedName]
usedNames <- forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\[UsedName]
used -> ([UsedName]
used, UsedName
fName forall a. a -> [a] -> [a]
: [UsedName]
used))
        Referenced Schema
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
O.declareSchemaRef forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @f
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Schema -> NamedSchema
O.NamedSchema forall a. Maybe a
Nothing
            forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
                forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
O.properties
                    forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [
                            ( UsedName -> Text
Key.toText forall a b. (a -> b) -> a -> b
$ [UsedName] -> UsedName -> UsedName
actualFieldName [UsedName]
usedNames UsedName
fName
                            , forall a. a -> Referenced a
O.Inline forall a b. (a -> b) -> a -> b
$ forall a. ToSchema a => Proxy a -> Schema
O.toSchema forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @f
                            )
                        ]

-- Grab the name of the field and set it as O.required
instance
    {-# OVERLAPPABLE #-}
    (O.ToSchema f, HasFieldName f)
    => GNamedToSchema (S1 s (Rec0 f))
    where
    gDeclareNamedSchema :: NamedJsonOptions
-> Proxy (S1 s (Rec0 f))
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
_opts Proxy (S1 s (Rec0 f))
_ = do
        let fName :: UsedName
fName = Text -> UsedName
Key.fromText forall a b. (a -> b) -> a -> b
$ forall t. HasFieldName t => Text
fieldName @f
        [UsedName]
usedNames <- forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\[UsedName]
used -> ([UsedName]
used, UsedName
fName forall a. a -> [a] -> [a]
: [UsedName]
used))
        Referenced Schema
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
O.declareSchemaRef forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @f
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Schema -> NamedSchema
O.NamedSchema forall a. Maybe a
Nothing
            forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
                forall a b. a -> (a -> b) -> b
& forall s a. HasProperties s a => Lens' s a
O.properties
                    forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [
                            ( UsedName -> Text
Key.toText forall a b. (a -> b) -> a -> b
$ [UsedName] -> UsedName -> UsedName
actualFieldName [UsedName]
usedNames UsedName
fName
                            , forall a. a -> Referenced a
O.Inline forall a b. (a -> b) -> a -> b
$ forall a. ToSchema a => Proxy a -> Schema
O.toSchema forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @f
                            )
                        ]
                forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
O.required
                    forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [UsedName -> Text
Key.toText forall a b. (a -> b) -> a -> b
$ [UsedName] -> UsedName -> UsedName
actualFieldName [UsedName]
usedNames UsedName
fName]

instance GNamedToSchema U1 where
    gDeclareNamedSchema :: NamedJsonOptions
-> Proxy U1
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
_opts Proxy U1
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
O.NamedSchema forall a. Maybe a
Nothing forall a. Monoid a => a
mempty

instance (GNamedToSchema f, GNamedToSchema g) => GNamedToSchema (f :*: g) where
    gDeclareNamedSchema :: NamedJsonOptions
-> Proxy (f :*: g)
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts Proxy (f :*: g)
_ = do
        O.NamedSchema Maybe Text
_ Schema
a <- forall (f :: * -> *).
GNamedToSchema f =>
NamedJsonOptions
-> Proxy f
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts (forall {k} (t :: k). Proxy t
Proxy @f)
        O.NamedSchema Maybe Text
_ Schema
b <- forall (f :: * -> *).
GNamedToSchema f =>
NamedJsonOptions
-> Proxy f
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts (forall {k} (t :: k). Proxy t
Proxy @g)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> Schema -> NamedSchema
O.NamedSchema forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Schema
a forall a. Semigroup a => a -> a -> a
<> Schema
b)

instance (GNamedToSchema f, GNamedToSchema g) => GNamedToSchema (f :+: g) where
    gDeclareNamedSchema :: NamedJsonOptions
-> Proxy (f :+: g)
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts Proxy (f :+: g)
_ = do
        -- Sum types do not share fields, thus we do not need to adjust the names
        O.NamedSchema Maybe Text
_ Schema
a <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall (f :: * -> *).
GNamedToSchema f =>
NamedJsonOptions
-> Proxy f
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts (forall {k} (t :: k). Proxy t
Proxy @f)) []
        O.NamedSchema Maybe Text
_ Schema
b <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall (f :: * -> *).
GNamedToSchema f =>
NamedJsonOptions
-> Proxy f
-> StateT
     [UsedName] (DeclareT (Definitions Schema) Identity) NamedSchema
gDeclareNamedSchema NamedJsonOptions
opts (forall {k} (t :: k). Proxy t
Proxy @g)) []
        let unwrapOneOf :: O.Schema -> [O.Referenced O.Schema]
            unwrapOneOf :: Schema -> [Referenced Schema]
unwrapOneOf Schema
x = forall a. a -> Maybe a -> a
fromMaybe [forall a. a -> Referenced a
O.Inline Schema
x] forall a b. (a -> b) -> a -> b
$ Schema
x forall s a. s -> Getting a s a -> a
^. forall s a. HasOneOf s a => Lens' s a
O.oneOf
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
            Maybe Text -> Schema -> NamedSchema
O.NamedSchema forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
                forall a. Monoid a => a
mempty
                    forall a b. a -> (a -> b) -> b
& forall s a. HasOneOf s a => Lens' s a
O.oneOf
                        forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> [Referenced Schema]
unwrapOneOf Schema
a forall a. Semigroup a => a -> a -> a
<> Schema -> [Referenced Schema]
unwrapOneOf Schema
b

------------------------------------------ToJSON------------------------------------------
type UsedName = Key

class GNamedToJSON a where
    gToTupleList :: NamedJsonOptions -> a x -> State [UsedName] [(Key, Value)]

instance (GNamedToJSON f) => GNamedToJSON (M1 D d f) where
    gToTupleList :: forall (x :: k).
NamedJsonOptions
-> M1 D d f x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts = forall {k} (a :: k -> *) (x :: k).
GNamedToJSON a =>
NamedJsonOptions -> a x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (GNamedToJSON f, Constructor c) => GNamedToJSON (M1 C c f) where
    gToTupleList :: forall (x :: k).
NamedJsonOptions
-> M1 C c f x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts M1 C c f x
a = do
        [(UsedName, Value)]
tag <-
            if NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"skipTagField"
                then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                else do
                    [UsedName]
usedNames <- forall s (m :: * -> *). MonadState s m => m s
get
                    forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ [UsedName]
usedNames forall a. Semigroup a => a -> a -> a
<> [Text -> UsedName
Key.fromText forall a b. (a -> b) -> a -> b
$ NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"tagFieldName" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Getting r String Text
packed]
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        [
                            ( Text -> UsedName
Key.fromText forall a b. (a -> b) -> a -> b
$ NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"tagFieldName" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Getting r String Text
packed
                            , Text -> Value
String
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"constructorTagModifier")
                                forall a b. (a -> b) -> a -> b
$ forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c f x
a
                            )
                        ]
        [(UsedName, Value)]
rest <- forall {k} (a :: k -> *) (x :: k).
GNamedToJSON a =>
NamedJsonOptions -> a x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 M1 C c f x
a
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(UsedName, Value)]
tag forall a. Semigroup a => a -> a -> a
<> [(UsedName, Value)]
rest

instance (ToJSON t, HasFieldName t) => GNamedToJSON (M1 S c (Rec0 t)) where
    gToTupleList :: forall (x :: k).
NamedJsonOptions
-> M1 S c (Rec0 t) x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
_opts M1 S c (Rec0 t) x
a = do
        [UsedName]
usedNames <- forall s (m :: * -> *). MonadState s m => m s
get
        let fName :: UsedName
fName = Text -> UsedName
Key.fromText forall a b. (a -> b) -> a -> b
$ forall t. HasFieldName t => Text
fieldName @t
        forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ [UsedName]
usedNames forall a. Semigroup a => a -> a -> a
<> [UsedName
fName]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [([UsedName] -> UsedName -> UsedName
actualFieldName [UsedName]
usedNames UsedName
fName, forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). K1 i c p -> c
unK1 forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 M1 S c (Rec0 t) x
a)]

instance GNamedToJSON U1 where
    gToTupleList :: forall (x :: k).
NamedJsonOptions -> U1 x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
_opts U1 x
U1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance (GNamedToJSON a, GNamedToJSON b) => GNamedToJSON (a :*: b) where
    gToTupleList :: forall (x :: k).
NamedJsonOptions
-> (:*:) a b x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts (a x
a :*: b x
b) = do
        [(UsedName, Value)]
p1 <- forall {k} (a :: k -> *) (x :: k).
GNamedToJSON a =>
NamedJsonOptions -> a x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts a x
a
        [(UsedName, Value)]
p2 <- forall {k} (a :: k -> *) (x :: k).
GNamedToJSON a =>
NamedJsonOptions -> a x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts b x
b
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [(UsedName, Value)]
p1 forall a. Semigroup a => a -> a -> a
<> [(UsedName, Value)]
p2

instance (GNamedToJSON a, GNamedToJSON b) => GNamedToJSON (a :+: b) where
    gToTupleList :: forall (x :: k).
NamedJsonOptions
-> (:+:) a b x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts = \case
        L1 a x
a -> forall {k} (a :: k -> *) (x :: k).
GNamedToJSON a =>
NamedJsonOptions -> a x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts a x
a
        R1 b x
a -> forall {k} (a :: k -> *) (x :: k).
GNamedToJSON a =>
NamedJsonOptions -> a x -> State [UsedName] [(UsedName, Value)]
gToTupleList NamedJsonOptions
opts b x
a

actualFieldName :: [UsedName] -> Key -> Key
actualFieldName :: [UsedName] -> UsedName -> UsedName
actualFieldName [UsedName]
usedNames UsedName
fName =
    UsedName
fName forall a. Semigroup a => a -> a -> a
<> case forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
== UsedName
fName) [UsedName]
usedNames) of
        Int
0 -> Text -> UsedName
Key.fromText Text
""
        Int
i -> Text -> UsedName
Key.fromText forall a b. (a -> b) -> a -> b
$ Text
"_" forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show (Int
i forall a. Num a => a -> a -> a
+ Int
1))

-----------------------------------------FromJSON-----------------------------------------

lookupKey :: Key -> Value -> StateT [UsedName] Parser Value
lookupKey :: UsedName -> Value -> StateT [UsedName] Parser Value
lookupKey UsedName
k = \case
    Object Object
o -> do
        [UsedName]
usedNames <- forall s (m :: * -> *). MonadState s m => m s
get
        forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ [UsedName]
usedNames forall a. Semigroup a => a -> a -> a
<> [UsedName
k]
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"No key " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show UsedName
k) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v. UsedName -> KeyMap v -> Maybe v
KM.lookup UsedName
k Object
o
    Value
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Expected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show UsedName
k forall a. Semigroup a => a -> a -> a
<> String
" to be an object."

class GNamedFromJSON a where
    gNamedFromJSON :: NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)

instance GNamedFromJSON p => GNamedFromJSON (M1 D f p) where
    gNamedFromJSON :: forall (x :: k).
NamedJsonOptions -> Value -> StateT [UsedName] Parser (M1 D f p x)
gNamedFromJSON NamedJsonOptions
opts Value
v = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (a :: k -> *) (x :: k).
GNamedFromJSON a =>
NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)
gNamedFromJSON NamedJsonOptions
opts Value
v

instance (Constructor f, GNamedFromJSON p) => GNamedFromJSON (M1 C f p) where
    gNamedFromJSON :: forall (x :: k).
NamedJsonOptions -> Value -> StateT [UsedName] Parser (M1 C f p x)
gNamedFromJSON NamedJsonOptions
opts Value
v =
        if NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"skipTagField"
            then forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (a :: k -> *) (x :: k).
GNamedFromJSON a =>
NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)
gNamedFromJSON NamedJsonOptions
opts Value
v
            else do
                Value
tag <- UsedName -> Value -> StateT [UsedName] Parser Value
lookupKey (Text -> UsedName
Key.fromText forall a b. (a -> b) -> a -> b
$ NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"tagFieldName" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Getting r String Text
packed) Value
v
                M1 C f p x
c <- forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (a :: k -> *) (x :: k).
GNamedFromJSON a =>
NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)
gNamedFromJSON NamedJsonOptions
opts Value
v
                let constructorName :: Text
constructorName =
                        String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedJsonOptions
opts forall s a. s -> Getting a s a -> a
^. forall (field :: Symbol) s t a b.
HasField field s t a b =>
Lens s t a b
field @"constructorTagModifier") forall a b. (a -> b) -> a -> b
$ forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C f p x
c
                case Value
tag of
                    String Text
t | Text
t forall a. Eq a => a -> a -> Bool
== Text
constructorName -> forall (f :: * -> *) a. Applicative f => a -> f a
pure M1 C f p x
c
                    Value
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unknown tag"

instance GNamedFromJSON U1 where
    gNamedFromJSON :: forall (x :: k).
NamedJsonOptions -> Value -> StateT [UsedName] Parser (U1 x)
gNamedFromJSON NamedJsonOptions
_opts Value
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1

instance (GNamedFromJSON a, GNamedFromJSON b) => GNamedFromJSON (a :+: b) where
    gNamedFromJSON :: forall (x :: k).
NamedJsonOptions -> Value -> StateT [UsedName] Parser ((:+:) a b x)
gNamedFromJSON NamedJsonOptions
opts Value
vals =
        forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (a :: k -> *) (x :: k).
GNamedFromJSON a =>
NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)
gNamedFromJSON NamedJsonOptions
opts Value
vals forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (a :: k -> *) (x :: k).
GNamedFromJSON a =>
NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)
gNamedFromJSON NamedJsonOptions
opts Value
vals

instance (GNamedFromJSON a, GNamedFromJSON b) => GNamedFromJSON (a :*: b) where
    gNamedFromJSON :: forall (x :: k).
NamedJsonOptions -> Value -> StateT [UsedName] Parser ((:*:) a b x)
gNamedFromJSON NamedJsonOptions
opts Value
vals = do
        a x
p1 <- forall {k} (a :: k -> *) (x :: k).
GNamedFromJSON a =>
NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)
gNamedFromJSON NamedJsonOptions
opts Value
vals
        b x
p2 <- forall {k} (a :: k -> *) (x :: k).
GNamedFromJSON a =>
NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)
gNamedFromJSON NamedJsonOptions
opts Value
vals
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a x
p1 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b x
p2

instance (FromJSON t, HasFieldName t) => GNamedFromJSON (M1 S c (Rec0 t)) where
    gNamedFromJSON :: forall (x :: k).
NamedJsonOptions
-> Value -> StateT [UsedName] Parser (M1 S c (Rec0 t) x)
gNamedFromJSON NamedJsonOptions
_opts Value
vals = do
        [UsedName]
usedNames <- forall s (m :: * -> *). MonadState s m => m s
get
        let fName :: UsedName
fName = Text -> UsedName
Key.fromText forall a b. (a -> b) -> a -> b
$ forall t. HasFieldName t => Text
fieldName @t
        Value
v <- UsedName -> Value -> StateT [UsedName] Parser Value
lookupKey ([UsedName] -> UsedName -> UsedName
actualFieldName [UsedName]
usedNames UsedName
fName) Value
vals
        forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ [UsedName]
usedNames forall a. Semigroup a => a -> a -> a
<> [UsedName
fName]
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. FromJSON a => Value -> Parser a
parseJSON @t) Value
v