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