{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.RenderIntrospection
  ( render,
    createObjectType,
    WithSchema,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.App.Internal.Resolving.Resolver
  ( Resolver,
    ResolverContext (..),
  )
import Data.Morpheus.App.Internal.Resolving.Types
  ( ResolverValue,
    mkBoolean,
    mkList,
    mkNull,
    mkObject,
    mkString,
  )
import qualified Data.Morpheus.Core as GQL
import Data.Morpheus.Internal.Utils
  ( fromLBS,
    selectBy,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    ArgumentDefinition (..),
    ArgumentsDefinition,
    DataEnumValue (..),
    Description,
    DirectiveDefinition (..),
    DirectiveLocation,
    Directives,
    FieldContent (..),
    FieldDefinition (..),
    FieldName,
    FieldsDefinition,
    GQLError,
    IN,
    Msg (msg),
    OUT,
    QUERY,
    Schema,
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeKind (..),
    TypeName,
    TypeRef (..),
    TypeWrapper (BaseType, TypeList),
    UnionMember (..),
    VALID,
    Value (..),
    fieldVisibility,
    internal,
    kindOf,
    lookupDeprecated,
    lookupDeprecatedReason,
    mkInputUnionFields,
    msg,
    possibleInterfaceTypes,
    typeDefinitions,
    unpackName,
  )
import Data.Text (pack)
import Relude

class
  ( Monad m,
    MonadError GQLError m
  ) =>
  WithSchema m
  where
  getSchema :: m (Schema VALID)

instance Monad m => WithSchema (Resolver QUERY e m) where
  getSchema :: Resolver QUERY e m (Schema VALID)
getSchema = ResolverContext -> Schema VALID
schema forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask

selectType ::
  WithSchema m =>
  TypeName ->
  m (TypeDefinition ANY VALID)
selectType :: forall (m :: * -> *).
WithSchema m =>
TypeName -> m (TypeDefinition ANY VALID)
selectType TypeName
name =
  forall (m :: * -> *). WithSchema m => m (Schema VALID)
getSchema
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy (GQLError -> GQLError
internal forall a b. (a -> b) -> a -> b
$ GQLError
"INTROSPECTION Type not Found: \"" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
name forall a. Semigroup a => a -> a -> a
<> GQLError
"\"") TypeName
name
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage).
Schema s -> HashMap TypeName (TypeDefinition ANY s)
typeDefinitions

class RenderIntrospection a where
  render :: (Monad m, WithSchema m) => a -> m (ResolverValue m)

instance RenderIntrospection TypeName where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeName -> m (ResolverValue m)
render = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Text -> ResolverValue m
mkString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName

instance RenderIntrospection FieldName where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
FieldName -> m (ResolverValue m)
render = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Text -> ResolverValue m
mkString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName

instance RenderIntrospection Description where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
Text -> m (ResolverValue m)
render = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Text -> ResolverValue m
mkString

instance RenderIntrospection a => RenderIntrospection [a] where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
[a] -> m (ResolverValue m)
render [a]
ls = 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 [a]
ls

instance RenderIntrospection a => RenderIntrospection (Maybe a) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
Maybe a -> m (ResolverValue m)
render (Just a
value) = forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render a
value
  render Maybe a
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). ResolverValue m
mkNull

instance RenderIntrospection Bool where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
Bool -> m (ResolverValue m)
render = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Bool -> ResolverValue m
mkBoolean

instance RenderIntrospection TypeKind where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> m (ResolverValue m)
render = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Text -> ResolverValue m
mkString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
fromLBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RenderGQL a => a -> ByteString
GQL.render

instance RenderIntrospection (DirectiveDefinition VALID) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
DirectiveDefinition VALID -> m (ResolverValue m)
render
    DirectiveDefinition
      { FieldName
directiveDefinitionName :: forall (s :: Stage). DirectiveDefinition s -> FieldName
directiveDefinitionName :: FieldName
directiveDefinitionName,
        Maybe Text
directiveDefinitionDescription :: forall (s :: Stage). DirectiveDefinition s -> Maybe Text
directiveDefinitionDescription :: Maybe Text
directiveDefinitionDescription,
        [DirectiveLocation]
directiveDefinitionLocations :: forall (s :: Stage). DirectiveDefinition s -> [DirectiveLocation]
directiveDefinitionLocations :: [DirectiveLocation]
directiveDefinitionLocations,
        ArgumentsDefinition VALID
directiveDefinitionArgs :: forall (s :: Stage). DirectiveDefinition s -> ArgumentsDefinition s
directiveDefinitionArgs :: ArgumentsDefinition VALID
directiveDefinitionArgs
      } =
      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
