{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Schema.SchemaAPI
  ( withSystemFields,
  )
where

import Data.Morpheus.Ext.SemigroupM ((<:>))
import Data.Morpheus.Internal.Utils
  ( elems,
    empty,
    selectOr,
  )
import Data.Morpheus.Rendering.RenderIntrospection
  ( createObjectType,
    render,
  )
import Data.Morpheus.Schema.Schema
  (
  )
import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    FieldName,
    OBJECT,
    QUERY,
    ScalarValue (..),
    Schema (..),
    TypeDefinition (..),
    TypeName (..),
    VALID,
    Value (..),
  )
import Data.Morpheus.Types.Internal.Resolving
  ( ResModel,
    Resolver,
    ResultT,
    RootResModel (..),
    mkList,
    mkNull,
    mkObject,
    withArguments,
  )
import Relude hiding (empty)

resolveTypes ::
  Monad m => Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)
resolveTypes :: Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)
resolveTypes Schema VALID
schema = [ResModel QUERY e m] -> ResModel QUERY e m
forall (o :: OperationType) e (m :: * -> *).
[ResModel o e m] -> ResModel o e m
mkList ([ResModel QUERY e m] -> ResModel QUERY e m)
-> Resolver QUERY e m [ResModel QUERY e m]
-> Resolver QUERY e m (ResModel QUERY e m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeDefinition ANY VALID
 -> Resolver QUERY e m (ResModel QUERY e m))
-> [TypeDefinition ANY VALID]
-> Resolver QUERY e m [ResModel QUERY e m]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeDefinition ANY VALID -> Resolver QUERY e m (ResModel QUERY e m)
forall a (m :: * -> *) e.
(RenderIntrospection a, Monad m) =>
a -> Resolver QUERY e m (ResModel QUERY e m)
render (Schema VALID -> [TypeDefinition ANY VALID]
forall a coll. Elems a coll => coll -> [a]
elems Schema VALID
schema)

renderOperation ::
  Monad m =>
  Maybe (TypeDefinition OBJECT VALID) ->
  Resolver QUERY e m (ResModel QUERY e m)
renderOperation :: Maybe (TypeDefinition OBJECT VALID)
-> Resolver QUERY e m (ResModel QUERY e m)
renderOperation (Just TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName}) = ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m))
-> ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m)
forall a b. (a -> b) -> a -> b
$ TypeName
-> Maybe Description
-> [TypeName]
-> FieldsDefinition OUT VALID
-> ResModel QUERY e m
forall (m :: * -> *) e.
Monad m =>
TypeName
-> Maybe Description
-> [TypeName]
-> FieldsDefinition OUT VALID
-> ResModel QUERY e m
createObjectType TypeName
typeName Maybe Description
forall a. Maybe a
Nothing [] FieldsDefinition OUT VALID
forall a coll. Collection a coll => coll
empty
renderOperation Maybe (TypeDefinition OBJECT VALID)
Nothing = ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResModel QUERY e m
forall (o :: OperationType) e (m :: * -> *). ResModel o e m
mkNull

findType ::
  Monad m =>
  TypeName ->
  Schema VALID ->
  Resolver QUERY e m (ResModel QUERY e m)
findType :: TypeName -> Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)
findType = Resolver QUERY e m (ResModel QUERY e m)
-> (TypeDefinition ANY VALID
    -> Resolver QUERY e m (ResModel QUERY e m))
-> TypeName
-> Schema VALID
-> Resolver QUERY e m (ResModel QUERY e m)
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr (ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResModel QUERY e m
forall (o :: OperationType) e (m :: * -> *). ResModel o e m
mkNull) TypeDefinition ANY VALID -> Resolver QUERY e m (ResModel QUERY e m)
forall a (m :: * -> *) e.
(RenderIntrospection a, Monad m) =>
a -> Resolver QUERY e m (ResModel QUERY e m)
render

