RenderIntrospection.hs

{-# 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 (..))
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 x = internal ("INTROSPECTION" <> x)

getType :: (MonadResolver m) => TypeName -> m TypeDef
getType name =
  asks schema
    >>= selectBy (iError $ "type \"" <> msg name <> "\" not found!") name
    . typeDefinitions

assertINTERFACE :: (MonadResolver m) => TypeDef -> m TypeDef
assertINTERFACE t@TypeDefinition {typeContent = DataInterface {}} = pure t
assertINTERFACE t = throwError $ iError $ "Type " <> msg (typeName t) <> " 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 = pure . mkString . unpackName

instance RenderI Description where
  renderI = pure . mkString

instance (RenderI a) => RenderI [a] where
  renderI ls = mkList <$> traverse renderI ls

instance (RenderI a) => RenderI (Maybe a) where
  renderI (Just value) = renderI value
  renderI Nothing = pure mkNull

instance RenderI Bool where
  renderI = pure . mkBoolean

instance RenderI TypeKind where
  renderI = pure . mkString . fromLBS . render

instance RenderI (DirectiveDefinition VALID) where
  renderI DirectiveDefinition {..} =
    object
      "__Directive"
      [ fName directiveDefinitionName,
        fDescription directiveDefinitionDescription,
        ("locations", renderI directiveDefinitionLocations),
        ("args", renderI directiveDefinitionArgs)
      ]

instance RenderI DirectiveLocation where
  renderI locations = pure $ mkString (pack $ show locations)

instance RenderI (TypeDefinition c VALID) where
  renderI TypeDefinition {..} = renderContent typeContent
    where
      __type :: (MonadResolver m) => TypeKind -> [IField m] -> IValue m
      __type kind = __Type kind typeName typeDescription
      renderContent :: (MonadResolver m) => TypeContent bool a VALID -> IValue m
      renderContent DataScalar {} = __type KIND_SCALAR []
      renderContent (DataEnum enums) = __type KIND_ENUM [("enumValues", renderI enums)]
      renderContent (DataInputObject inputFields) =
        __type
          KIND_INPUT_OBJECT
          [("inputFields", renderI inputFields)]
      renderContent DataObject {objectImplements, objectFields} =
        __Type
          (KIND_OBJECT Nothing)
          typeName
          typeDescription
          [ ("fields", renderI objectFields),
            ("interfaces", traverse (getType >=> assertINTERFACE) objectImplements >>= renderI)
          ]
      renderContent (DataUnion union) =
        __type
          KIND_UNION
          [("possibleTypes", renderI $ toList union)]
      renderContent (DataInputUnion members) =
        __Type
          KIND_INPUT_OBJECT
          typeName
          ( Just
              ( "Note! This input is an exclusive object,\n"
                  <> "i.e., the customer can provide a value for only one field."
              )
              <> typeDescription
          )
          [ ( "inputFields",
              renderI (mkInputUnionFields members)
            )
          ]
      renderContent (DataInterface fields) =
        __type
          KIND_INTERFACE
          [ ("fields", renderI fields),
            ("possibleTypes", asks schema >>= renderI . possibleInterfaceTypes typeName)
          ]

instance RenderI (UnionMember OUT s) where
  renderI UnionMember {memberName} = getType memberName >>= renderI

instance (RenderI (FieldDefinition cat s)) => RenderI (FieldsDefinition cat s) where
  renderI = renderI . filter fieldVisibility . toList

instance RenderI (FieldContent TRUE IN VALID) where
  renderI = renderI . defaultInputValue

instance RenderI (Value VALID) where
  renderI Null = pure mkNull
  renderI x = pure $ mkString $ fromLBS $ render x

instance RenderI (FieldDefinition OUT VALID) where
  renderI FieldDefinition {..} =
    object "__Field"
      $ [ fName fieldName,
          fDescription fieldDescription,
          fType fieldType,
          ("args", maybe (pure $ mkList []) renderI fieldContent)
        ]
      <> fDeprecated fieldDirectives

instance RenderI (FieldContent TRUE OUT VALID) where
  renderI (FieldArgs args) = renderI args

instance RenderI (ArgumentsDefinition VALID) where
  renderI = fmap mkList . traverse (renderI . argument) . toList

instance RenderI (FieldDefinition IN VALID) where
  renderI FieldDefinition {..} =
    object
      "__InputValue"
      [ fName fieldName,
        fDescription fieldDescription,
        fType fieldType,
        fDefaultValue fieldContent
      ]

instance RenderI (DataEnumValue VALID) where
  renderI DataEnumValue {..} =
    object "__EnumValue"
      $ [ fName enumName,
          fDescription enumDescription
        ]
      <> fDeprecated enumDirectives

instance RenderI TypeRef where
  renderI TypeRef {..} = renderWrapper typeWrappers
    where
      renderWrapper (TypeList nextWrapper isNonNull) =
        withNonNull isNonNull $ wrapper KIND_LIST (renderWrapper nextWrapper)
      renderWrapper (BaseType isNonNull) =
        withNonNull isNonNull $ do
          kind <- kindOf <$> getType typeConName
          __Type kind typeConName Nothing []

withNonNull :: (MonadResolver m) => Bool -> IValue m -> IValue m
withNonNull True = wrapper KIND_NON_NULL
withNonNull False = id

__Type ::
  (MonadResolver m) =>
  TypeKind ->
  Name t ->
  Maybe Description ->
  [IField m] ->
  IValue m
__Type kind name desc etc =
  object
    "__Type"
    ( [ fKind kind,
        fName name,
        fDescription desc
      ]
        <> etc
    )

wrapper :: (MonadResolver m) => TypeKind -> IValue m -> IValue m
wrapper k t =
  object
    "__Type"
    [ fKind k,
      ("ofType", t)
    ]

object :: (Monad m) => TypeName -> [IField m] -> IValue m
object name = pure . mkObject name

fDeprecated :: (MonadResolver m) => Directives s -> [IField m]
fDeprecated dirs =
  [ ("isDeprecated", renderI (isJust $ lookupDeprecated dirs)),
    ("deprecationReason", renderI (lookupDeprecated dirs >>= lookupDeprecatedReason))
  ]

fDescription :: (MonadResolver m) => Maybe Description -> IField m
fDescription = ("description",) . renderI

fName :: (MonadResolver m) => Name t -> IField m
fName = ("name",) . renderI

fKind :: (MonadResolver m) => TypeKind -> IField m
fKind = ("kind",) . renderI

fType :: (MonadResolver m) => TypeRef -> IField m
fType = ("type",) . renderI

fDefaultValue :: (MonadResolver m) => Maybe (FieldContent TRUE IN VALID) -> IField m
fDefaultValue = ("defaultValue",) . renderI