graphql-engine/server/src-lib/Hasura/GraphQL/Schema/Introspect.hs

{-# LANGUAGE ApplicativeDo #-}

module Hasura.GraphQL.Schema.Introspect
  ( buildIntrospectionSchema,
    schema,
    typeIntrospection,
  )
where

-- import qualified Hasura.RQL.Types

import Data.Aeson.Ordered qualified as J
import Data.HashMap.Strict qualified as Map
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Data.Text.Extended
import Data.Vector qualified as V
import Hasura.Base.Error
import Hasura.GraphQL.Parser (FieldParser, Kind (..), Parser, Schema (..))
import Hasura.GraphQL.Parser qualified as P
import Hasura.GraphQL.Parser.Class
import Hasura.GraphQL.Parser.Directives
import Hasura.GraphQL.Parser.Internal.Parser (FieldParser (..))
import Hasura.Prelude
import Language.GraphQL.Draft.Printer qualified as GP
import Language.GraphQL.Draft.Syntax qualified as G
import Text.Builder qualified as T

{-
Note [Basics of introspection schema generation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We generate the introspection schema from the existing schema for queries,
mutations and subscriptions.  In other words, we generate one @Parser@ from some
other @Parser@s.  In this way, we avoid having to remember what types we have to
expose through introspection explicitly, as we did in a previous version of
graphql-engine.

However the schema information is obtained, the @Schema@ type stores it.  From a
@Schema@ object we then produce one @FieldParser@ that reads a `__schema` field,
and one that reads a `__type` field.  The idea is that these parsers simply
output a JSON value directly, and so indeed the type of @schema@, for instance,
is @FieldParser n J.Value@.

The idea of "just output the JSON object directly" breaks down when we want to
output a list of things, however, such as in the `types` field of `__schema`.
In the case of `types`, the JSON object to be generated is influenced by the
underlying selection set, so that, for instance,

```
query {
  __schema {
    types {
      name
    }
  }
}
```

means that we only output the _name_ of every type in our schema.  One naive
approach one might consider here would be to have a parser

```
typeField :: P.Type k -> Parser n J.Value
```

that takes a type, and is able to produce a JSON value for it, and then to apply
this parser to all the types in our schema.

However, we only have *one* selection set to parse: so which of the parsers we
obtained should we use to parse it?  And what should we do in the theoretical
case that we have a schema without any types?  (The latter is actually not
possible since we always have `query_root`, but it illustrates the problem that
there is no canonical choice of type to use to parse the selection set.)
Additionally, this would allow us to get the JSON output for *one* type, rather
than for our list of types.  After all, @Parser n@ is *not* a @Monad@ (it's not
even an @Applicative@), so we don't have a map @(a -> Parser n b) -> [a] -> m
[b]@.

In order to resolve this conundrum, let's consider what the ordinary Postgres
schema generates for a query such as follows.

```
query {
  author {
    articles {
      title
    }
  }
}
```

Now the @Parser@ for an article's title does not directly give the desired
output data: indeed, there would be many different titles, rather than any
single one we can return.  Instead, it returns a value that can, after parsing,
be used to build an output, along the lines of:

```
articleTitle :: FieldParser n SQLArticleTitle
```

(This is a heavily simplified representation of reality.)

These values can be thought of as an intermediate representation that can then
be used to generate and run SQL that gives the desired JSON output at a later
stage.  In other words, in the above example, @SQLArticleTitle@ can be thought
of as a function @Article -> Title@ that, given an article, gives back its
title.

Such an approach could help us as well, as, from instructions on how to generate
a JSON return for a given `__Type`, surely we can later simply apply this
construction to all types desired.

However, we don't _need_ to build an intermediate AST to do this: we can simply
output the conversion functions directly.  So the type of @typeField@ is closer
to:

```
typeField :: Parser n (P.Type k -> J.Value)
```

This says that we are always able to parse a selection set for a `__Type`, and
once we do, we obtain a map, which we refer to as `printer` in this module,
which can output a JSON object for a given GraphQL type from our schema.

To use `typeField` as part of another selection set, we build up a corresponding
`FieldParser`, thus obtaining a printer, then apply this printer to all desired
types, and output the final JSON object as a J.Array of the printed results,
like so (again, heavily simplified):

```
    types :: FieldParser n J.Value
    types = do
      printer <- P.subselection_ $$(G.litName "types") Nothing typeField
      return $ J.Array $ map printer $ allSchemaTypes
```

Upon reading this you may be bewildered how we are able to use do notation for
@FieldParser@, which does not have a @Monad@ instance, or even an @Applicative@
instance.  It just so happens that, as long as we write our do blocks carefully,
so that we only use the functoriality of @FieldParser@, the simplification rules
of GHC kick in just in time to avoid any application of @(>>=)@ or @return@.
Arguably the above notation is prettier than equivalent code that explicitly
reduces this to applications of @fmap@.  If you, dear reader, feel like the do
notation adds more confusion than value, you should feel free to change this, as
there is no deeper meaning to the application of do notation than ease of
reading.
-}

{- Note [What introspection exposes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
NB: By "introspection query", we mean a query making use of the __type or
__schema top-level fields.

It would be very convenient if we could simply build up our desired GraphQL
schema, without regard for introspection. Ideally, we would then extract the
data required for introspection from this complete GraphQL schema. There are,
however, some complications:

1. Of course, we _do_ need to include the introspection fields themselves into
   the query_root, so that we can deal with introspection queries
   appropriately. So we can't avoid thinking about introspection entirely while
   constructing the GraphQL schema.

2. The GraphQL specification says that although we must always expose __type and
   __schema fields as part of the query_root, they must not be visible fields of
   the query_root object type. See
   http://spec.graphql.org/June2018/#sec-Schema-Introspection

At this point, one might naively attempt to generate two GraphQL schemas:

- One without the __type and __schema fields, from which we generate the data
  required for responding to introspection queries.
- One with the __type and __schema fields, which is used to actually respond to
  queries.

However, this is also not GraphQL-compliant!

The problem here is that while __type and __schema are not visible fields of the
query root object, their *types*, __Type and __Schema respectively, *must be*
exposed through __type introspection, even though those types never appear as
(transitive) members of the query/mutation/subscription root fields.

So in order to gather the data required for introspection, we follow the
following recipe:

A. Collect type information from the introspection-free GraphQL schema

B. Collect type information from the introspection-only GraphQL schema

C. Stitch together the results of (A) and (B). In particular, the query_root
from (A) is used, and all types from (A) and (B) are used, except for the
query_root obtained in (B). -}

-- | Builds a @Schema@ from GraphQL types for the query_root, mutation_root and
-- subscription_root.
--
-- See Note [What introspection exposes]
buildIntrospectionSchema ::
  MonadError QErr m =>
  P.Type 'Output ->
  Maybe (P.Type 'Output) ->
  Maybe (P.Type 'Output) ->
  m P.Schema
buildIntrospectionSchema queryRoot' mutationRoot' subscriptionRoot' = do
  let -- The only directives that we currently expose over introspection are our
      -- statically defined ones.  So, for instance, we don't correctly expose
      -- directives from remote schemas.
      directives = directivesInfo @(P.ParseT Identity)
      -- The __schema and __type introspection fields
      introspection = [schema @(P.ParseT Identity), typeIntrospection]
      {-# INLINE introspection #-}

  -- Collect type information of all non-introspection fields
  allBasicTypes <-
    collectTypes
      [ P.TypeDefinitionsWrapper queryRoot',
        P.TypeDefinitionsWrapper mutationRoot',
        P.TypeDefinitionsWrapper subscriptionRoot',
        P.TypeDefinitionsWrapper $ P.diArguments =<< directives
      ]

  -- TODO: it may be worth looking at whether we can stop collecting
  -- introspection types monadically.  They are independent of the user schema;
  -- the types here are always the same and specified by the GraphQL spec

  -- Pull all the introspection types out (__Type, __Schema, etc)
  allIntrospectionTypes <- collectTypes (map fDefinition introspection)

  let allTypes =
        Map.unions
          [ allBasicTypes,
            Map.filterWithKey (\name _info -> name /= P.getName queryRoot') allIntrospectionTypes
          ]
  pure $
    P.Schema
      { sDescription = Nothing,
        sTypes = allTypes,
        sQueryType = queryRoot',
        sMutationType = mutationRoot',
        sSubscriptionType = subscriptionRoot',
        sDirectives = directives
      }

collectTypes ::
  forall m a.
  (MonadError QErr m, P.HasTypeDefinitions a) =>
  a ->
  m (HashMap G.Name (P.Definition P.SomeTypeInfo))
collectTypes x =
  P.collectTypeDefinitions x
    `onLeft` \(P.ConflictingDefinitions (type1, origin1) (_type2, origins)) ->
      -- See Note [Collecting types from the GraphQL schema]
      throw500 $
        "Found conflicting definitions for " <> P.getName type1 <<> ".  The definition at " <> origin1
          <<> " differs from the the definition at " <> commaSeparated origins
          <<> "."

-- | Generate a __type introspection parser
typeIntrospection ::
  forall n.
  MonadParse n =>
  FieldParser n (Schema -> J.Value)
{-# INLINE typeIntrospection #-}
typeIntrospection = do
  let nameArg :: P.InputFieldsParser n Text
      nameArg = P.field $$(G.litName "name") Nothing P.string
  ~(nameText, printer) <- P.subselection $$(G.litName "__type") Nothing nameArg typeField
  -- We pass around the GraphQL schema information under the name `partialSchema`,
  -- because the GraphQL spec forces us to expose a hybrid between the
  -- specification of valid queries (including introspection) and an
  -- introspection-free GraphQL schema.  See Note [What introspection exposes].
  pure $ \partialSchema -> fromMaybe J.Null $ do
    name <- G.mkName nameText
    P.Definition n d (P.SomeTypeInfo i) <- Map.lookup name $ sTypes partialSchema
    Just $ printer $ SomeType $ P.TNamed P.Nullable $ P.Definition n d i

-- | Generate a __schema introspection parser.
schema ::
  forall n.
  MonadParse n =>
  FieldParser n (Schema -> J.Value)
{-# INLINE schema #-}
schema = P.subselection_ $$(G.litName "__schema") Nothing schemaSet

{-
type __Type {
  kind: __TypeKind!
  name: String
  description: String

  # should be non-null for OBJECT and INTERFACE only, must be null for the others
  fields(includeDeprecated: Boolean = false): [__Field!]

  # should be non-null for OBJECT and INTERFACE only, must be null for the others
  interfaces: [__Type!]

  # should be non-null for INTERFACE and UNION only, always null for the others
  possibleTypes: [__Type!]

  # should be non-null for ENUM only, must be null for the others
  enumValues(includeDeprecated: Boolean = false): [__EnumValue!]

  # should be non-null for INPUT_OBJECT only, must be null for the others
  inputFields: [__InputValue!]

  # should be non-null for NON_NULL and LIST only, must be null for the others
  ofType: __Type
}
-}

data SomeType = forall k. SomeType (P.Type k)

typeField ::
  forall n.
  MonadParse n =>
  Parser 'Output n (SomeType -> J.Value)
typeField =
  let includeDeprecated :: P.InputFieldsParser n Bool
      includeDeprecated =
        P.fieldWithDefault $$(G.litName "includeDeprecated") Nothing (G.VBoolean False) (P.nullable P.boolean)
          <&> fromMaybe False
      kind :: FieldParser n (SomeType -> J.Value)
      kind =
        P.selection_ $$(G.litName "kind") Nothing typeKind
          $> \case
            SomeType tp ->
              case tp of
                P.TList P.NonNullable _ ->
                  J.String "NON_NULL"
                P.TNamed P.NonNullable _ ->
                  J.String "NON_NULL"
                P.TList P.Nullable _ ->
                  J.String "LIST"
                P.TNamed P.Nullable (P.Definition _ _ P.TIScalar) ->
                  J.String "SCALAR"
                P.TNamed P.Nullable (P.Definition _ _ (P.TIEnum _)) ->
                  J.String "ENUM"
                P.TNamed P.Nullable (P.Definition _ _ (P.TIInputObject _)) ->
                  J.String "INPUT_OBJECT"
                P.TNamed P.Nullable (P.Definition _ _ (P.TIObject _)) ->
                  J.String "OBJECT"
                P.TNamed P.Nullable (P.Definition _ _ (P.TIInterface _)) ->
                  J.String "INTERFACE"
                P.TNamed P.Nullable (P.Definition _ _ (P.TIUnion _)) ->
                  J.String "UNION"
      name :: FieldParser n (SomeType -> J.Value)
      name =
        P.selection_ $$(G.litName "name") Nothing P.string
          $> \case
            SomeType tp ->
              case tp of
                P.TNamed P.Nullable (P.Definition name' _ _) ->
                  nameAsJSON name'
                _ -> J.Null
      description :: FieldParser n (SomeType -> J.Value)
      description =
        P.selection_ $$(G.litName "description") Nothing P.string
          $> \case
            SomeType (P.TNamed _ (P.Definition _ (Just desc) _)) ->
              J.String (G.unDescription desc)
            _ -> J.Null
      fields :: FieldParser n (SomeType -> J.Value)
      fields = do
        -- TODO handle the value of includeDeprecated
        ~(_includeDeprecated, printer) <- P.subselection $$(G.litName "fields") Nothing includeDeprecated fieldField
        return $
          \case
            SomeType tp ->
              case tp of
                P.TNamed P.Nullable (P.Definition _ _ (P.TIObject (P.ObjectInfo fields' _interfaces'))) ->
                  J.Array $ V.fromList $ printer <$> sortOn P.dName fields'
                P.TNamed P.Nullable (P.Definition _ _ (P.TIInterface (P.InterfaceInfo fields' _objects'))) ->
                  J.Array $ V.fromList $ printer <$> sortOn P.dName fields'
                _ -> J.Null
      interfaces :: FieldParser n (SomeType -> J.Value)
      interfaces = do
        printer <- P.subselection_ $$(G.litName "interfaces") Nothing typeField
        return $
          \case
            SomeType tp ->
              case tp of
                P.TNamed P.Nullable (P.Definition _ _ (P.TIObject (P.ObjectInfo _fields' interfaces'))) ->
                  J.Array $ V.fromList $ printer . SomeType . P.TNamed P.Nullable . fmap P.TIInterface <$> sortOn P.dName interfaces'
                _ -> J.Null
      possibleTypes :: FieldParser n (SomeType -> J.Value)
      possibleTypes = do
        printer <- P.subselection_ $$(G.litName "possibleTypes") Nothing typeField
        return $
          \case
            SomeType tp ->
              case tp of
                P.TNamed P.Nullable (P.Definition _ _ (P.TIInterface (P.InterfaceInfo _fields' objects'))) ->
                  J.Array $ V.fromList $ printer . SomeType . P.TNamed P.Nullable . fmap P.TIObject <$> sortOn P.dName objects'
                P.TNamed P.Nullable (P.Definition _ _ (P.TIUnion (P.UnionInfo objects'))) ->
                  J.Array $ V.fromList $ printer . SomeType . P.TNamed P.Nullable . fmap P.TIObject <$> sortOn P.dName objects'
                _ -> J.Null
      enumValues :: FieldParser n (SomeType -> J.Value)
      enumValues = do
        -- TODO handle the value of includeDeprecated
        ~(_includeDeprecated, printer) <- P.subselection $$(G.litName "enumValues") Nothing includeDeprecated enumValue
        return $
          \case
            SomeType tp ->
              case tp of
                P.TNamed P.Nullable (P.Definition _ _ (P.TIEnum vals)) ->
                  J.Array $ V.fromList $ fmap printer $ sortOn P.dName $ toList vals
                _ -> J.Null
      inputFields :: FieldParser n (SomeType -> J.Value)
      inputFields = do
        printer <- P.subselection_ $$(G.litName "inputFields") Nothing inputValue
        return $
          \case
            SomeType tp ->
              case tp of
                P.TNamed P.Nullable (P.Definition _ _ (P.TIInputObject (P.InputObjectInfo fieldDefs))) ->
                  J.Array $ V.fromList $ map printer $ sortOn P.dName fieldDefs
                _ -> J.Null
      -- ofType peels modalities off of types
      ofType :: FieldParser n (SomeType -> J.Value)
      ofType = do
        printer <- P.subselection_ $$(G.litName "ofType") Nothing typeField
        return $ \case
          -- kind = "NON_NULL": !a -> a
          SomeType (P.TNamed P.NonNullable x) ->
            printer $ SomeType $ P.TNamed P.Nullable x
          -- kind = "NON_NULL": ![a] -> [a], and ![!a] -> [!a]
          SomeType (P.TList P.NonNullable x) ->
            printer $ SomeType $ P.TList P.Nullable x
          -- kind = "LIST": [a] -> a
          SomeType (P.TList P.Nullable x) ->
            printer $ SomeType x
          _ -> J.Null
   in applyPrinter
        <$> P.selectionSet
          $$(G.litName "__Type")
          Nothing
          [ kind,
            name,
            description,
            fields,
            interfaces,
            possibleTypes,
            enumValues,
            inputFields,
            ofType
          ]

{-
type __InputValue {
  name: String!
  description: String
  type: __Type!
  defaultValue: String
}
-}
inputValue ::
  forall n.
  MonadParse n =>
  Parser 'Output n (P.Definition P.InputFieldInfo -> J.Value)
inputValue =
  let name :: FieldParser n (P.Definition P.InputFieldInfo -> J.Value)
      name =
        P.selection_ $$(G.litName "name") Nothing P.string
          $> nameAsJSON . P.dName
      description :: FieldParser n (P.Definition P.InputFieldInfo -> J.Value)
      description =
        P.selection_ $$(G.litName "description") Nothing P.string
          $> maybe J.Null (J.String . G.unDescription) . P.dDescription
      typeF :: FieldParser n (P.Definition P.InputFieldInfo -> J.Value)
      typeF = do
        printer <- P.subselection_ $$(G.litName "type") Nothing typeField
        return $ \defInfo -> case P.dInfo defInfo of
          P.InputFieldInfo tp _ -> printer $ SomeType tp
      defaultValue :: FieldParser n (P.Definition P.InputFieldInfo -> J.Value)
      defaultValue =
        P.selection_ $$(G.litName "defaultValue") Nothing P.string
          $> \defInfo -> case P.dInfo defInfo of
            P.InputFieldInfo _ (Just val) -> J.String $ T.run $ GP.value val
            _ -> J.Null
   in applyPrinter
        <$> P.selectionSet
          $$(G.litName "__InputValue")
          Nothing
          [ name,
            description,
            typeF,
            defaultValue
          ]

{-
type __EnumValue {
  name: String!
  description: String
  isDeprecated: Boolean!
  deprecationReason: String
}
-}
enumValue ::
  forall n.
  MonadParse n =>
  Parser 'Output n (P.Definition P.EnumValueInfo -> J.Value)
enumValue =
  let name :: FieldParser n (P.Definition P.EnumValueInfo -> J.Value)
      name =
        P.selection_ $$(G.litName "name") Nothing P.string
          $> nameAsJSON . P.dName
      description :: FieldParser n (P.Definition P.EnumValueInfo -> J.Value)
      description =
        P.selection_ $$(G.litName "description") Nothing P.string
          $> maybe J.Null (J.String . G.unDescription) . P.dDescription
      -- TODO We don't seem to support enum value deprecation
      isDeprecated :: FieldParser n (P.Definition P.EnumValueInfo -> J.Value)
      isDeprecated =
        P.selection_ $$(G.litName "isDeprecated") Nothing P.string
          $> const (J.Bool False)
      deprecationReason :: FieldParser n (P.Definition P.EnumValueInfo -> J.Value)
      deprecationReason =
        P.selection_ $$(G.litName "deprecationReason") Nothing P.string
          $> const J.Null
   in applyPrinter
        <$> P.selectionSet
          $$(G.litName "__EnumValue")
          Nothing
          [ name,
            description,
            isDeprecated,
            deprecationReason
          ]

{-
enum __TypeKind {
  ENUM
  INPUT_OBJECT
  INTERFACE
  LIST
  NON_NULL
  OBJECT
  SCALAR
  UNION
}
-}
typeKind ::
  forall n.
  MonadParse n =>
  Parser 'Both n ()
typeKind =
  P.enum
    $$(G.litName "__TypeKind")
    Nothing
    ( NE.fromList
        [ mkDefinition $$(G.litName "ENUM"),
          mkDefinition $$(G.litName "INPUT_OBJECT"),
          mkDefinition $$(G.litName "INTERFACE"),
          mkDefinition $$(G.litName "LIST"),
          mkDefinition $$(G.litName "NON_NULL"),
          mkDefinition $$(G.litName "OBJECT"),
          mkDefinition $$(G.litName "SCALAR"),
          mkDefinition $$(G.litName "UNION")
        ]
    )
  where
    mkDefinition name = (P.Definition name Nothing P.EnumValueInfo, ())

{-
type __Field {
  name: String!
  description: String
  args: [__InputValue!]!
  type: __Type!
  isDeprecated: Boolean!
  deprecationReason: String
}
-}
fieldField ::
  forall n.
  MonadParse n =>
  Parser 'Output n (P.Definition P.FieldInfo -> J.Value)
fieldField =
  let name :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
      name =
        P.selection_ $$(G.litName "name") Nothing P.string
          $> nameAsJSON . P.dName
      description :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
      description =
        P.selection_ $$(G.litName "description") Nothing P.string $> \defInfo ->
          case P.dDescription defInfo of
            Nothing -> J.Null
            Just desc -> J.String (G.unDescription desc)
      args :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
      args = do
        printer <- P.subselection_ $$(G.litName "args") Nothing inputValue
        return $ J.Array . V.fromList . map printer . sortOn P.dName . P.fArguments . P.dInfo
      typeF :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
      typeF = do
        printer <- P.subselection_ $$(G.litName "type") Nothing typeField
        return $ printer . (\case P.FieldInfo _ tp -> SomeType tp) . P.dInfo
      -- TODO We don't seem to track deprecation info
      isDeprecated :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
      isDeprecated =
        P.selection_ $$(G.litName "isDeprecated") Nothing P.string
          $> const (J.Bool False)
      deprecationReason :: FieldParser n (P.Definition P.FieldInfo -> J.Value)
      deprecationReason =
        P.selection_ $$(G.litName "deprecationReason") Nothing P.string
          $> const J.Null
   in applyPrinter
        <$> P.selectionSet
          $$(G.litName "__Field")
          Nothing
          [ name,
            description,
            args,
            typeF,
            isDeprecated,
            deprecationReason
          ]

{-
type __Directive {
  name: String!
  description: String
  locations: [__DirectiveLocation!]!
  args: [__InputValue!]!
  isRepeatable: Boolean!
}
-}

directiveSet ::
  forall n.
  MonadParse n =>
  Parser 'Output n (P.DirectiveInfo -> J.Value)
directiveSet =
  let name :: FieldParser n (P.DirectiveInfo -> J.Value)
      name =
        P.selection_ $$(G.litName "name") Nothing P.string
          $> (J.toOrdered . P.diName)
      description :: FieldParser n (P.DirectiveInfo -> J.Value)
      description =
        P.selection_ $$(G.litName "description") Nothing P.string
          $> (J.toOrdered . P.diDescription)
      locations :: FieldParser n (P.DirectiveInfo -> J.Value)
      locations =
        P.selection_ $$(G.litName "locations") Nothing P.string
          $> (J.toOrdered . map showDirLoc . P.diLocations)
      args :: FieldParser n (P.DirectiveInfo -> J.Value)
      args = do
        printer <- P.subselection_ $$(G.litName "args") Nothing inputValue
        pure $ J.array . map printer . P.diArguments
      isRepeatable :: FieldParser n (P.DirectiveInfo -> J.Value)
      isRepeatable =
        P.selection_ $$(G.litName "isRepeatable") Nothing P.string
          $> const J.Null
   in applyPrinter
        <$> P.selectionSet
          $$(G.litName "__Directive")
          Nothing
          [ name,
            description,
            locations,
            args,
            isRepeatable
          ]
  where
    showDirLoc :: G.DirectiveLocation -> Text
    showDirLoc = \case
      G.DLExecutable edl -> T.pack $ drop 3 $ show edl
      G.DLTypeSystem tsdl -> T.pack $ drop 4 $ show tsdl

{-
type __Schema {
  description: String
  types: [__Type!]!
  queryType: __Type!
  mutationType: __Type
  subscriptionType: __Type
  directives: [__Directive!]!
}
-}
schemaSet ::
  forall n.
  MonadParse n =>
  Parser 'Output n (Schema -> J.Value)
{-# INLINE schemaSet #-}
schemaSet =
  let description :: FieldParser n (Schema -> J.Value)
      description =
        P.selection_ $$(G.litName "description") Nothing P.string
          $> \partialSchema -> case sDescription partialSchema of
            Nothing -> J.Null
            Just s -> J.String $ G.unDescription s
      types :: FieldParser n (Schema -> J.Value)
      types = do
        printer <- P.subselection_ $$(G.litName "types") Nothing typeField
        return $
          \partialSchema ->
            J.Array $
              V.fromList $
                map (printer . schemaTypeToSomeType) $
                  sortOn P.dName $ Map.elems $ sTypes partialSchema
        where
          schemaTypeToSomeType ::
            P.Definition P.SomeTypeInfo ->
            SomeType
          schemaTypeToSomeType (P.Definition n d (P.SomeTypeInfo i)) =
            SomeType $ P.TNamed P.Nullable (P.Definition n d i)
      queryType :: FieldParser n (Schema -> J.Value)
      queryType = do
        printer <- P.subselection_ $$(G.litName "queryType") Nothing typeField
        return $ \partialSchema -> printer $ SomeType $ sQueryType partialSchema
      mutationType :: FieldParser n (Schema -> J.Value)
      mutationType = do
        printer <- P.subselection_ $$(G.litName "mutationType") Nothing typeField
        return $ \partialSchema -> case sMutationType partialSchema of
          Nothing -> J.Null
          Just tp -> printer $ SomeType tp
      subscriptionType :: FieldParser n (Schema -> J.Value)
      subscriptionType = do
        printer <- P.subselection_ $$(G.litName "subscriptionType") Nothing typeField
        return $ \partialSchema -> case sSubscriptionType partialSchema of
          Nothing -> J.Null
          Just tp -> printer $ SomeType tp
      directives :: FieldParser n (Schema -> J.Value)
      directives = do
        printer <- P.subselection_ $$(G.litName "directives") Nothing directiveSet
        return $ \partialSchema -> J.array $ map printer $ sDirectives partialSchema
   in applyPrinter
        <$> P.selectionSet
          $$(G.litName "__Schema")
          Nothing
          [ description,
            types,
            queryType,
            mutationType,
            subscriptionType,
            directives
          ]

selectionSetToJSON ::
  OMap.InsOrdHashMap G.Name J.Value ->
  J.Value
selectionSetToJSON = J.object . map (first G.unName) . OMap.toList

applyPrinter ::
  OMap.InsOrdHashMap G.Name (P.ParsedSelection (a -> J.Value)) ->
  a ->
  J.Value
applyPrinter = flip (\x -> selectionSetToJSON . fmap (($ x) . P.handleTypename (const . nameAsJSON)))

nameAsJSON :: P.HasName a => a -> J.Value
nameAsJSON = J.String . G.unName . P.getName