{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Named.EncodeValue
  ( EncodeFieldKind,
    Encode,
    getTypeName,
    encodeResolverValue,
  )
where

import Control.Monad.Except (MonadError (..))
import Data.Aeson (ToJSON (..))
import Data.Morpheus.App.Internal.Resolving
  ( LiftOperation,
    NamedResolverRef (..),
    NamedResolverResult (..),
    ObjectTypeResolver (..),
    Resolver,
    ResolverValue (..),
    getArguments,
    liftResolverState,
    mkList,
    mkNull,
  )
import Data.Morpheus.Kind
  ( CUSTOM,
    DerivingKind,
    SCALAR,
    TYPE,
    WRAPPER,
  )
import Data.Morpheus.NamedResolvers
  ( NamedResolverT (..),
    ResolveNamed (..),
  )
import Data.Morpheus.Server.Deriving.Decode
  ( DecodeConstraint,
    decodeArguments,
  )
import Data.Morpheus.Server.Deriving.Encode
  ( ContextValue (..),
  )
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    DataType (..),
    FieldRep (..),
    TypeConstraint (..),
    TypeRep (..),
    toFieldRes,
    toValue,
  )
import Data.Morpheus.Server.Types.GQLType
  ( GQLType (__type),
    KIND,
    TypeData (gqlTypeName),
  )