"__Directive"
          [ forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
name -> (FieldName, m (ResolverValue m))
renderName FieldName
directiveDefinitionName,
            forall (m :: * -> *).
(Monad m, WithSchema m) =>
Maybe Text -> (FieldName, m (ResolverValue m))
description Maybe Text
directiveDefinitionDescription,
            (FieldName
"locations", forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render [DirectiveLocation]
directiveDefinitionLocations),
            (FieldName
"args", forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render ArgumentsDefinition VALID
directiveDefinitionArgs)
          ]

instance RenderIntrospection DirectiveLocation where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
DirectiveLocation -> m (ResolverValue m)
render DirectiveLocation
locations = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Text -> ResolverValue m
mkString (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall b a. (Show a, IsString b) => a -> b
show DirectiveLocation
locations)

instance RenderIntrospection (TypeDefinition cat VALID) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeDefinition cat VALID -> m (ResolverValue m)
render
    TypeDefinition
      { TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName,
        Maybe Text
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Text
typeDescription :: Maybe Text
typeDescription,
        TypeContent TRUE cat VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE cat VALID
typeContent
      } = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (bool :: Bool) (a :: TypeCategory).
(Monad m, WithSchema m) =>
TypeContent bool a VALID -> ResolverValue m
renderContent TypeContent TRUE cat VALID
typeContent
      where
        __type ::
          ( Monad m,
            WithSchema m
          ) =>
          TypeKind ->
          [(FieldName, m (ResolverValue m))] ->
          ResolverValue m
        __type :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> [(FieldName, m (ResolverValue m))] -> ResolverValue m
__type TypeKind
kind = forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
TypeKind
-> name
-> Maybe Text
-> [(FieldName, m (ResolverValue m))]
-> ResolverValue m
mkType TypeKind
kind TypeName
typeName Maybe Text
typeDescription
        renderContent ::
          ( Monad m,
            WithSchema m
          ) =>
          TypeContent bool a VALID ->
          ResolverValue m
        renderContent :: forall (m :: * -> *) (bool :: Bool) (a :: TypeCategory).
(Monad m, WithSchema m) =>
TypeContent bool a VALID -> ResolverValue m
renderContent DataScalar {} = forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> [(FieldName, m (ResolverValue m))] -> ResolverValue m
__type TypeKind
KindScalar []
        renderContent (DataEnum DataEnum VALID
enums) = forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> [(FieldName, m (ResolverValue m))] -> ResolverValue m
__type TypeKind
KindEnum [(FieldName
"enumValues", forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render DataEnum VALID
enums)]
        renderContent (DataInputObject FieldsDefinition IN VALID
inputFields) =
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> [(FieldName, m (ResolverValue m))] -> ResolverValue m
__type
            TypeKind
KindInputObject
            [(FieldName
"inputFields", forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render FieldsDefinition IN VALID
inputFields)]
        renderContent DataObject {[TypeName]
objectImplements :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> [TypeName]
objectImplements :: [TypeName]
objectImplements, FieldsDefinition OUT VALID
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT VALID
objectFields} =
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeName
-> Maybe Text
-> [TypeName]
-> FieldsDefinition OUT VALID
-> ResolverValue m
createObjectType TypeName
typeName Maybe Text
typeDescription [TypeName]
objectImplements FieldsDefinition OUT VALID
objectFields
        renderContent (DataUnion UnionTypeDefinition OUT VALID
union) =
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> [(FieldName, m (ResolverValue m))] -> ResolverValue m
__type
            TypeKind
KindUnion
            [(FieldName
"possibleTypes", forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UnionTypeDefinition OUT VALID
union)]
        renderContent (DataInputUnion UnionTypeDefinition IN VALID
members) =
          forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
TypeKind
-> name
-> Maybe Text
-> [(FieldName, m (ResolverValue m))]
-> ResolverValue m
mkType
            TypeKind
KindInputObject
            TypeName
typeName
            ( forall a. a -> Maybe a
Just
                ( Text
"Note! This input is an exclusive object,\n"
                    forall a. Semigroup a => a -> a -> a
<> Text
"i.e., the customer can provide a value for only one field."
                )
                forall a. Semigroup a => a -> a -> a
<> Maybe Text
typeDescription
            )
            [ ( FieldName
"inputFields",
                forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render (forall (t :: * -> *) (s :: Stage).
Foldable t =>
t (UnionMember IN s) -> FieldsDefinition IN s
mkInputUnionFields UnionTypeDefinition IN VALID
members)
              )
            ]
        renderContent (DataInterface FieldsDefinition OUT VALID
fields) =
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> [(FieldName, m (ResolverValue m))] -> ResolverValue m
__type
            TypeKind
