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

module Data.Morpheus.App.RenderIntrospection
  ( renderI,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.App.Internal.Resolving.MonadResolver
  ( MonadResolver,
    ResolverContext (..),
  )
import Data.Morpheus.App.Internal.Resolving.Types
  ( ResolverValue,
    mkBoolean,
    mkList,
    mkNull,
    mkObject,
    mkString,
  )
import Data.Morpheus.Core (render)
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),
    Name,
    OUT,
    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

iError :: GQLError -> GQLError
iError :: GQLError -> GQLError
iError GQLError
x = GQLError -> GQLError
internal (GQLError
"INTROSPECTION" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
x)

getType :: MonadResolver m => TypeName -> m TypeDef
getType :: forall (m :: * -> *). MonadResolver m => TypeName -> m TypeDef
getType TypeName
name =
  (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 TypeDef) -> m TypeDef
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GQLError -> TypeName -> HashMap TypeName TypeDef -> m TypeDef
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy (GQLError -> GQLError
iError (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
"type \"" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
name GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"\" not found!") TypeName
name
      (HashMap TypeName TypeDef -> m TypeDef)
-> (Schema VALID -> HashMap TypeName TypeDef)
-> Schema VALID
-> m TypeDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema VALID -> HashMap TypeName TypeDef
forall (s :: Stage).
Schema s -> HashMap TypeName (TypeDefinition ANY s)
typeDefinitions

assertINTERFACE :: MonadResolver m => TypeDef -> m TypeDef
assertINTERFACE :: forall (m :: * -> *). MonadResolver m => TypeDef -> m TypeDef
assertINTERFACE t :: TypeDef
t@TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInterface {}} = TypeDef -> m TypeDef
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDef
t
assertINTERFACE TypeDef
t = GQLError -> m TypeDef
forall a. GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m TypeDef) -> GQLError -> m TypeDef
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
iError (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
"Type " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg (TypeDef -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDef
t) GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" must be an Interface!"

type TypeDef = TypeDefinition ANY VALID

type IValue m = m (ResolverValue m)

type IField m = (FieldName, IValue m)

class RenderI a where
  renderI :: MonadResolver m => a -> IValue m

instance RenderI (Name t) where
  renderI :: forall (m :: * -> *). MonadResolver m => Name t -> IValue m
renderI = ResolverValue m -> m (ResolverValue m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> m (ResolverValue m))
-> (Name t -> ResolverValue m) -> Name t -> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ResolverValue m
forall (m :: * -> *). Text -> ResolverValue m
mkString (Text -> ResolverValue m)
-> (Name t -> Text) -> Name t -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name t -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName

instance RenderI Description where
  renderI :: forall (m :: * -> *). MonadResolver m => Text -> IValue m
renderI = ResolverValue m -> m (ResolverValue m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> m (ResolverValue m))
-> (Text -> ResolverValue m) -> Text -> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ResolverValue m
forall (m :: * -> *). Text -> ResolverValue m
mkString

instance RenderI a => RenderI [a] where
  renderI :: forall (m :: * -> *). MonadResolver m => [a] -> IValue m
renderI [a]
ls = [ResolverValue m] -> ResolverValue m
forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList ([ResolverValue m] -> ResolverValue m)
-> m [ResolverValue m] -> m (ResolverValue m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m (ResolverValue m)) -> [a] -> m [ResolverValue m]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse a -> m (ResolverValue m)
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => a -> IValue m
renderI [a]
ls

instance RenderI a => RenderI (Maybe a) where
  renderI :: forall (m :: * -> *). MonadResolver m => Maybe a -> IValue m
renderI (Just a
value) = a -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => a -> IValue m
renderI a
value
  renderI Maybe a
Nothing = ResolverValue m -> IValue m
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResolverValue m
forall (m :: * -> *). ResolverValue m
mkNull

instance RenderI Bool where
  renderI :: forall (m :: * -> *). MonadResolver m => Bool -> IValue m
renderI = ResolverValue m -> m (ResolverValue m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> m (ResolverValue m))
-> (Bool -> ResolverValue m) -> Bool -> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ResolverValue m
forall (m :: * -> *). Bool -> ResolverValue m
mkBoolean

instance RenderI TypeKind where
  renderI :: forall (m :: * -> *). MonadResolver m => TypeKind -> IValue m
renderI = ResolverValue m -> m (ResolverValue m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> m (ResolverValue m))
-> (TypeKind -> ResolverValue m) -> TypeKind -> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ResolverValue m
forall (m :: * -> *). Text -> ResolverValue m
mkString (Text -> ResolverValue m)
-> (TypeKind -> Text) -> TypeKind -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
fromLBS (ByteString -> Text)
-> (TypeKind -> ByteString) -> TypeKind -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeKind -> ByteString
forall a. RenderGQL a => a -> ByteString
render

instance RenderI (DirectiveDefinition VALID) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
DirectiveDefinition VALID -> IValue m
renderI DirectiveDefinition {[DirectiveLocation]
Maybe Text
ArgumentsDefinition VALID
FieldName
directiveDefinitionName :: FieldName
directiveDefinitionDescription :: Maybe Text
directiveDefinitionArgs :: ArgumentsDefinition VALID
directiveDefinitionLocations :: [DirectiveLocation]
directiveDefinitionName :: forall (s :: Stage). DirectiveDefinition s -> FieldName
directiveDefinitionDescription :: forall (s :: Stage). DirectiveDefinition s -> Maybe Text
directiveDefinitionArgs :: forall (s :: Stage). DirectiveDefinition s -> ArgumentsDefinition s
directiveDefinitionLocations :: forall (s :: Stage). DirectiveDefinition s -> [DirectiveLocation]
..} =
    TypeName -> [IField m] -> IValue m
forall (m :: * -> *). Monad m => TypeName -> [IField m] -> IValue m
object
      TypeName
"__Directive"
      [ FieldName -> IField m
forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
Name t -> IField m
fName FieldName
directiveDefinitionName,
        Maybe Text -> IField m
forall (m :: * -> *). MonadResolver m => Maybe Text -> IField m
fDescription Maybe Text
directiveDefinitionDescription,
        (FieldName
"locations", [DirectiveLocation] -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
[DirectiveLocation] -> IValue m
renderI [DirectiveLocation]
directiveDefinitionLocations),
        (FieldName
"args", ArgumentsDefinition VALID -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
ArgumentsDefinition VALID -> IValue m
renderI ArgumentsDefinition VALID
directiveDefinitionArgs)
      ]

instance RenderI DirectiveLocation where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
DirectiveLocation -> IValue m
renderI DirectiveLocation
locations = 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
$ Text -> ResolverValue m
forall (m :: * -> *). Text -> ResolverValue m
mkString (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DirectiveLocation -> String
forall b a. (Show a, IsString b) => a -> b
show DirectiveLocation
locations)

instance RenderI (TypeDefinition c VALID) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
TypeDefinition c VALID -> IValue m
renderI TypeDefinition {Maybe Text
Directives VALID
TypeName
TypeContent TRUE c VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDescription :: Maybe Text
typeName :: TypeName
typeDirectives :: Directives VALID
typeContent :: TypeContent TRUE c VALID
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Text
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
..} = TypeContent TRUE c VALID -> IValue m
forall (m :: * -> *) (bool :: Bool) (a :: TypeCategory).
MonadResolver m =>
TypeContent bool a VALID -> IValue m
renderContent TypeContent TRUE c VALID
typeContent
    where
      __type :: MonadResolver m => TypeKind -> [IField m] -> IValue m
      __type :: forall (m :: * -> *).
MonadResolver m =>
TypeKind -> [IField m] -> IValue m
__type TypeKind
kind = TypeKind -> TypeName -> Maybe Text -> [IField m] -> IValue m
forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
TypeKind -> Name t -> Maybe Text -> [IField m] -> IValue m
__Type TypeKind
kind TypeName
typeName Maybe Text
typeDescription
      renderContent :: MonadResolver m => TypeContent bool a VALID -> IValue m
      renderContent :: forall (m :: * -> *) (bool :: Bool) (a :: TypeCategory).
MonadResolver m =>
TypeContent bool a VALID -> IValue m
renderContent DataScalar {} = TypeKind -> [IField m] -> IValue m
forall (m :: * -> *).
MonadResolver m =>
TypeKind -> [IField m] -> IValue m
__type TypeKind
KIND_SCALAR []
      renderContent (DataEnum DataEnum VALID
enums) = TypeKind -> [IField m] -> IValue m
forall (m :: * -> *).
MonadResolver m =>
TypeKind -> [IField m] -> IValue m
__type TypeKind
KIND_ENUM [(FieldName
"enumValues", DataEnum VALID -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => DataEnum VALID -> IValue m
renderI DataEnum VALID
enums)]
      renderContent (DataInputObject FieldsDefinition IN VALID
inputFields) =
        TypeKind -> [IField m] -> IValue m
forall (m :: * -> *).
MonadResolver m =>
TypeKind -> [IField m] -> IValue m
__type
          TypeKind
KIND_INPUT_OBJECT
          [(FieldName
"inputFields", FieldsDefinition IN VALID -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
FieldsDefinition IN VALID -> IValue m
renderI FieldsDefinition IN VALID
inputFields)]
      renderContent DataObject {[TypeName]
objectImplements :: [TypeName]
objectImplements :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> [TypeName]
objectImplements, FieldsDefinition OUT VALID
objectFields :: FieldsDefinition OUT VALID
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields} =
        TypeKind -> TypeName -> Maybe Text -> [IField m] -> IValue m
forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
TypeKind -> Name t -> Maybe Text -> [IField m] -> IValue m
__Type
          (Maybe OperationType -> TypeKind
KIND_OBJECT Maybe OperationType
forall a. Maybe a
Nothing)
          TypeName
typeName
          Maybe Text
typeDescription
          [ (FieldName
"fields", FieldsDefinition OUT VALID -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
FieldsDefinition OUT VALID -> IValue m
renderI FieldsDefinition OUT VALID
objectFields),
            (FieldName
"interfaces", (TypeName -> m TypeDef) -> [TypeName] -> m [TypeDef]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (TypeName -> m TypeDef
forall (m :: * -> *). MonadResolver m => TypeName -> m TypeDef
getType (TypeName -> m TypeDef)
-> (TypeDef -> m TypeDef) -> TypeName -> m TypeDef
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TypeDef -> m TypeDef
forall (m :: * -> *). MonadResolver m => TypeDef -> m TypeDef
assertINTERFACE) [TypeName]
objectImplements m [TypeDef] -> ([TypeDef] -> IValue m) -> IValue m
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TypeDef] -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => [TypeDef] -> IValue m
renderI)
          ]
      renderContent (DataUnion UnionTypeDefinition OUT VALID
union) =
        TypeKind -> [IField m] -> IValue m
