{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.App.Internal.Resolving.SchemaAPI ( schemaAPI, ) where import Data.Morpheus.App.Internal.Resolving.MonadResolver ( MonadResolver (..), withArguments, ) import Data.Morpheus.App.Internal.Resolving.Types ( ObjectTypeResolver (..), ResolverValue, mkList, mkNull, mkObject, ) import Data.Morpheus.App.RenderIntrospection ( 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 :: MonadResolver m => Schema VALID -> m (ResolverValue m) resolveTypes :: forall (m :: * -> *). MonadResolver 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, MonadResolver 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 :: MonadResolver m => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation :: forall (m :: * -> *). MonadResolver 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 :: * -> *). MonadResolver 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 :: MonadResolver m => TypeName -> Schema VALID -> m (ResolverValue m) findType :: forall (m :: * -> *). MonadResolver 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, MonadResolver 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 :: MonadResolver m => Schema VALID -> m (ResolverValue m) schemaResolver :: forall (m :: * -> *). MonadResolver 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 :: * -> *). MonadResolver m => Schema VALID -> m (ResolverValue m) resolveTypes Schema VALID schema), (FieldName "queryType", forall (m :: * -> *). MonadResolver m => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation (forall a. a -> Maybe a Just TypeDefinition OBJECT VALID query)), (FieldName "mutationType", forall (m :: * -> *). MonadResolver m => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation Maybe (TypeDefinition OBJECT VALID) mutation), (FieldName "subscriptionType", forall (m :: * -> *). MonadResolver m => Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m) renderOperation Maybe (TypeDefinition OBJECT VALID) subscription), (FieldName "directives", forall a (m :: * -> *). (RenderIntrospection a, MonadResolver 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 :: ( MonadOperation m ~ QUERY, MonadResolver m ) => Schema VALID -> ObjectTypeResolver m schemaAPI :: forall (m :: * -> *). (MonadOperation m ~ QUERY, MonadResolver m) => Schema VALID -> ObjectTypeResolver 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 (m :: * -> *) a. MonadResolver m => (Arguments VALID -> m a) -> m a withArguments Arguments VALID -> m (ResolverValue m) typeResolver), (FieldName "__schema", forall (m :: * -> *). MonadResolver m => Schema VALID -> m (ResolverValue m) schemaResolver Schema VALID schema) ] ) where typeResolver :: Arguments VALID -> m (ResolverValue 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) 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 :: * -> *). MonadResolver 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