{-# 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