schemaResolver ::
  Monad m =>
  Schema VALID ->
  Resolver QUERY e m (ResModel QUERY e m)
schemaResolver :: Schema VALID -> Resolver QUERY e m (ResModel QUERY e 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, [DirectiveDefinition VALID]
directiveDefinitions :: forall (s :: Stage). Schema s -> [DirectiveDefinition s]
directiveDefinitions :: [DirectiveDefinition VALID]
directiveDefinitions} =
  ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m))
-> ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m)
forall a b. (a -> b) -> a -> b
$
    TypeName
-> [(FieldName, Resolver QUERY e m (ResModel QUERY e m))]
-> ResModel QUERY e m
forall (o :: OperationType) e (m :: * -> *).
TypeName
-> [(FieldName, Resolver o e m (ResModel o e m))] -> ResModel o e m
mkObject
      TypeName
"__Schema"
      [ (FieldName
"types", Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)
forall (m :: * -> *) e.
Monad m =>
Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)
resolveTypes Schema VALID
schema),
        (FieldName
"queryType", Maybe (TypeDefinition OBJECT VALID)
-> Resolver QUERY e m (ResModel QUERY e m)
forall (m :: * -> *) e.
Monad m =>
Maybe (TypeDefinition OBJECT VALID)
-> Resolver QUERY e m (ResModel QUERY e 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)
-> Resolver QUERY e m (ResModel QUERY e m)
forall (m :: * -> *) e.
Monad m =>
Maybe (TypeDefinition OBJECT VALID)
-> Resolver QUERY e m (ResModel QUERY e m)
renderOperation Maybe (TypeDefinition OBJECT VALID)
mutation),
        (FieldName
"subscriptionType", Maybe (TypeDefinition OBJECT VALID)
-> Resolver QUERY e m (ResModel QUERY e m)
forall (m :: * -> *) e.
Monad m =>
Maybe (TypeDefinition OBJECT VALID)
-> Resolver QUERY e m (ResModel QUERY e m)
renderOperation Maybe (TypeDefinition OBJECT VALID)
subscription),
        (FieldName
"directives", [DirectiveDefinition VALID]
-> Resolver QUERY e m (ResModel QUERY e m)
forall a (m :: * -> *) e.
(RenderIntrospection a, Monad m) =>
a -> Resolver QUERY e m (ResModel QUERY e m)
render [DirectiveDefinition VALID]
directiveDefinitions)
      ]

schemaAPI :: Monad m => Schema VALID -> ResModel QUERY e m
schemaAPI :: Schema VALID -> ResModel QUERY e m
schemaAPI Schema VALID
schema =
  TypeName
-> [(FieldName, Resolver QUERY e m (ResModel QUERY e m))]
-> ResModel QUERY e m
forall (o :: OperationType) e (m :: * -> *).
TypeName
-> [(FieldName, Resolver o e m (ResModel o e m))] -> ResModel o e m
mkObject
    TypeName
"Root"
    [ (FieldName
"__type", (Arguments VALID -> Resolver QUERY e m (ResModel QUERY e m))
-> Resolver QUERY e m (ResModel 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 (ResModel QUERY e m)
forall e.
Arguments VALID -> Resolver QUERY e m (ResModel QUERY e m)
typeResolver),
      (FieldName
"__schema", Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)
forall (m :: * -> *) e.
Monad m =>
Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)
schemaResolver Schema VALID
schema)
    ]
  where
    typeResolver :: Arguments VALID -> Resolver QUERY e m (ResModel QUERY e m)
typeResolver = Resolver QUERY e m (ResModel QUERY e m)
-> (Argument VALID -> Resolver QUERY e m (ResModel QUERY e m))
-> FieldName
-> Arguments VALID
-> Resolver QUERY e m (ResModel QUERY e m)
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr (ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResModel QUERY e m
forall (o :: OperationType) e (m :: * -> *). ResModel o e m
mkNull) Argument VALID -> Resolver QUERY e m (ResModel QUERY e m)
forall (m :: * -> *) (valid :: Stage) e.
Monad m =>
Argument valid -> Resolver QUERY e m (ResModel QUERY e m)
handleArg (FieldName
"name" :: FieldName)
      where
        handleArg :: Argument valid -> Resolver QUERY e m (ResModel QUERY e m)