KindInterface
            [ (FieldName
"fields", forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render FieldsDefinition OUT VALID
fields),
              (FieldName
"possibleTypes", forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeName -> m (ResolverValue m)
renderPossibleTypes TypeName
typeName)
            ]

instance RenderIntrospection (UnionMember OUT s) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
UnionMember OUT s -> m (ResolverValue m)
render UnionMember {TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName :: TypeName
memberName} = forall (m :: * -> *).
WithSchema m =>
TypeName -> m (TypeDefinition ANY VALID)
selectType TypeName
memberName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render

instance
  RenderIntrospection (FieldDefinition cat s) =>
  RenderIntrospection (FieldsDefinition cat s)
  where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
FieldsDefinition cat s -> m (ResolverValue m)
render = forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Bool
fieldVisibility forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance RenderIntrospection (FieldContent TRUE IN VALID) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
FieldContent TRUE IN VALID -> m (ResolverValue m)
render = forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage) (cat :: TypeCategory).
FieldContent (IN <=? cat) cat s -> Value s
defaultInputValue

instance RenderIntrospection (Value VALID) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
Value VALID -> m (ResolverValue m)
render Value VALID
Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *). ResolverValue m
mkNull
  render Value VALID
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Text -> ResolverValue m
mkString forall a b. (a -> b) -> a -> b
$ ByteString -> Text
fromLBS forall a b. (a -> b) -> a -> b
$ forall a. RenderGQL a => a -> ByteString
GQL.render Value VALID
x

instance
  RenderIntrospection
    (FieldDefinition OUT VALID)
  where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
FieldDefinition OUT VALID -> m (ResolverValue m)
render FieldDefinition {Maybe Text
Maybe (FieldContent TRUE OUT VALID)
TypeRef
FieldName
Directives VALID
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Text
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Directives s
fieldDirectives :: Directives VALID
fieldContent :: Maybe (FieldContent TRUE OUT VALID)
fieldType :: TypeRef
fieldName :: FieldName
fieldDescription :: Maybe Text
..} =
    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
"__Field" forall a b. (a -> b) -> a -> b
$
        [ forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
name -> (FieldName, m (ResolverValue m))
renderName FieldName
fieldName,
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
Maybe Text -> (FieldName, m (ResolverValue m))
description Maybe Text
fieldDescription,
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeRef -> (FieldName, m (ResolverValue m))
type' TypeRef
fieldType,
          (FieldName
"args", forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList []) forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render Maybe (FieldContent TRUE OUT VALID)
fieldContent)
        ]
          forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *) (s :: Stage).
(Monad m, WithSchema m) =>
Directives s -> [(FieldName, m (ResolverValue m))]
renderDeprecated Directives VALID
fieldDirectives

instance RenderIntrospection (FieldContent TRUE OUT VALID) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
FieldContent TRUE OUT VALID -> m (ResolverValue m)
render (FieldArgs ArgumentsDefinition VALID
args) = forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render ArgumentsDefinition VALID
args

instance RenderIntrospection (ArgumentsDefinition VALID) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
ArgumentsDefinition VALID -> m (ResolverValue m)
render = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance RenderIntrospection (FieldDefinition IN VALID) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
FieldDefinition IN VALID -> m (ResolverValue m)
render FieldDefinition {Maybe Text
Maybe (FieldContent TRUE IN VALID)
TypeRef
FieldName
Directives VALID
fieldDirectives :: Directives VALID
fieldContent :: Maybe (FieldContent TRUE IN VALID)
fieldType :: TypeRef
fieldName :: FieldName
fieldDescription :: Maybe Text
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Text
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Directives s
..} =
    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
"__InputValue"
        [ forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
name -> (FieldName, m (ResolverValue m))
renderName FieldName
fieldName,
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
Maybe Text -> (FieldName, m (ResolverValue m))
description Maybe Text
fieldDescription,
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeRef -> (FieldName, m (ResolverValue m))
type' TypeRef
fieldType,
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
Maybe (FieldContent TRUE IN VALID)
-> (FieldName, m (ResolverValue m))
defaultValue Maybe (FieldContent TRUE IN VALID)
fieldContent
        ]