forall (m :: * -> *).
MonadResolver m =>
TypeKind -> [IField m] -> IValue m
__type
          TypeKind
KIND_UNION
          [(FieldName
"possibleTypes", [UnionMember OUT VALID] -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
[UnionMember OUT VALID] -> IValue m
renderI ([UnionMember OUT VALID] -> IValue m)
-> [UnionMember OUT VALID] -> IValue m
forall a b. (a -> b) -> a -> b
$ UnionTypeDefinition OUT VALID -> [UnionMember OUT VALID]
forall a. OrdMap TypeName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UnionTypeDefinition OUT VALID
union)]
      renderContent (DataInputUnion UnionTypeDefinition IN VALID
members) =
        TypeKind -> TypeName -> Maybe Text -> [IField m] -> IValue m
forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
TypeKind -> Name t -> Maybe Text -> [IField m] -> IValue m
__Type
          TypeKind
KIND_INPUT_OBJECT
          TypeName
typeName
          ( Text -> Maybe Text
forall a. a -> Maybe a
Just
              ( Text
"Note! This input is an exclusive object,\n"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"i.e., the customer can provide a value for only one field."
              )
              Maybe Text -> Maybe Text -> Maybe Text
forall a. Semigroup a => a -> a -> a
<> Maybe Text
typeDescription
          )
          [ ( FieldName
"inputFields",
              FieldsDefinition IN VALID -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
FieldsDefinition IN VALID -> IValue m
renderI (UnionTypeDefinition IN VALID -> FieldsDefinition IN VALID
forall (t :: * -> *) (s :: Stage).
Foldable t =>
t (UnionMember IN s) -> FieldsDefinition IN s
mkInputUnionFields UnionTypeDefinition IN VALID
members)
            )
          ]
      renderContent (DataInterface FieldsDefinition OUT VALID
fields) =
        TypeKind -> [IField m] -> IValue m
