{-# 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, FieldConstraint, ) 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.Server.Deriving.Decode ( Decode, decodeArguments, ) import Data.Morpheus.Server.Deriving.Encode ( ContextValue (..), ) import Data.Morpheus.Server.Deriving.Schema.Directive (toFieldRes) import Data.Morpheus.Server.Deriving.Utils ( ConsRep (..), DataType (..), FieldRep (..), ) import Data.Morpheus.Server.Deriving.Utils.DeriveGType ( DeriveValueOptions (..), DeriveWith, deriveValue, ) import Data.Morpheus.Server.Deriving.Utils.Kinded import Data.Morpheus.Server.NamedResolvers ( NamedResolverT (..), ResolveNamed (..), ) import Data.Morpheus.Server.Types.GQLType ( GQLType (__type), KIND, deriveTypename, __typeData, ) import Data.Morpheus.Server.Types.Internal ( TypeData (gqlTypeName), ) import Data.Morpheus.Server.Types.Kind ( CUSTOM, DerivingKind, SCALAR, TYPE, WRAPPER, ) 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 :: forall (m :: * -> *) a. (MonadError GQLError m, FieldConstraint m a) => a -> m (NamedResolverResult m) encodeResolverValue a x = forall a (m :: * -> *) (f :: * -> *). (GQLType a, MonadError GQLError m) => f a -> DataType (m (ResolverValue m)) -> m (NamedResolverResult m) convertNamedNode (forall a. a -> Identity a Identity a x) (forall (m :: * -> *) a. FieldConstraint m a => a -> DataType (m (ResolverValue m)) getFieldValues a x) type FieldConstraint m a = ( GQLType a, Generic a, DeriveWith (GValueMapConstraint 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 = forall (k :: DerivingKind) (m :: * -> *) a. EncodeFieldKind k m a => ContextValue k a -> m (ResolverValue m) encodeFieldKind (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 = forall (f :: * -> *) a. Applicative f => a -> f a pure forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). ScalarValue -> ResolverValue m ResScalar forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. EncodeScalar a => a -> ScalarValue encodeScalar forall b c a. (b -> c) -> (a -> b) -> a -> c . 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 _) = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (m :: * -> *). [ResolverValue m] -> ResolverValue m ResList forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse forall (m :: * -> *) res. Encode m res => res -> m (ResolverValue m) encodeField forall b c a. (b -> c) -> (a -> b) -> a -> c . 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)) = forall (m :: * -> *) res. Encode m res => res -> m (ResolverValue m) encodeField a x encodeFieldKind (ContextValue Maybe a Nothing) = forall (f :: * -> *) a. Applicative f => a -> f a pure 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) encodeRef forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (kind :: DerivingKind) a. ContextValue kind a -> a unContextValue where name :: TypeName name :: TypeName name = forall a (f :: * -> *). GQLType a => f a -> TypeName getTypeName (forall {k} (t :: k). Proxy t Proxy @a) encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m) encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m) encodeRef (Ref m (Dep a) x) = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). m NamedResolverRef -> ResolverValue m ResRef (TypeName -> ValidValue -> NamedResolverRef NamedResolverRef TypeName name forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (a :: Stage). Value -> Value a replaceValue forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. ToJSON a => a -> Value toJSON forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> m (Dep a) x) encodeRef (Value m a value) = m a value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *) res. Encode m res => res -> m (ResolverValue m) encodeField encodeRef (Refs m [Dep a] refs) = forall (m :: * -> *). [ResolverValue m] -> ResolverValue m mkList forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (forall (m :: * -> *). m NamedResolverRef -> ResolverValue m ResRef forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a. Applicative f => a -> f a pure forall b c a. (b -> c) -> (a -> b) -> a -> c . TypeName -> ValidValue -> NamedResolverRef NamedResolverRef TypeName name forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (a :: Stage). Value -> Value a replaceValue forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. ToJSON a => a -> Value toJSON) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> m [Dep a] refs instance ( Decode 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) = forall (o :: OperationType) (m :: * -> *) e. (LiftOperation o, Monad m) => Resolver o e m (Arguments VALID) getArguments forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (o :: OperationType) (m :: * -> *) a e. (LiftOperation o, Monad m) => ResolverState a -> Resolver o e m a liftResolverState forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Decode a => Arguments VALID -> ResolverState a decodeArguments forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *) res. Encode m res => res -> m (ResolverValue m) encodeField forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> b f class (Encode m a, GQLType a) => GValueMapConstraint m a instance (Encode m a, GQLType a) => GValueMapConstraint m a getFieldValues :: forall m a. FieldConstraint m a => a -> DataType (m (ResolverValue m)) getFieldValues :: forall (m :: * -> *) a. FieldConstraint m a => a -> DataType (m (ResolverValue m)) getFieldValues = forall (kind :: TypeCategory) a (constraint :: * -> Constraint) value. (CategoryValue kind, Generic a, DeriveWith constraint value (Rep a)) => DeriveValueOptions kind constraint value -> a -> DataType value deriveValue ( DeriveValueOptions { __valueApply :: forall a. GValueMapConstraint m a => a -> m (ResolverValue m) __valueApply = forall (m :: * -> *) res. Encode m res => res -> m (ResolverValue m) encodeField, __valueTypeName :: TypeName __valueTypeName = forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *). (GQLType a, CategoryValue kind) => kinded kind a -> TypeName deriveTypename (forall {k} {k} (k :: k) (a :: k). KindedProxy k a KindedProxy :: KindedProxy OUT a), __valueGetType :: forall (f :: * -> *) a. GValueMapConstraint m a => f a -> TypeData __valueGetType = forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a. (GQLType a, CategoryValue kind) => kinded kind a -> TypeData __typeData forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {k1} {k2} (f :: k1 -> *) (k3 :: k1) (f' :: k2 -> *) (a :: k2). f k3 -> f' a -> KindedProxy k3 a kinded (forall {k} (t :: k). Proxy t Proxy @OUT) } :: DeriveValueOptions OUT (GValueMapConstraint m) (m (ResolverValue m)) ) convertNamedNode :: (GQLType a, MonadError GQLError m) => f a -> DataType (m (ResolverValue m)) -> m (NamedResolverResult m) convertNamedNode :: forall a (m :: * -> *) (f :: * -> *). (GQLType a, MonadError GQLError m) => f a -> DataType (m (ResolverValue m)) -> m (NamedResolverResult m) convertNamedNode f a proxy 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} } | forall (t :: * -> *) a. Foldable t => t a -> Bool null [FieldRep (m (ResolverValue m))] consFields = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). TypeName -> NamedResolverResult m NamedEnumResolver TypeName consName | Bool tyIsUnion = forall (m :: * -> *). MonadError GQLError m => [FieldRep (m (ResolverValue m))] -> m (NamedResolverResult m) deriveUnion [FieldRep (m (ResolverValue m))] consFields | Bool otherwise = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). ObjectTypeResolver m -> NamedResolverResult m NamedObjectResolver ObjectTypeResolver { objectFields :: HashMap FieldName (m (ResolverValue m)) objectFields = forall l. IsList l => [Item l] -> l HM.fromList (forall a (f :: * -> *) v. GQLType a => f a -> FieldRep v -> (FieldName, v) toFieldRes f a proxy 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 :: forall (m :: * -> *). MonadError GQLError m => [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 ..}] = forall (m :: * -> *). NamedResolverRef -> NamedResolverResult m NamedUnionResolver forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (m (ResolverValue m) fieldValue forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *). MonadError GQLError m => ResolverValue m -> m NamedResolverRef getRef) deriveUnion [FieldRep (m (ResolverValue 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 :: forall (m :: * -> *). MonadError GQLError m => ResolverValue m -> m NamedResolverRef getRef (ResRef m NamedResolverRef x) = m NamedResolverRef x getRef ResolverValue m _ = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError GQLError "only resolver references are supported!" getTypeName :: GQLType a => f a -> TypeName getTypeName :: forall a (f :: * -> *). GQLType a => f a -> TypeName getTypeName f a proxy = TypeData -> TypeName gqlTypeName forall a b. (a -> b) -> a -> b $ forall a (f :: * -> *). GQLType a => f a -> TypeCategory -> TypeData __type f a proxy TypeCategory OUT