instance RenderIntrospection (DataEnumValue VALID) where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
DataEnumValue VALID -> m (ResolverValue m)
render DataEnumValue {TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName :: TypeName
enumName, Maybe Text
enumDescription :: forall (s :: Stage). DataEnumValue s -> Maybe Text
enumDescription :: Maybe Text
enumDescription, Directives VALID
enumDirectives :: forall (s :: Stage). DataEnumValue s -> Directives s
enumDirectives :: Directives VALID
enumDirectives} =
    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
"__Field" forall a b. (a -> b) -> a -> b
$
        [ forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
name -> (FieldName, m (ResolverValue m))
renderName TypeName
enumName,
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
Maybe Text -> (FieldName, m (ResolverValue m))
description Maybe Text
enumDescription
        ]
          forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *) (s :: Stage).
(Monad m, WithSchema m) =>
Directives s -> [(FieldName, m (ResolverValue m))]
renderDeprecated Directives VALID
enumDirectives

instance RenderIntrospection TypeRef where
  render :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeRef -> m (ResolverValue m)
render TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName, TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers} = forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeWrapper -> m (ResolverValue m)
renderWrapper TypeWrapper
typeWrappers
    where
      renderWrapper :: (Monad m, WithSchema m) => TypeWrapper -> m (ResolverValue m)
      renderWrapper :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeWrapper -> m (ResolverValue m)
renderWrapper (TypeList TypeWrapper
nextWrapper Bool
isNonNull) =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *).
(Monad m, WithSchema m) =>
Bool -> ResolverValue m -> ResolverValue m
withNonNull Bool
isNonNull forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *).
TypeName -> [ResolverEntry m] -> ResolverValue m
mkObject
              TypeName
"__Type"
              [ forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> (FieldName, m (ResolverValue m))
renderKind TypeKind
KindList,
                (FieldName
"ofType", forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeWrapper -> m (ResolverValue m)
renderWrapper TypeWrapper
nextWrapper)
              ]
      renderWrapper (BaseType Bool
isNonNull) =
        forall (m :: * -> *).
(Monad m, WithSchema m) =>
Bool -> ResolverValue m -> ResolverValue m
withNonNull Bool
isNonNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          TypeKind
kind <- forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeKind
kindOf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
WithSchema m =>
TypeName -> m (TypeDefinition ANY VALID)
selectType TypeName
typeConName
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
TypeKind
-> name
-> Maybe Text
-> [(FieldName, m (ResolverValue m))]
-> ResolverValue m
mkType TypeKind
kind TypeName
typeConName forall a. Maybe a
Nothing []

withNonNull ::
  ( Monad m,
    WithSchema m
  ) =>
  Bool ->
  ResolverValue m ->
  ResolverValue m
withNonNull :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
Bool -> ResolverValue m -> ResolverValue m
withNonNull Bool
True ResolverValue m
contentType =
  forall (m :: * -> *).
TypeName -> [ResolverEntry m] -> ResolverValue m
mkObject
    TypeName
"__Type"
    [ forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> (FieldName, m (ResolverValue m))
renderKind TypeKind
KindNonNull,
      (FieldName
"ofType", forall (f :: * -> *) a. Applicative f => a -> f a
pure ResolverValue m
contentType)
    ]
withNonNull Bool
False ResolverValue m
contentType = ResolverValue m
contentType

renderPossibleTypes ::
  (Monad m, WithSchema m) =>
  TypeName ->
  m (ResolverValue m)
renderPossibleTypes :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeName -> m (ResolverValue m)
renderPossibleTypes TypeName
name =
  forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (m :: * -> *). WithSchema m => m (Schema VALID)
getSchema
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m 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 b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). TypeName -> Schema s -> [TypeDefinition ANY s]
possibleInterfaceTypes TypeName
name
        )

renderDeprecated ::
  ( Monad m,
    WithSchema m
  ) =>
  Directives s ->
  [(FieldName, m (ResolverValue m))]
renderDeprecated :: forall (m :: * -> *) (s :: Stage).
(Monad m, WithSchema m) =>
Directives s -> [(FieldName, m (ResolverValue m))]
renderDeprecated Directives s
dirs =
  [ (FieldName
"isDeprecated", forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall (s :: Stage). Directives s -> Maybe (Directive s)
lookupDeprecated Directives s
dirs)),
    (FieldName
"deprecationReason", forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render (forall (s :: Stage). Directives s -> Maybe (Directive s)
lookupDeprecated Directives s
dirs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (s :: Stage). Directive s -> Maybe Text
lookupDeprecatedReason))
  ]