forall (m :: * -> *).
MonadResolver m =>
TypeKind -> [IField m] -> IValue m
__type
          TypeKind
KIND_INTERFACE
          [ (FieldName
"fields", FieldsDefinition OUT VALID -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
FieldsDefinition OUT VALID -> IValue m
renderI FieldsDefinition OUT VALID
fields),
            (FieldName
"possibleTypes", (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 -> IValue m) -> IValue m
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TypeDef] -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => [TypeDef] -> IValue m
renderI ([TypeDef] -> IValue m)
-> (Schema VALID -> [TypeDef]) -> Schema VALID -> IValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Schema VALID -> [TypeDef]
forall (s :: Stage). TypeName -> Schema s -> [TypeDefinition ANY s]
possibleInterfaceTypes TypeName
typeName)
          ]

instance RenderI (UnionMember OUT s) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
UnionMember OUT s -> IValue m
renderI UnionMember {TypeName
memberName :: TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName} = TypeName -> m TypeDef
forall (m :: * -> *). MonadResolver m => TypeName -> m TypeDef
getType TypeName
memberName m TypeDef
-> (TypeDef -> 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
>>= TypeDef -> m (ResolverValue m)
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => TypeDef -> IValue m
renderI

instance RenderI (FieldDefinition cat s) => RenderI (FieldsDefinition cat s) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
FieldsDefinition cat s -> IValue m
renderI = [FieldDefinition cat s] -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
[FieldDefinition cat s] -> IValue m
renderI ([FieldDefinition cat s] -> IValue m)
-> (FieldsDefinition cat s -> [FieldDefinition cat s])
-> FieldsDefinition cat s
-> IValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDefinition cat s -> Bool)
-> [FieldDefinition cat s] -> [FieldDefinition cat s]
forall a. (a -> Bool) -> [a] -> [a]
filter FieldDefinition cat s -> Bool
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Bool
fieldVisibility ([FieldDefinition cat s] -> [FieldDefinition cat s])
-> (FieldsDefinition cat s -> [FieldDefinition cat s])
-> FieldsDefinition cat s
-> [FieldDefinition cat s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldsDefinition cat s -> [FieldDefinition cat s]
forall a. OrdMap FieldName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance RenderI (FieldContent TRUE IN VALID) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
FieldContent TRUE IN VALID -> IValue m
renderI = Value VALID -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => Value VALID -> IValue m
renderI (Value VALID -> IValue m)
-> (FieldContent TRUE IN VALID -> Value VALID)
-> FieldContent TRUE IN VALID
-> IValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldContent TRUE IN VALID -> Value VALID
FieldContent (IN <=? IN) IN VALID -> Value VALID
forall (s :: Stage) (cat :: TypeCategory).
FieldContent (IN <=? cat) cat s -> Value s
defaultInputValue

instance RenderI (Value VALID) where
  renderI :: forall (m :: * -> *). MonadResolver m => Value VALID -> IValue m
renderI Value VALID
Null = 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
  renderI Value VALID
x = 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
$ Text -> ResolverValue m
forall (m :: * -> *). Text -> ResolverValue m
mkString (Text -> ResolverValue m) -> Text -> ResolverValue m
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
fromLBS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value VALID -> ByteString
forall a. RenderGQL a => a -> ByteString
render Value VALID
x

instance RenderI (FieldDefinition OUT VALID) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
FieldDefinition OUT VALID -> IValue m
renderI FieldDefinition {Maybe Text
Maybe (FieldContent TRUE OUT VALID)
Directives VALID
FieldName
TypeRef
fieldDescription :: Maybe Text
fieldName :: FieldName
fieldType :: TypeRef
fieldContent :: Maybe (FieldContent TRUE OUT VALID)
fieldDirectives :: 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
..} =
    TypeName -> [IField m] -> IValue m
forall (m :: * -> *). Monad m => TypeName -> [IField m] -> IValue m
object TypeName
"__Field" ([IField m] -> IValue m) -> [IField m] -> IValue m
forall a b. (a -> b) -> a -> b
$
      [ FieldName -> IField m
forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
Name t -> IField m
fName FieldName
fieldName,
        Maybe Text -> IField m
forall (m :: * -> *). MonadResolver m => Maybe Text -> IField m
fDescription Maybe Text
fieldDescription,
        TypeRef -> IField m
forall (m :: * -> *). MonadResolver m => TypeRef -> IField m
fType TypeRef
fieldType,
        (FieldName
"args", IValue m
-> (FieldContent TRUE OUT VALID -> IValue m)
-> Maybe (FieldContent TRUE OUT VALID)
-> IValue m
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ResolverValue m -> IValue m
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> IValue m) -> ResolverValue m -> IValue m
forall a b. (a -> b) -> a -> b
$ [ResolverValue m] -> ResolverValue m
forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList []) FieldContent TRUE OUT VALID -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
FieldContent TRUE OUT VALID -> IValue m
renderI Maybe (FieldContent TRUE OUT VALID)
fieldContent)
      ]
        [IField m] -> [IField m] -> [IField m]
