{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.App.Internal.Resolving.SchemaAPI ( schemaAPI, ) where import Data.Morpheus.App.Internal.Resolving.Resolver (Resolver, withArguments) import Data.Morpheus.App.Internal.Resolving.Types ( ObjectTypeResolver (..), ResolverValue, mkList, mkNull, mkObject, ) import Data.Morpheus.App.RenderIntrospection ( WithSchema, createObjectType, render, ) import Data.Morpheus.Internal.Utils ( empty, selectOr, ) import Data.Morpheus.Types.Internal.AST ( Argument (..), FieldName, OBJECT, QUERY, ScalarValue (..), Schema (..), TypeDefinition (..), TypeName, VALID, Value (..), packName, typeDefinitions, ) import Relude hiding (empty) import qualified Relude as HM resolveTypes :: (Monad m, WithSchema m) => Schema VALID -> m (ResolverValue m) resolveTypes :: Schema VALID -> m (ResolverValue m) resolveTypes Schema VALID schema = [ResolverValue m] -> ResolverValue m forall (m :: * -> *). [ResolverValue m] -> ResolverValue m mkList ([ResolverValue m] -> ResolverValue m) -> m [ResolverValue m] -> m (ResolverValue m) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (TypeDefinition ANY VALID -> m (ResolverValue m)) -> [TypeDefinition ANY VALID] -> m [ResolverValue m] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse TypeDefinition ANY VALID -> m (ResolverValue m) forall a (m :: * -> *). (RenderIntrospection a, Monad m, WithSchema m) => a -> m (ResolverValue m) render (HashMap TypeName (TypeDefinition ANY VALID) -> [TypeDefinition ANY VALID] forall (t :: * -> *) a. Foldable t => t a -> [a] toList (HashMap TypeName (TypeDefinition ANY VALID) -> [TypeDefinition ANY VALID]) -> HashMap TypeName (TypeDefinition ANY VALID) -> [TypeDefinition ANY VALID] forall a b. (a -> b) -> a -> b $ Schema VALID -> HashMap TypeName (TypeDefinition ANY VALID) forall (s :: Stage). Schema s -> HashMap TypeName (TypeDefinition ANY s) typeDefinitions Schema VALID schema) renderOperation :: (Monad m, WithSchema m) => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation :: Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation (Just TypeDefinition {TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName :: TypeName typeName}) = 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 $ TypeName -> Maybe Description -> [TypeName] -> FieldsDefinition OUT VALID -> ResolverValue m forall (m :: * -> *). (Monad m, WithSchema m) => TypeName -> Maybe Description -> [TypeName] -> FieldsDefinition OUT VALID -> ResolverValue m createObjectType TypeName typeName Maybe Description forall a. Maybe a Nothing [] FieldsDefinition OUT VALID forall coll. Empty coll => coll empty renderOperation Maybe (TypeDefinition OBJECT VALID) Nothing = ResolverValue m -> m (ResolverValue m) forall (f :: * -> *) a. Applicative f => a -> f a pure ResolverValue m forall (m :: * -> *). ResolverValue m mkNull findType :: (Monad m, WithSchema m) => TypeName -> Schema VALID -> m (ResolverValue m) findType :: TypeName -> Schema VALID -> m (ResolverValue m) findType TypeName name = m (ResolverValue m) -> (TypeDefinition ANY VALID -> m (ResolverValue m)) -> TypeName -> HashMap TypeName (TypeDefinition ANY VALID) -> m (ResolverValue m) forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr (ResolverValue m -> m (ResolverValue m) forall (f :: * -> *) a. Applicative f => a -> f a pure ResolverValue m forall (m :: * -> *). ResolverValue m mkNull) TypeDefinition ANY VALID -> m (ResolverValue m) forall a (m :: * -> *). (RenderIntrospection a, Monad m, WithSchema m) => a -> m (ResolverValue m) render TypeName name (HashMap TypeName (TypeDefinition ANY VALID) -> m (ResolverValue m)) -> (Schema VALID -> HashMap TypeName (TypeDefinition ANY VALID)) -> Schema VALID -> m (ResolverValue m) forall b c a. (b -> c) -> (a -> b) -> a -> c . Schema VALID -> HashMap TypeName (TypeDefinition ANY VALID) forall (s :: Stage). Schema s -> HashMap TypeName (TypeDefinition ANY s) typeDefinitions schemaResolver :: (Monad m, WithSchema m) => Schema VALID -> m (ResolverValue m) schemaResolver :: Schema VALID -> m (ResolverValue m) schemaResolver schema :: Schema VALID schema@Schema {TypeDefinition OBJECT VALID query :: forall (s :: Stage). Schema s -> TypeDefinition OBJECT s query :: TypeDefinition OBJECT VALID query, Maybe (TypeDefinition OBJECT VALID) mutation :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s) mutation :: Maybe (TypeDefinition OBJECT VALID) mutation, Maybe (TypeDefinition OBJECT VALID) subscription :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s) subscription :: Maybe (TypeDefinition OBJECT VALID) subscription, DirectivesDefinition VALID directiveDefinitions :: forall (s :: Stage). Schema s -> DirectivesDefinition s directiveDefinitions :: DirectivesDefinition VALID directiveDefinitions} = 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 $ TypeName -> [ResolverEntry m] -> ResolverValue m forall (m :: * -> *). TypeName -> [ResolverEntry m] -> ResolverValue m mkObject TypeName "__Schema" [ (FieldName "types", Schema VALID -> m (ResolverValue m) forall (m :: * -> *). (Monad m, WithSchema m) => Schema VALID -> m (ResolverValue m) resolveTypes Schema VALID schema), (FieldName "queryType", Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) forall (m :: * -> *). (Monad m, WithSchema m) => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation (TypeDefinition OBJECT VALID -> Maybe (TypeDefinition OBJECT VALID) forall a. a -> Maybe a Just TypeDefinition OBJECT VALID query)), (FieldName "mutationType", Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) forall (m :: * -> *). (Monad m, WithSchema m) => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation Maybe (TypeDefinition OBJECT VALID) mutation), (FieldName "subscriptionType", Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) forall (m :: * -> *). (Monad m, WithSchema m) => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation Maybe (TypeDefinition OBJECT VALID) subscription), (FieldName "directives", [DirectiveDefinition VALID] -> m (ResolverValue m) forall a (m :: * -> *). (RenderIntrospection a, Monad m, WithSchema m) => a -> m (ResolverValue m) render ([DirectiveDefinition VALID] -> m (ResolverValue m)) -> [DirectiveDefinition VALID] -> m (ResolverValue m) forall a b. (a -> b) -> a -> b $ DirectivesDefinition VALID -> [DirectiveDefinition VALID] forall (t :: * -> *) a. Foldable t => t a -> [a] toList DirectivesDefinition VALID directiveDefinitions) ] schemaAPI :: Monad m => Schema VALID -> ObjectTypeResolver (Resolver QUERY e m) schemaAPI :: Schema VALID -> ObjectTypeResolver (Resolver QUERY e m) schemaAPI Schema VALID schema = HashMap FieldName (Resolver QUERY e m (ResolverValue (Resolver QUERY e m))) -> ObjectTypeResolver (Resolver QUERY e m) forall (m :: * -> *). HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m ObjectTypeResolver ( [Item (HashMap FieldName (Resolver QUERY e m (ResolverValue (Resolver QUERY e m))))] -> HashMap FieldName (Resolver QUERY e m (ResolverValue (Resolver QUERY e m))) forall l. IsList l => [Item l] -> l HM.fromList [ (FieldName "__type", (Arguments VALID -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m))) -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) forall (o :: OperationType) (m :: * -> *) e a. (LiftOperation o, Monad m) => (Arguments VALID -> Resolver o e m a) -> Resolver o e m a withArguments Arguments VALID -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) forall (valid :: Stage). OrdMap FieldName (Argument valid) -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) typeResolver), (FieldName "__schema", Schema VALID -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) forall (m :: * -> *). (Monad m, WithSchema m) => Schema VALID -> m (ResolverValue m) schemaResolver Schema VALID schema) ] ) where typeResolver :: OrdMap FieldName (Argument valid) -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) typeResolver = Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) -> (Argument valid -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m))) -> FieldName -> OrdMap FieldName (Argument valid) -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr (ResolverValue (Resolver QUERY e m) -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) forall (f :: * -> *) a. Applicative f => a -> f a pure ResolverValue (Resolver QUERY e m) forall (m :: * -> *). ResolverValue m mkNull) Argument valid -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) forall (m :: * -> *) (valid :: Stage). WithSchema m => Argument valid -> m (ResolverValue m) handleArg (FieldName "name" :: FieldName) where handleArg :: Argument valid -> m (ResolverValue m) handleArg Argument { argumentValue :: forall (valid :: Stage). Argument valid -> Value valid argumentValue = (Scalar (String Description typename)) } = TypeName -> Schema VALID -> m (ResolverValue m) forall (m :: * -> *). (Monad m, WithSchema m) => TypeName -> Schema VALID -> m (ResolverValue m) findType (Description -> TypeName forall a (t :: NAME). NamePacking a => a -> Name t packName Description typename) Schema VALID schema handleArg Argument valid _ = ResolverValue m -> m (ResolverValue m) forall (f :: * -> *) a. Applicative f => a -> f a pure ResolverValue m forall (m :: * -> *). ResolverValue m mkNull