handleArg
          Argument
            { argumentValue :: forall (valid :: Stage). Argument valid -> Value valid
argumentValue = (Scalar (String Description
typename))
            } = TypeName -> Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)
forall (m :: * -> *) e.
Monad m =>
TypeName -> Schema VALID -> Resolver QUERY e m (ResModel QUERY e m)
findType (Description -> TypeName
TypeName Description
typename) Schema VALID
schema
        handleArg Argument valid
_ = ResModel QUERY e m -> Resolver QUERY e m (ResModel QUERY e m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResModel QUERY e m
forall (o :: OperationType) e (m :: * -> *). ResModel o e m
mkNull

withSystemFields ::
  Monad m =>
  Schema VALID ->
  RootResModel e m ->
  ResultT e' m (RootResModel e m)
withSystemFields :: Schema VALID -> RootResModel e m -> ResultT e' m (RootResModel e m)
withSystemFields Schema VALID
schema RootResModel {ResolverState (ResModel QUERY e m)
query :: forall e (m :: * -> *).
RootResModel e m -> ResolverState (ResModel QUERY e m)
query :: ResolverState (ResModel QUERY e m)
query, Maybe (Selection VALID -> ResolverState (Channel e))
ResolverState (ResModel SUBSCRIPTION e m)
ResolverState (ResModel MUTATION e m)
channelMap :: forall e (m :: * -> *).
RootResModel e m
-> Maybe (Selection VALID -> ResolverState (Channel e))
subscription :: forall e (m :: * -> *).
RootResModel e m -> ResolverState (ResModel SUBSCRIPTION e m)
mutation :: forall e (m :: * -> *).
RootResModel e m -> ResolverState (ResModel MUTATION e m)
channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
subscription :: ResolverState (ResModel SUBSCRIPTION e m)
mutation :: ResolverState (ResModel MUTATION e m)
..} =
  RootResModel e m -> ResultT e' m (RootResModel e m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RootResModel e m -> ResultT e' m (RootResModel e m))
-> RootResModel e m -> ResultT e' m (RootResModel e m)
forall a b. (a -> b) -> a -> b
$
    RootResModel :: forall e (m :: * -> *).
ResolverState (ResModel QUERY e m)
-> ResolverState (ResModel MUTATION e m)
-> ResolverState (ResModel SUBSCRIPTION e m)
-> Maybe (Selection VALID -> ResolverState (Channel e))
-> RootResModel e m
RootResModel
      { query :: ResolverState (ResModel QUERY e m)
query = ResolverState (ResModel QUERY e m)
query ResolverState (ResModel QUERY e m)
-> (ResModel QUERY e m -> ResolverState (ResModel QUERY e m))
-> ResolverState (ResModel QUERY e m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ResModel QUERY e m
-> ResModel QUERY e m -> ResolverState (ResModel QUERY e m)
forall (m :: * -> *) a. SemigroupM m a => a -> a -> m a
<:> Schema VALID -> ResModel QUERY e m
forall (m :: * -> *) e.
Monad m =>
Schema VALID -> ResModel QUERY e m
schemaAPI Schema VALID
schema),
        Maybe (Selection VALID -> ResolverState (Channel e))
ResolverState (ResModel SUBSCRIPTION e m)
ResolverState (ResModel MUTATION e m)
channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
subscription :: ResolverState (ResModel SUBSCRIPTION e m)
mutation :: ResolverState (ResModel MUTATION e m)
channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
subscription :: ResolverState (ResModel SUBSCRIPTION e m)
mutation :: ResolverState (ResModel MUTATION e m)
..
      }