forall a. Semigroup a => a -> a -> a
<> Directives VALID -> [IField m]
forall (m :: * -> *) (s :: Stage).
MonadResolver m =>
Directives s -> [IField m]
fDeprecated Directives VALID
fieldDirectives

instance RenderI (FieldContent TRUE OUT VALID) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
FieldContent TRUE OUT VALID -> IValue m
renderI (FieldArgs ArgumentsDefinition VALID
args) = ArgumentsDefinition VALID -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
ArgumentsDefinition VALID -> IValue m
renderI ArgumentsDefinition VALID
args

instance RenderI (ArgumentsDefinition VALID) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
ArgumentsDefinition VALID -> IValue m
renderI = ([ResolverValue m] -> ResolverValue m)
-> m [ResolverValue m] -> m (ResolverValue m)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ResolverValue m] -> ResolverValue m
forall (m :: * -> *). [ResolverValue m] -> ResolverValue m
mkList (m [ResolverValue m] -> m (ResolverValue m))
-> (ArgumentsDefinition VALID -> m [ResolverValue m])
-> ArgumentsDefinition VALID
-> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ArgumentDefinition VALID -> m (ResolverValue m))
-> [ArgumentDefinition VALID] -> m [ResolverValue m]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (FieldDefinition IN VALID -> m (ResolverValue m)
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
FieldDefinition IN VALID -> IValue m
renderI (FieldDefinition IN VALID -> m (ResolverValue m))
-> (ArgumentDefinition VALID -> FieldDefinition IN VALID)
-> ArgumentDefinition VALID
-> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgumentDefinition VALID -> FieldDefinition IN VALID
forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument) ([ArgumentDefinition VALID] -> m [ResolverValue m])
-> (ArgumentsDefinition VALID -> [ArgumentDefinition VALID])
-> ArgumentsDefinition VALID
-> m [ResolverValue m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgumentsDefinition VALID -> [ArgumentDefinition VALID]
forall a. OrdMap FieldName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance RenderI (FieldDefinition IN VALID) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
FieldDefinition IN VALID -> IValue m
renderI FieldDefinition {Maybe Text
Maybe (FieldContent TRUE IN VALID)
Directives VALID
FieldName
TypeRef
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
fieldDescription :: Maybe Text
fieldName :: FieldName
fieldType :: TypeRef
fieldContent :: Maybe (FieldContent TRUE IN VALID)
fieldDirectives :: Directives VALID
..} =
    TypeName -> [IField m] -> IValue m
forall (m :: * -> *). Monad m => TypeName -> [IField m] -> IValue m
object
      TypeName
"__InputValue"
      [ FieldName -> IField m
forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
Name t -> IField m
fName FieldName
fieldName,
        Maybe Text -> IField m
forall (m :: * -> *). MonadResolver m => Maybe Text -> IField m
fDescription Maybe Text
fieldDescription,
        TypeRef -> IField m
forall (m :: * -> *). MonadResolver m => TypeRef -> IField m
fType TypeRef
fieldType,
        Maybe (FieldContent TRUE IN VALID) -> IField m
forall (m :: * -> *).
MonadResolver m =>
Maybe (FieldContent TRUE IN VALID) -> IField m
fDefaultValue Maybe (FieldContent TRUE IN VALID)
fieldContent
      ]

instance RenderI (DataEnumValue VALID) where
  renderI :: forall (m :: * -> *).
MonadResolver m =>
DataEnumValue VALID -> IValue m
renderI DataEnumValue {Maybe Text
Directives VALID
TypeName
enumDescription :: Maybe Text
enumName :: TypeName
enumDirectives :: Directives VALID
enumDescription :: forall (s :: Stage). DataEnumValue s -> Maybe Text
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumDirectives :: forall (s :: Stage). DataEnumValue s -> Directives s
..} =
    TypeName -> [IField m] -> IValue m
forall (m :: * -> *). Monad m => TypeName -> [IField m] -> IValue m
object TypeName
"__EnumValue" ([IField m] -> IValue m) -> [IField m] -> IValue m
forall a b. (a -> b) -> a -> b
$
      [ TypeName -> IField m
forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
Name t -> IField m
fName TypeName
enumName,
        Maybe Text -> IField m
forall (m :: * -> *). MonadResolver m => Maybe Text -> IField m
fDescription Maybe Text
enumDescription
      ]
        [IField m] -> [IField m] -> [IField m]
forall a. Semigroup a => a -> a -> a
<> Directives VALID -> [IField m]
forall (m :: * -> *) (s :: Stage).
MonadResolver m =>
Directives s -> [IField m]
fDeprecated Directives VALID
enumDirectives

instance RenderI TypeRef where
  renderI :: forall (m :: * -> *). MonadResolver m => TypeRef -> IValue m
renderI TypeRef {TypeName
TypeWrapper
typeConName :: TypeName
typeWrappers :: TypeWrapper
typeConName :: TypeRef -> TypeName
typeWrappers :: TypeRef -> TypeWrapper
..} = TypeWrapper -> IValue m
renderWrapper TypeWrapper
typeWrappers
    where
      renderWrapper :: TypeWrapper -> IValue m
renderWrapper (TypeList TypeWrapper
nextWrapper Bool
isNonNull) =
        Bool -> IValue m -> IValue m
forall (m :: * -> *).
MonadResolver m =>
Bool -> IValue m -> IValue m
withNonNull Bool
isNonNull (IValue m -> IValue m) -> IValue m -> IValue m
forall a b. (a -> b) -> a -> b
$ TypeKind -> IValue m -> IValue m
forall (m :: * -> *).
MonadResolver m =>
TypeKind -> IValue m -> IValue m
wrapper TypeKind
KIND_LIST (TypeWrapper -> IValue m
renderWrapper TypeWrapper
nextWrapper)
      renderWrapper (BaseType Bool
isNonNull) =
        Bool -> IValue m -> IValue m
forall (m :: * -> *).
MonadResolver m =>
Bool -> IValue m -> IValue m
withNonNull Bool
isNonNull (IValue m -> IValue m) -> IValue m -> IValue m
forall a b. (a -> b) -> a -> b
$ do
          TypeKind
kind <- TypeDef -> TypeKind
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeKind
kindOf (TypeDef -> TypeKind) -> m TypeDef -> m TypeKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeName -> m TypeDef
forall (m :: * -> *). MonadResolver m => TypeName -> m TypeDef
getType TypeName
typeConName
          TypeKind -> TypeName -> Maybe Text -> [IField m] -> IValue m
forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
TypeKind -> Name t -> Maybe Text -> [IField m] -> IValue m
__Type TypeKind
kind TypeName
typeConName Maybe Text
forall a. Maybe a
Nothing []

withNonNull :: MonadResolver m => Bool -> IValue m -> IValue m
withNonNull :: forall (m :: * -> *).
MonadResolver m =>
Bool -> IValue m -> IValue m
withNonNull Bool
True = TypeKind -> IValue m -> IValue m
forall (m :: * -> *).
MonadResolver m =>
TypeKind -> IValue m -> IValue m
wrapper TypeKind
KIND_NON_NULL
withNonNull Bool
False = IValue m -> IValue m
forall a. a -> a
id

__Type ::
  MonadResolver m =>
  TypeKind ->
  Name t ->
  Maybe Description ->
  [IField m] ->
  IValue m
__Type :: forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
TypeKind -> Name t -> Maybe Text -> [IField m] -> IValue m
__Type TypeKind
kind Name t
name Maybe Text
desc [IField m]
etc =
  TypeName -> [IField m] -> IValue m
forall (m :: * -> *). Monad m => TypeName -> [IField m] -> IValue m
object
    TypeName
"__Type"
    ( [ TypeKind -> IField m
forall (m :: * -> *). MonadResolver m => TypeKind -> IField m
fKind TypeKind
kind,
        Name t -> IField m
forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
Name t -> IField m
fName Name t
name,
        Maybe Text -> IField m
forall (m :: * -> *). MonadResolver m => Maybe Text -> IField m
fDescription Maybe Text
desc
      ]
        [IField m] -> [IField m] -> [IField m]
forall a. Semigroup a => a -> a -> a
<> [IField m]
etc
    )

wrapper :: MonadResolver m => TypeKind -> IValue m -> IValue m
wrapper :: forall (m :: * -> *).
MonadResolver m =>
TypeKind -> IValue m -> IValue m
wrapper TypeKind
k IValue m
t =
  TypeName -> [IField m] -> IValue m
forall (m :: * -> *). Monad m => TypeName -> [IField m] -> IValue m
object
    TypeName
"__Type"
    [ TypeKind -> IField m
forall (m :: * -> *). MonadResolver m => TypeKind -> IField m
fKind TypeKind
k,
      (FieldName
"ofType", IValue m
t)
    ]

object :: Monad m => TypeName -> [IField m] -> IValue m
object :: forall (m :: * -> *). Monad m => TypeName -> [IField m] -> IValue m
object TypeName
name = ResolverValue m -> m (ResolverValue m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> m (ResolverValue m))
-> ([IField m] -> ResolverValue m)
-> [IField m]
-> m (ResolverValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> [IField m] -> ResolverValue m
forall (m :: * -> *).
TypeName -> [ResolverEntry m] -> ResolverValue m
mkObject TypeName
name

fDeprecated :: MonadResolver m => Directives s -> [IField m]
fDeprecated :: forall (m :: * -> *) (s :: Stage).
MonadResolver m =>
Directives s -> [IField m]
fDeprecated Directives s
dirs =
  [ (FieldName
"isDeprecated", Bool -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => Bool -> IValue m
renderI (Maybe (Directive s) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Directive s) -> Bool) -> Maybe (Directive s) -> Bool
forall a b. (a -> b) -> a -> b
$ Directives s -> Maybe (Directive s)
forall (s :: Stage). Directives s -> Maybe (Directive s)
lookupDeprecated Directives s
dirs)),
    (FieldName
"deprecationReason", Maybe Text -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => Maybe Text -> IValue m
renderI (Directives s -> Maybe (Directive s)
forall (s :: Stage). Directives s -> Maybe (Directive s)
lookupDeprecated Directives s
dirs Maybe (Directive s) -> (Directive s -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Directive s -> Maybe Text
forall (s :: Stage). Directive s -> Maybe Text
lookupDeprecatedReason))
  ]

fDescription :: MonadResolver m => Maybe Description -> IField m
fDescription :: forall (m :: * -> *). MonadResolver m => Maybe Text -> IField m
fDescription = (FieldName
"description",) (IValue m -> IField m)
-> (Maybe Text -> IValue m) -> Maybe Text -> IField m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => Maybe Text -> IValue m
renderI

fName :: MonadResolver m => Name t -> IField m
fName :: forall (m :: * -> *) (t :: NAME).
MonadResolver m =>
Name t -> IField m
fName = (FieldName
"name",) (IValue m -> IField m)
-> (Name t -> IValue m) -> Name t -> IField m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name t -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => Name t -> IValue m
renderI

fKind :: MonadResolver m => TypeKind -> IField m
fKind :: forall (m :: * -> *). MonadResolver m => TypeKind -> IField m
fKind = (FieldName
"kind",) (IValue m -> IField m)
-> (TypeKind -> IValue m) -> TypeKind -> IField m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeKind -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => TypeKind -> IValue m
renderI

fType :: MonadResolver m => TypeRef -> IField m
fType :: forall (m :: * -> *). MonadResolver m => TypeRef -> IField m
fType = (FieldName
"type",) (IValue m -> IField m)
-> (TypeRef -> IValue m) -> TypeRef -> IField m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRef -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *). MonadResolver m => TypeRef -> IValue m
renderI

fDefaultValue :: MonadResolver m => Maybe (FieldContent TRUE IN VALID) -> IField m
fDefaultValue :: forall (m :: * -> *).
MonadResolver m =>
Maybe (FieldContent TRUE IN VALID) -> IField m
fDefaultValue = (FieldName
"defaultValue",) (IValue m -> IField m)
-> (Maybe (FieldContent TRUE IN VALID) -> IValue m)
-> Maybe (FieldContent TRUE IN VALID)
-> IField m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (FieldContent TRUE IN VALID) -> IValue m
forall a (m :: * -> *).
(RenderI a, MonadResolver m) =>
a -> IValue m
forall (m :: * -> *).
MonadResolver m =>
Maybe (FieldContent TRUE IN VALID) -> IValue m
renderI