{-# 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 (..), DirectiveDefinition (..), 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 :: forall (m :: * -> *). (Monad m, WithSchema m) => Schema VALID -> m (ResolverValue m) resolveTypes Schema VALID schema = forall (m :: * -> *). [ResolverValue m] -> ResolverValue m mkList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse forall a (m :: * -> *). (RenderIntrospection a, Monad m, WithSchema m) => a -> m (ResolverValue m) render (forall (t :: * -> *) a. Foldable t => t a -> [a] toList forall a b. (a -> b) -> a -> b $ 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 :: forall (m :: * -> *). (Monad m, WithSchema m) => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation (Just TypeDefinition {TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName :: TypeName typeName}) = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). (Monad m, WithSchema m) => TypeName -> Maybe Description -> [TypeName] -> FieldsDefinition OUT VALID -> ResolverValue m createObjectType TypeName typeName forall a. Maybe a Nothing [] forall coll. Empty coll => coll empty renderOperation Maybe (TypeDefinition OBJECT VALID) Nothing = forall (f :: * -> *) a. Applicative f => a -> f a pure forall (m :: * -> *). ResolverValue m mkNull findType :: (Monad m, WithSchema m) => TypeName -> Schema VALID -> m (ResolverValue m) findType :: forall (m :: * -> *). (Monad m, WithSchema m) => TypeName -> Schema VALID -> m (ResolverValue m) findType TypeName name = forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr (forall (f :: * -> *) a. Applicative f => a -> f a pure forall (m :: * -> *). ResolverValue m mkNull) forall a (m :: * -> *). (RenderIntrospection a, Monad m, WithSchema m) => a -> m (ResolverValue m) render TypeName name forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (s :: Stage). Schema s -> HashMap TypeName (TypeDefinition ANY s) typeDefinitions schemaResolver :: (Monad m, WithSchema m) => Schema VALID -> m (ResolverValue m) schemaResolver :: forall (m :: * -> *). (Monad m, WithSchema m) => 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} = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). TypeName -> [ResolverEntry m] -> ResolverValue m mkObject TypeName "__Schema" [ (FieldName "types", forall (m :: * -> *). (Monad m, WithSchema m) => Schema VALID -> m (ResolverValue m) resolveTypes Schema VALID schema), (FieldName "queryType", forall (m :: * -> *). (Monad m, WithSchema m) => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation (forall a. a -> Maybe a Just TypeDefinition OBJECT VALID query)), (FieldName "mutationType", forall (m :: * -> *). (Monad m, WithSchema m) => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation Maybe (TypeDefinition OBJECT VALID) mutation), (FieldName "subscriptionType", forall (m :: * -> *). (Monad m, WithSchema m) => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation Maybe (TypeDefinition OBJECT VALID) subscription), (FieldName "directives", forall a (m :: * -> *). (RenderIntrospection a, Monad m, WithSchema m) => a -> m (ResolverValue m) render forall a b. (a -> b) -> a -> b $ forall b a. Ord b => (a -> b) -> [a] -> [a] sortWith forall (s :: Stage). DirectiveDefinition s -> FieldName directiveDefinitionName forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t a -> [a] toList DirectivesDefinition VALID directiveDefinitions) ] schemaAPI :: Monad m => Schema VALID -> ObjectTypeResolver (Resolver QUERY e m) schemaAPI :: forall (m :: * -> *) e. Monad m => Schema VALID -> ObjectTypeResolver (Resolver QUERY e m) schemaAPI Schema VALID schema = forall (m :: * -> *). HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m ObjectTypeResolver ( forall l. IsList l => [Item l] -> l HM.fromList [ (FieldName "__type", forall (o :: OperationType) (m :: * -> *) e a. (LiftOperation o, Monad m) => (Arguments VALID -> Resolver o e m a) -> Resolver o e m a withArguments forall {valid :: Stage}. OrdMap FieldName (Argument valid) -> Resolver QUERY e m (ResolverValue (Resolver QUERY e m)) typeResolver), (FieldName "__schema", 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 = forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr (forall (f :: * -> *) a. Applicative f => a -> f a pure forall (m :: * -> *). ResolverValue m mkNull) 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)) } = forall (m :: * -> *). (Monad m, WithSchema m) => TypeName -> Schema VALID -> m (ResolverValue m) findType (forall a (t :: NAME). NamePacking a => a -> Name t packName Description typename) Schema VALID schema handleArg Argument valid _ = forall (f :: * -> *) a. Applicative f => a -> f a pure forall (m :: * -> *). ResolverValue m mkNull