{-# 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 UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.Deriving.Kinded.NamedResolverFun ( deriveNamedResolverFun, KindedNamedFunValue (..), ) where import Control.Monad.Except (MonadError (..)) import Data.Aeson (ToJSON (..)) import Data.Morpheus.App.Internal.Resolving ( MonadResolver (..), NamedResolverRef (..), NamedResolverResult (..), ObjectTypeResolver (..), ResolverValue (..), getArguments, mkList, mkNull, ) import Data.Morpheus.Server.Deriving.Internal.Decode.Utils (useDecodeArguments) import Data.Morpheus.Server.Deriving.Internal.Schema.Directive (UseDeriving, toFieldRes) import Data.Morpheus.Server.Deriving.Utils.GRep ( ConsRep (..), FieldRep (..), GRep, RepContext (..), TypeRep (..), deriveValue, ) import Data.Morpheus.Server.Deriving.Utils.Kinded ( CatType (..), outputType, ) import Data.Morpheus.Server.Deriving.Utils.Proxy ( ContextValue (..), ) import Data.Morpheus.Server.Deriving.Utils.Use ( UseDeriving (..), UseGQLType (..), UseNamedResolver (..), ) import Data.Morpheus.Server.Types.Kind ( CUSTOM, DerivingKind, SCALAR, TYPE, WRAPPER, ) import Data.Morpheus.Server.Types.NamedResolvers ( NamedRef, NamedResolverT (..), ) import Data.Morpheus.Types.GQLScalar ( EncodeScalar (..), ) import Data.Morpheus.Types.Internal.AST ( GQLError, OUT, TypeName, ValidValue, Value (List), internal, replaceValue, ) import qualified GHC.Exts as HM import GHC.Generics ( Generic (..), ) import Relude hiding (empty) deriveNamedResolverFun :: ( Generic a, gql [Maybe a], gql a, MonadError GQLError m, GRep gql (res m) (m (ResolverValue m)) (Rep a) ) => UseNamedResolver namedRes res gql val -> [Maybe a] -> m [NamedResolverResult m] deriveNamedResolverFun :: forall a (gql :: * -> Constraint) (m :: * -> *) (res :: (* -> *) -> * -> Constraint) (namedRes :: (* -> *) -> * -> Constraint) (val :: * -> Constraint). (Generic a, gql [Maybe a], gql a, MonadError GQLError m, GRep gql (res m) (m (ResolverValue m)) (Rep a)) => UseNamedResolver namedRes res gql val -> [Maybe a] -> m [NamedResolverResult m] deriveNamedResolverFun UseNamedResolver namedRes res gql val ctx [Maybe a] x = forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse Maybe a -> m (NamedResolverResult m) encodeNode [Maybe a] x where encodeNode :: Maybe a -> m (NamedResolverResult m) encodeNode (Just a v) = forall (gql :: * -> Constraint) a (m :: * -> *) (val :: * -> Constraint) (f :: * -> *). (gql a, MonadError GQLError m) => UseDeriving gql val -> f a -> TypeRep (m (ResolverValue m)) -> m (NamedResolverResult m) convertNamedNode (forall (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> UseDeriving gql val namedDrv UseNamedResolver namedRes res gql val ctx) (forall a. a -> Identity a Identity [Maybe a] x) (forall a (gql :: * -> Constraint) (constraint :: * -> Constraint) value. (Generic a, GRep gql constraint value (Rep a), gql a) => RepContext gql constraint Identity value -> a -> TypeRep value deriveValue (forall (namedRes :: (* -> *) -> * -> Constraint) (res :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint) (m :: * -> *). UseNamedResolver namedRes res gql val -> RepContext gql (res m) Identity (m (ResolverValue m)) getOptions UseNamedResolver namedRes res gql val ctx) a v) encodeNode Maybe a Nothing = forall (f :: * -> *) a. Applicative f => a -> f a pure forall (m :: * -> *). NamedResolverResult m NamedNullResolver class KindedNamedFunValue res gql val (k :: DerivingKind) (m :: Type -> Type) (a :: Type) where kindedNamedFunValue :: UseNamedResolver namedRes res gql val -> ContextValue k a -> m (ResolverValue m) instance (EncodeScalar a, Monad m) => KindedNamedFunValue res gql val SCALAR m a where kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint). UseNamedResolver namedRes res gql val -> ContextValue SCALAR a -> m (ResolverValue m) kindedNamedFunValue UseNamedResolver namedRes res gql val _ = 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 (MonadError GQLError m) => KindedNamedFunValue res gql val TYPE m a where kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint). UseNamedResolver namedRes res gql val -> ContextValue TYPE a -> m (ResolverValue m) kindedNamedFunValue UseNamedResolver namedRes res gql val _ (ContextValue a _) = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> GQLError internal GQLError "types are resolved by Refs") instance (Applicative m, res m a) => KindedNamedFunValue res gql val WRAPPER m [a] where kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint). UseNamedResolver namedRes res gql val -> ContextValue WRAPPER [a] -> m (ResolverValue m) kindedNamedFunValue UseNamedResolver namedRes res gql val ctx = 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 (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> forall a (m :: * -> *). fun m a => a -> m (ResolverValue m) useNamedFieldResolver UseNamedResolver namedRes res gql val ctx) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (kind :: DerivingKind) a. ContextValue kind a -> a unContextValue instance (gql a, res m a, Applicative m) => KindedNamedFunValue res gql val WRAPPER m (Maybe a) where kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint). UseNamedResolver namedRes res gql val -> ContextValue WRAPPER (Maybe a) -> m (ResolverValue m) kindedNamedFunValue UseNamedResolver namedRes res gql val ctx (ContextValue (Just a x)) = forall (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> forall a (m :: * -> *). fun m a => a -> m (ResolverValue m) useNamedFieldResolver UseNamedResolver namedRes res gql val ctx a x kindedNamedFunValue UseNamedResolver namedRes res gql val _ (ContextValue Maybe a Nothing) = forall (f :: * -> *) a. Applicative f => a -> f a pure forall (m :: * -> *). ResolverValue m mkNull instance (Monad m, gql a, ToJSON (NamedRef a)) => KindedNamedFunValue res gql val CUSTOM m (NamedResolverT m a) where kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint). UseNamedResolver namedRes res gql val -> ContextValue CUSTOM (NamedResolverT m a) -> m (ResolverValue m) kindedNamedFunValue UseNamedResolver namedRes res gql val ctx = 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 (gql :: * -> Constraint). UseGQLType gql -> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeName useTypename (forall (gql :: * -> Constraint) (val :: * -> Constraint). UseDeriving gql val -> UseGQLType gql dirGQL (forall (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> UseDeriving gql val namedDrv UseNamedResolver namedRes res gql val ctx)) (forall {k} (a :: k). CatType OUT a OutputType :: CatType OUT a) encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m) encodeRef :: Monad m => NamedResolverT m a -> m (ResolverValue m) encodeRef (NamedResolverT m (NamedRef a) ref) = do Value VALID value <- 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 (NamedRef a) ref case Value VALID value of (List [Value VALID] ls) -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). [ResolverValue m] -> ResolverValue m mkList forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (forall (m :: * -> *). Applicative m => TypeName -> Value VALID -> ResolverValue m packRef TypeName name) [Value VALID] ls Value VALID _ -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Applicative m => TypeName -> Value VALID -> ResolverValue m packRef TypeName name Value VALID value packRef :: Applicative m => TypeName -> ValidValue -> ResolverValue m packRef :: forall (m :: * -> *). Applicative m => TypeName -> Value VALID -> ResolverValue m packRef TypeName name Value VALID v = forall (m :: * -> *). m NamedResolverRef -> ResolverValue m ResRef forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ TypeName -> [Value VALID] -> NamedResolverRef NamedResolverRef TypeName name [Value VALID v] instance (Monad m, val a, MonadResolver m, res m b) => KindedNamedFunValue res gql val CUSTOM m (a -> b) where kindedNamedFunValue :: forall (namedRes :: (* -> *) -> * -> Constraint). UseNamedResolver namedRes res gql val -> ContextValue CUSTOM (a -> b) -> m (ResolverValue m) kindedNamedFunValue UseNamedResolver namedRes res gql val ctx (ContextValue a -> b f) = forall (m :: * -> *). MonadResolver m => m (Arguments VALID) getArguments forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *) a. MonadResolver m => ResolverState a -> m a liftState forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (val :: * -> Constraint) a (gql :: * -> Constraint). val a => UseDeriving gql val -> Arguments VALID -> ResolverState a useDecodeArguments (forall (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> UseDeriving gql val namedDrv UseNamedResolver namedRes res gql val ctx) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> forall a (m :: * -> *). fun m a => a -> m (ResolverValue m) useNamedFieldResolver UseNamedResolver namedRes res gql val ctx forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> b f getOptions :: UseNamedResolver namedRes res gql val -> RepContext gql (res m) Identity (m (ResolverValue m)) getOptions :: forall (namedRes :: (* -> *) -> * -> Constraint) (res :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint) (m :: * -> *). UseNamedResolver namedRes res gql val -> RepContext gql (res m) Identity (m (ResolverValue m)) getOptions UseNamedResolver {UseDeriving gql val forall a (m :: * -> *). res m a => a -> m (ResolverValue m) forall (f :: * -> *) a (m :: * -> *). namedRes m a => f a -> [NamedResolver m] forall (f :: * -> *) a (m :: * -> *). namedRes m a => f a -> [ScanRef (namedRes m)] useDeriveNamedRefs :: forall (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> forall (f :: * -> *) a (m :: * -> *). named m a => f a -> [ScanRef (named m)] useDeriveNamedResolvers :: forall (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> forall (f :: * -> *) a (m :: * -> *). named m a => f a -> [NamedResolver m] namedDrv :: UseDeriving gql val useDeriveNamedRefs :: forall (f :: * -> *) a (m :: * -> *). namedRes m a => f a -> [ScanRef (namedRes m)] useDeriveNamedResolvers :: forall (f :: * -> *) a (m :: * -> *). namedRes m a => f a -> [NamedResolver m] useNamedFieldResolver :: forall a (m :: * -> *). res m a => a -> m (ResolverValue m) useNamedFieldResolver :: forall (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> forall a (m :: * -> *). fun m a => a -> m (ResolverValue m) namedDrv :: forall (named :: (* -> *) -> * -> Constraint) (fun :: (* -> *) -> * -> Constraint) (gql :: * -> Constraint) (val :: * -> Constraint). UseNamedResolver named fun gql val -> UseDeriving gql val ..} = RepContext { optApply :: forall a. res m a => Identity a -> m (ResolverValue m) optApply = forall a (m :: * -> *). res m a => a -> m (ResolverValue m) useNamedFieldResolver forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Identity a -> a runIdentity, optTypeData :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeData optTypeData = forall (gql :: * -> Constraint). UseGQLType gql -> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeData useTypeData (forall (gql :: * -> Constraint) (val :: * -> Constraint). UseDeriving gql val -> UseGQLType gql dirGQL UseDeriving gql val namedDrv) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a outputType } convertNamedNode :: (gql a, MonadError GQLError m) => UseDeriving gql val -> f a -> TypeRep (m (ResolverValue m)) -> m (NamedResolverResult m) convertNamedNode :: forall (gql :: * -> Constraint) a (m :: * -> *) (val :: * -> Constraint) (f :: * -> *). (gql a, MonadError GQLError m) => UseDeriving gql val -> f a -> TypeRep (m (ResolverValue m)) -> m (NamedResolverResult m) convertNamedNode UseDeriving gql val drv f a proxy TypeRep { Bool tyIsUnion :: forall v. TypeRep v -> Bool tyIsUnion :: Bool tyIsUnion, tyCons :: forall v. TypeRep 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 (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *) v. gql a => UseDeriving gql args -> f a -> FieldRep v -> (FieldName, v) toFieldRes UseDeriving gql val drv 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!"