import Data.Morpheus.Types.GQLScalar
  ( EncodeScalar (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( GQLError,
    OUT,
    TypeCategory (OUT),
    TypeName,
    internal,
    replaceValue,
  )
import qualified GHC.Exts as HM
import GHC.Generics
  ( Generic (..),
  )
import Relude

encodeResolverValue :: (MonadError GQLError m, FieldConstraint m a) => a -> m (NamedResolverResult m)
encodeResolverValue :: a -> m (NamedResolverResult m)
encodeResolverValue = DataType (m (ResolverValue m)) -> m (NamedResolverResult m)
forall (m :: * -> *).
MonadError GQLError m =>
DataType (m (ResolverValue m)) -> m (NamedResolverResult m)
convertNamedNode (DataType (m (ResolverValue m)) -> m (NamedResolverResult m))
-> (a -> DataType (m (ResolverValue m)))
-> a
-> m (NamedResolverResult m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> DataType (m (ResolverValue m))
forall (m :: * -> *) a.
FieldConstraint m a =>
a -> DataType (m (ResolverValue m))
getFieldValues

type FieldConstraint m a =
  ( GQLType a,
    Generic a,
    TypeRep (Encode m) (m (ResolverValue m)) (Rep a)
  )

class Encode (m :: Type -> Type) res where
  encodeField :: res -> m (ResolverValue m)

instance (EncodeFieldKind (KIND a) m a) => Encode m a where
  encodeField :: a -> m (ResolverValue m)
encodeField a
resolver = ContextValue (KIND a) a -> m (ResolverValue m)
forall (k :: DerivingKind) (m :: * -> *) a.
EncodeFieldKind k m a =>
ContextValue k a -> m (ResolverValue m)
encodeFieldKind (a -> ContextValue (KIND a) a
forall (kind :: DerivingKind) a. a -> ContextValue kind a
ContextValue a
resolver :: ContextValue (KIND a) a)

class EncodeFieldKind (k :: DerivingKind) (m :: Type -> Type) (a :: Type) where
  encodeFieldKind :: ContextValue k a -> m (ResolverValue m)

instance (EncodeScalar a, Monad m) => EncodeFieldKind SCALAR m a where
  encodeFieldKind :: ContextValue SCALAR a -> m (ResolverValue m)
encodeFieldKind = ResolverValue m -> m (ResolverValue m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> m (ResolverValue m))
-> (ContextValue SCALAR a -> ResolverValue m)
-> ContextValue SCALAR a
-> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar (ScalarValue -> ResolverValue m)
-> (ContextValue SCALAR a -> ScalarValue)
-> ContextValue SCALAR a
-> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ScalarValue
forall a. EncodeScalar a => a -> ScalarValue
encodeScalar (a -> ScalarValue)
-> (ContextValue SCALAR a -> a)
-> ContextValue SCALAR a
-> ScalarValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextValue SCALAR a -> a
forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

instance (FieldConstraint m a, MonadError GQLError m) => EncodeFieldKind TYPE m a where
  encodeFieldKind :: ContextValue TYPE a -> m (ResolverValue m)
encodeFieldKind (ContextValue a
_) = GQLError -> m (ResolverValue m)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"types are resolved by Refs")

instance (GQLType a, Applicative m, EncodeFieldKind (KIND a) m a) => EncodeFieldKind WRAPPER m [a] where
  encodeFieldKind :: ContextValue WRAPPER [a] -> m (ResolverValue m)
encodeFieldKind = ([ResolverValue m] -> ResolverValue m)
-> m [ResolverValue m] -> m (ResolverValue m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ResolverValue m] -> ResolverValue m
forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
ResList (m [ResolverValue m] -> m (ResolverValue m))
-> (ContextValue WRAPPER [a] -> m [ResolverValue m])
-> ContextValue WRAPPER [a]
-> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (ResolverValue m)) -> [a] -> m [ResolverValue m]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> m (ResolverValue m)
forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField ([a] -> m [ResolverValue m])
-> (ContextValue WRAPPER [a] -> [a])
-> ContextValue WRAPPER [a]
-> m [ResolverValue m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextValue WRAPPER [a] -> [a]
forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue

instance (GQLType a, EncodeFieldKind (KIND a) m a, Applicative m) => EncodeFieldKind WRAPPER m (Maybe a) where
  encodeFieldKind :: ContextValue WRAPPER (Maybe a) -> m (ResolverValue m)
encodeFieldKind (ContextValue (Just a
x)) = a -> m (ResolverValue m)
forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField a
x
  encodeFieldKind (ContextValue Maybe a
Nothing) = ResolverValue m -> m (ResolverValue m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResolverValue m
forall (m :: * -> *). ResolverValue m
mkNull

instance
  ( Monad m,
    GQLType a,
    EncodeFieldKind (KIND a) m a,
    ToJSON (Dep a)
  ) =>
  EncodeFieldKind CUSTOM m (NamedResolverT m a)
  where
  encodeFieldKind :: ContextValue CUSTOM (NamedResolverT m a) -> m (ResolverValue m)
encodeFieldKind = Monad m => NamedResolverT m a -> m (ResolverValue m)
NamedResolverT m a -> m (ResolverValue m)
encodeRef (NamedResolverT m a -> m (ResolverValue m))
-> (ContextValue CUSTOM (NamedResolverT m a) -> NamedResolverT m a)
-> ContextValue CUSTOM (NamedResolverT m a)
-> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContextValue CUSTOM (NamedResolverT m a) -> NamedResolverT m a
forall (kind :: DerivingKind) a. ContextValue kind a -> a
unContextValue
    where
      name :: TypeName
      name :: TypeName
name = Proxy a -> TypeName
forall a (f :: * -> *). GQLType a => f a -> TypeName
getTypeName (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
      encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m)
      encodeRef :: NamedResolverT m a -> m (ResolverValue m)
encodeRef (Ref m (Dep a)
x) = ResolverValue m -> m (ResolverValue m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> m (ResolverValue m))
-> ResolverValue m -> m (ResolverValue m)
forall a b. (a -> b) -> a -> b
$ m NamedResolverRef -> ResolverValue m
forall (m :: * -> *). m NamedResolverRef -> ResolverValue m
ResRef (TypeName -> ValidValue -> NamedResolverRef
NamedResolverRef TypeName
name (ValidValue -> NamedResolverRef)
-> (Dep a -> ValidValue) -> Dep a -> NamedResolverRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValidValue
forall (a :: Stage). Value -> Value a
replaceValue (Value -> ValidValue) -> (Dep a -> Value) -> Dep a -> ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dep a -> Value
forall a. ToJSON a => a -> Value
toJSON (Dep a -> NamedResolverRef) -> m (Dep a) -> m NamedResolverRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Dep a)
x)
      encodeRef (Value m a
value) = m a
value m a -> (a -> m (ResolverValue m)) -> m (ResolverValue m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m (ResolverValue m)
forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField
      encodeRef (Refs m [Dep a]
refs) = [ResolverValue m] -> ResolverValue m
forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList ([ResolverValue m] -> ResolverValue m)
-> ([Dep a] -> [ResolverValue m]) -> [Dep a] -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dep a -> ResolverValue m) -> [Dep a] -> [ResolverValue m]
forall a b. (a -> b) -> [a] -> [b]
map (m NamedResolverRef -> ResolverValue m
forall (m :: * -> *). m NamedResolverRef -> ResolverValue m
ResRef (m NamedResolverRef -> ResolverValue m)
-> (Dep a -> m NamedResolverRef) -> Dep a -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedResolverRef -> m NamedResolverRef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedResolverRef -> m NamedResolverRef)
-> (Dep a -> NamedResolverRef) -> Dep a -> m NamedResolverRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> ValidValue -> NamedResolverRef
NamedResolverRef TypeName
name (ValidValue -> NamedResolverRef)
-> (Dep a -> ValidValue) -> Dep a -> NamedResolverRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValidValue
forall (a :: Stage). Value -> Value a
replaceValue (Value -> ValidValue) -> (Dep a -> Value) -> Dep a -> ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dep a -> Value
forall a. ToJSON a => a -> Value
toJSON) ([Dep a] -> ResolverValue m) -> m [Dep a] -> m (ResolverValue m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Dep a]
refs

instance
  ( DecodeConstraint a,
    Generic a,
    Monad m,
    Encode (Resolver o e m) b,
    LiftOperation o
  ) =>
  EncodeFieldKind CUSTOM (Resolver o e m) (a -> b)
  where
  encodeFieldKind :: ContextValue CUSTOM (a -> b)
-> Resolver o e m (ResolverValue (Resolver o e m))
encodeFieldKind (ContextValue a -> b
f) =
    Resolver o e m (Arguments VALID)
forall (o :: OperationType) (m :: * -> *) e.
(LiftOperation o, Monad m) =>
Resolver o e m (Arguments VALID)
getArguments
      Resolver o e m (Arguments VALID)
-> (Arguments VALID -> Resolver o e m a) -> Resolver o e m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ResolverState a -> Resolver o e m a
forall (o :: OperationType) (m :: * -> *) a e.
(LiftOperation o, Monad m) =>
ResolverState a -> Resolver o e m a
liftResolverState (ResolverState a -> Resolver o e m a)
-> (Arguments VALID -> ResolverState a)
-> Arguments VALID
-> Resolver o e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments VALID -> ResolverState a
forall a. DecodeConstraint a => Arguments VALID -> ResolverState a
decodeArguments
      Resolver o e m a
-> (a -> Resolver o e m (ResolverValue (Resolver o e m)))
-> Resolver o e m (ResolverValue (Resolver o e m))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> Resolver o e m (ResolverValue (Resolver o e m))
forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField (b -> Resolver o e m (ResolverValue (Resolver o e m)))
-> (a -> b) -> a -> Resolver o e m (ResolverValue (Resolver o e m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

getFieldValues :: FieldConstraint m a => a -> DataType (m (ResolverValue m))
getFieldValues :: a -> DataType (m (ResolverValue m))
getFieldValues =
  TypeConstraint (Encode m) (m (ResolverValue m)) Identity
-> Proxy OUT -> a -> DataType (m (ResolverValue m))
forall (proxy :: TypeCategory -> *) (kind :: TypeCategory)
       (constraint :: * -> Constraint) value a.
(GQLType a, CategoryValue kind, Generic a,
 TypeRep constraint value (Rep a)) =>
TypeConstraint constraint value Identity
-> proxy kind -> a -> DataType value
toValue
    ( (forall a. Encode m a => Identity a -> m (ResolverValue m))
-> TypeConstraint (Encode m) (m (ResolverValue m)) Identity
forall (c :: * -> Constraint) v (f :: * -> *).
(forall a. c a => f a -> v) -> TypeConstraint c v f
TypeConstraint (a -> m (ResolverValue m)
forall (m :: * -> *) res.
Encode m res =>
res -> m (ResolverValue m)
encodeField (a -> m (ResolverValue m))
-> (Identity a -> a) -> Identity a -> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity) ::
        TypeConstraint (Encode m) (m (ResolverValue m)) Identity
    )
    (Proxy OUT
forall k (t :: k). Proxy t
Proxy @OUT)

convertNamedNode ::
  MonadError GQLError m =>
  DataType (m (ResolverValue m)) ->
  m (NamedResolverResult m)
convertNamedNode :: DataType (m (ResolverValue m)) -> m (NamedResolverResult m)
convertNamedNode
  DataType
    { Bool
tyIsUnion :: forall v. DataType v -> Bool
tyIsUnion :: Bool
tyIsUnion,
      tyCons :: forall v. DataType v -> ConsRep v
tyCons = ConsRep {[FieldRep (m (ResolverValue m))]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (m (ResolverValue m))]
consFields, TypeName
consName :: forall v. ConsRep v -> TypeName
consName :: TypeName
consName}
    }
    | [FieldRep (m (ResolverValue m))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldRep (m (ResolverValue m))]
consFields = NamedResolverResult m -> m (NamedResolverResult m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedResolverResult m -> m (NamedResolverResult m))
-> NamedResolverResult m -> m (NamedResolverResult m)
forall a b. (a -> b) -> a -> b
$ TypeName -> NamedResolverResult m
forall (m :: * -> *). TypeName -> NamedResolverResult m
NamedEnumResolver TypeName
consName
    | Bool
tyIsUnion = [FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)
forall (m :: * -> *).
MonadError GQLError m =>
[FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)
deriveUnion [FieldRep (m (ResolverValue m))]
consFields
    | Bool
otherwise =
      NamedResolverResult m -> m (NamedResolverResult m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedResolverResult m -> m (NamedResolverResult m))
-> NamedResolverResult m -> m (NamedResolverResult m)
forall a b. (a -> b) -> a -> b
$
        ObjectTypeResolver m -> NamedResolverResult m
forall (m :: * -> *). ObjectTypeResolver m -> NamedResolverResult m
NamedObjectResolver
          ObjectTypeResolver :: forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver
            { objectFields :: HashMap FieldName (m (ResolverValue m))
objectFields = [Item (HashMap FieldName (m (ResolverValue m)))]
-> HashMap FieldName (m (ResolverValue m))
forall l. IsList l => [Item l] -> l
HM.fromList (FieldRep (m (ResolverValue m)) -> (FieldName, m (ResolverValue m))
forall k (m :: k -> *) (a :: k). FieldRep (m a) -> (FieldName, m a)
toFieldRes (FieldRep (m (ResolverValue m))
 -> (FieldName, m (ResolverValue m)))
-> [FieldRep (m (ResolverValue m))]
-> [(FieldName, m (ResolverValue m))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldRep (m (ResolverValue m))]
consFields)
            }

deriveUnion :: (MonadError GQLError m) => [FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)
deriveUnion :: [FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m)
deriveUnion [FieldRep {m (ResolverValue m)
TypeRef
FieldName
fieldValue :: forall a. FieldRep a -> a
fieldTypeRef :: forall a. FieldRep a -> TypeRef
fieldSelector :: forall a. FieldRep a -> FieldName
fieldValue :: m (ResolverValue m)
fieldTypeRef :: TypeRef
fieldSelector :: FieldName
..}] =
  NamedResolverRef -> NamedResolverResult m
forall (m :: * -> *). NamedResolverRef -> NamedResolverResult m
NamedUnionResolver (NamedResolverRef -> NamedResolverResult m)
-> m NamedResolverRef -> m (NamedResolverResult m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m (ResolverValue m)
fieldValue m (ResolverValue m)
-> (ResolverValue m -> m NamedResolverRef) -> m NamedResolverRef
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ResolverValue m -> m NamedResolverRef
forall (m :: * -> *).
MonadError GQLError m =>
ResolverValue m -> m NamedResolverRef
getRef)
deriveUnion [FieldRep (m (ResolverValue m))]
_ = GQLError -> m (NamedResolverResult m)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"only union references are supported!"

getRef :: MonadError GQLError m => ResolverValue m -> m NamedResolverRef
getRef :: ResolverValue m -> m NamedResolverRef
getRef (ResRef m NamedResolverRef
x) = m NamedResolverRef
x
getRef ResolverValue m
_ = GQLError -> m NamedResolverRef
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"only resolver references are supported!"

getTypeName :: GQLType a => f a -> TypeName
getTypeName :: f a -> TypeName
getTypeName f a
proxy = TypeData -> TypeName
gqlTypeName (TypeData -> TypeName) -> TypeData -> TypeName
forall a b. (a -> b) -> a -> b
$ f a -> TypeCategory -> TypeData
forall a (f :: * -> *).
GQLType a =>
f a -> TypeCategory -> TypeData
__type f a
proxy TypeCategory
OUT