{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Resolving.SchemaAPI
  ( schemaAPI,
  )
where

import Data.Morpheus.App.Internal.Resolving.MonadResolver
  ( MonadResolver (..),
    ResolverContext (..),
    getArgument,
  )
import Data.Morpheus.App.Internal.Resolving.Types
  ( ObjectTypeResolver (..),
    ResolverValue,
    mkNull,
    mkObject,
  )
import Data.Morpheus.App.RenderIntrospection
  ( renderI,
  )
import Data.Morpheus.Internal.Utils
  ( IsMap (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( DirectiveDefinition (..),
    QUERY,
    ScalarValue (..),
    Schema (..),
    VALID,
    Value (..),
    packName,
    typeDefinitions,
  )
import Relude hiding (empty)

resolveSchema :: (MonadResolver m) => Schema VALID -> m (ResolverValue m)
resolveSchema :: forall (m :: * -> *).
MonadResolver m =>
Schema VALID -> m (ResolverValue m)
resolveSchema schema :: Schema VALID
schema@Schema {Maybe (TypeDefinition OBJECT VALID)
TypeDefinition OBJECT VALID
TypeDefinitions VALID
DirectivesDefinition VALID
types :: TypeDefinitions VALID
query :: TypeDefinition OBJECT VALID
mutation :: Maybe (TypeDefinition OBJECT VALID)
subscription :: Maybe (TypeDefinition OBJECT VALID)
directiveDefinitions :: DirectivesDefinition VALID
types :: forall (s :: Stage). Schema s -> TypeDefinitions s
query :: forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
mutation :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
subscription :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
directiveDefinitions :: forall (s :: Stage). Schema s -> DirectivesDefinition s
..} =
  ResolverValue m -> m (ResolverValue m)
forall a. a -> m a
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", [TypeDefinition ANY VALID] -> m (ResolverValue m)
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
[TypeDefinition ANY VALID] -> IValue m
renderI ([TypeDefinition ANY VALID] -> m (ResolverValue m))
-> [TypeDefinition ANY VALID] -> m (ResolverValue m)
forall a b. (a -> b) -> a -> b
$ HashMap TypeName (TypeDefinition ANY VALID)
-> [TypeDefinition ANY VALID]
forall a. HashMap TypeName a -> [a]
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),
        (FieldName
"queryType", Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m)
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
Maybe (TypeDefinition OBJECT VALID) -> IValue m
renderI (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 a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
Maybe (TypeDefinition OBJECT VALID) -> IValue m
renderI Maybe (TypeDefinition OBJECT VALID)
mutation),
        (FieldName
"subscriptionType", Maybe (TypeDefinition OBJECT VALID) -> m (ResolverValue m)
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
Maybe (TypeDefinition OBJECT VALID) -> IValue m
renderI Maybe (TypeDefinition OBJECT VALID)
subscription),
        (FieldName
"directives", [DirectiveDefinition VALID] -> m (ResolverValue m)
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
[DirectiveDefinition VALID] -> IValue m
renderI ([DirectiveDefinition VALID] -> m (ResolverValue m))
-> [DirectiveDefinition VALID] -> m (ResolverValue m)
forall a b. (a -> b) -> a -> b
$ (DirectiveDefinition VALID -> FieldName)
-> [DirectiveDefinition VALID] -> [DirectiveDefinition VALID]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith DirectiveDefinition VALID -> FieldName
forall (s :: Stage). DirectiveDefinition s -> FieldName
directiveDefinitionName ([DirectiveDefinition VALID] -> [DirectiveDefinition VALID])
-> [DirectiveDefinition VALID] -> [DirectiveDefinition VALID]
forall a b. (a -> b) -> a -> b
$ DirectivesDefinition VALID -> [DirectiveDefinition VALID]
forall a. SafeHashMap FieldName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList DirectivesDefinition VALID
directiveDefinitions)
      ]

resolveType :: (MonadResolver m) => Value VALID -> m (ResolverValue m)
resolveType :: forall (m :: * -> *).
MonadResolver m =>
Value VALID -> m (ResolverValue m)
resolveType (Scalar (String Text
typename)) = (ResolverContext -> HashMap TypeName (TypeDefinition ANY VALID))
-> m (HashMap TypeName (TypeDefinition ANY VALID))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Schema VALID -> HashMap TypeName (TypeDefinition ANY VALID)
forall (s :: Stage).
Schema s -> HashMap TypeName (TypeDefinition ANY s)
typeDefinitions (Schema VALID -> HashMap TypeName (TypeDefinition ANY VALID))
-> (ResolverContext -> Schema VALID)
-> ResolverContext
-> HashMap TypeName (TypeDefinition ANY VALID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> Schema VALID
schema) m (HashMap TypeName (TypeDefinition ANY VALID))
-> (HashMap TypeName (TypeDefinition ANY VALID)
    -> m (ResolverValue m))
-> m (ResolverValue m)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (TypeDefinition ANY VALID) -> m (ResolverValue m)
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
Maybe (TypeDefinition ANY VALID) -> IValue m
renderI (Maybe (TypeDefinition ANY VALID) -> m (ResolverValue m))
-> (HashMap TypeName (TypeDefinition ANY VALID)
    -> Maybe (TypeDefinition ANY VALID))
-> HashMap TypeName (TypeDefinition ANY VALID)
-> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName
-> HashMap TypeName (TypeDefinition ANY VALID)
-> Maybe (TypeDefinition ANY VALID)
forall a. TypeName -> HashMap TypeName a -> Maybe a
forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
lookup (Text -> TypeName
forall a (t :: NAME). NamePacking a => a -> Name t
forall (t :: NAME). Text -> Name t
packName Text
typename)
resolveType Value VALID
_ = ResolverValue m -> m (ResolverValue m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResolverValue m
forall (m :: * -> *). ResolverValue m
mkNull

schemaAPI ::
  ( MonadOperation m ~ QUERY,
    MonadResolver m
  ) =>
  ObjectTypeResolver m
schemaAPI :: forall (m :: * -> *).
(MonadOperation m ~ QUERY, MonadResolver m) =>
ObjectTypeResolver m
schemaAPI =
  HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver
    ( [Item (HashMap FieldName (m (ResolverValue m)))]
-> HashMap FieldName (m (ResolverValue m))
forall l. IsList l => [Item l] -> l
fromList
        [ (FieldName
"__type", FieldName -> m (Value VALID)
forall (m :: * -> *).
MonadResolver m =>
FieldName -> m (Value VALID)
getArgument FieldName
"name" m (Value VALID)
-> (Value VALID -> m (ResolverValue m)) -> m (ResolverValue m)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value VALID -> m (ResolverValue m)
forall (m :: * -> *).
MonadResolver m =>
Value VALID -> m (ResolverValue m)
resolveType),
          (FieldName
"__schema", (ResolverContext -> Schema VALID) -> m (Schema VALID)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ResolverContext -> Schema VALID
schema m (Schema VALID)
-> (Schema VALID -> m (ResolverValue m)) -> m (ResolverValue m)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Schema VALID -> m (ResolverValue m)
forall (m :: * -> *).
MonadResolver m =>
Schema VALID -> m (ResolverValue m)
resolveSchema)
        ]
    )