description ::
  ( Monad m,
    WithSchema m
  ) =>
  Maybe Description ->
  (FieldName, m (ResolverValue m))
description :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
Maybe Text -> (FieldName, m (ResolverValue m))
description = (FieldName
"description",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render

mkType ::
  ( RenderIntrospection name,
    Monad m,
    WithSchema m
  ) =>
  TypeKind ->
  name ->
  Maybe Description ->
  [(FieldName, m (ResolverValue m))] ->
  ResolverValue m
mkType :: forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
TypeKind
-> name
-> Maybe Text
-> [(FieldName, m (ResolverValue m))]
-> ResolverValue m
mkType TypeKind
kind name
name Maybe Text
desc [ResolverEntry m]
etc =
  forall (m :: * -> *).
TypeName -> [ResolverEntry m] -> ResolverValue m
mkObject
    TypeName
"__Type"
    ( [ forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> (FieldName, m (ResolverValue m))
renderKind TypeKind
kind,
        forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
name -> (FieldName, m (ResolverValue m))
renderName name
name,
        forall (m :: * -> *).
(Monad m, WithSchema m) =>
Maybe Text -> (FieldName, m (ResolverValue m))
description Maybe Text
desc
      ]
        forall a. Semigroup a => a -> a -> a
<> [ResolverEntry m]
etc
    )

createObjectType ::
  (Monad m, WithSchema m) =>
  TypeName ->
  Maybe Description ->
  [TypeName] ->
  FieldsDefinition OUT VALID ->
  ResolverValue m
createObjectType :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeName
-> Maybe Text
-> [TypeName]
-> FieldsDefinition OUT VALID
-> ResolverValue m
createObjectType TypeName
name Maybe Text
desc [TypeName]
interfaces FieldsDefinition OUT VALID
fields =
  forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
TypeKind
-> name
-> Maybe Text
-> [(FieldName, m (ResolverValue m))]
-> ResolverValue m
mkType (Maybe OperationType -> TypeKind
KindObject forall a. Maybe a
Nothing) TypeName
name Maybe Text
desc [(FieldName
"fields", forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render FieldsDefinition OUT VALID
fields), (FieldName
"interfaces", 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 (m :: * -> *).
(Monad m, WithSchema m) =>
TypeName -> m (ResolverValue m)
implementedInterface [TypeName]
interfaces)]

implementedInterface ::
  (Monad m, WithSchema m) =>
  TypeName ->
  m (ResolverValue m)
implementedInterface :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeName -> m (ResolverValue m)
implementedInterface TypeName
name =
  forall (m :: * -> *).
WithSchema m =>
TypeName -> m (TypeDefinition ANY VALID)
selectType TypeName
name
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TypeDefinition ANY VALID -> m (ResolverValue m)
renderContent
  where
    renderContent :: TypeDefinition ANY VALID -> m (ResolverValue m)
renderContent typeDef :: TypeDefinition ANY VALID
typeDef@TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInterface {}} = forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render TypeDefinition ANY VALID
typeDef
    renderContent TypeDefinition ANY VALID
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
internal forall a b. (a -> b) -> a -> b
$ GQLError
"Type " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
name forall a. Semigroup a => a -> a -> a
<> GQLError
" must be an Interface"

renderName ::
  ( RenderIntrospection name,
    Monad m,
    WithSchema m
  ) =>
  name ->
  (FieldName, m (ResolverValue m))
renderName :: forall name (m :: * -> *).
(RenderIntrospection name, Monad m, WithSchema m) =>
name -> (FieldName, m (ResolverValue m))
renderName = (FieldName
"name",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render

renderKind ::
  (Monad m, WithSchema m) =>
  TypeKind ->
  (FieldName, m (ResolverValue m))
renderKind :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeKind -> (FieldName, m (ResolverValue m))
renderKind = (FieldName
"kind",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render

type' ::
  (Monad m, WithSchema m) =>
  TypeRef ->
  (FieldName, m (ResolverValue m))
type' :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
TypeRef -> (FieldName, m (ResolverValue m))
type' = (FieldName
"type",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render

defaultValue ::
  (Monad m, WithSchema m) =>
  Maybe (FieldContent TRUE IN VALID) ->
  ( FieldName,
    m (ResolverValue m)
  )
defaultValue :: forall (m :: * -> *).
(Monad m, WithSchema m) =>
Maybe (FieldContent TRUE IN VALID)
-> (FieldName, m (ResolverValue m))
defaultValue = (FieldName
"defaultValue",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *).
(RenderIntrospection a, Monad m, WithSchema m) =>
a -> m (ResolverValue m)
render