content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  
  module Data.Morpheus.Types.Internal.Validation.SchemaValidator
    ( SchemaValidator,
      TypeSystemContext (..),
      constraintInterface,
      renderField,
      withLocalContext,
      runSchemaValidator,
      inInterface,
      inType,
      inField,
      inArgument,
      ON_INTERFACE,
      ON_TYPE,
      TypeEntity (..),
      Field (..),
      InterfaceName (..),
      PLACE,
    )
  where
  
  import Control.Monad.Except (throwError)
  import Data.Morpheus.Ext.Result (GQLResult)
  import Data.Morpheus.Types.Internal.AST
    ( ANY,
      CONST,
      FieldName,
      FieldsDefinition,
      Name,
      OUT,
      PropName (PropName),
      TypeContent (..),
      TypeDefinition (..),
      TypeName,
      mkBaseType,
      msg,
      unpackName,
    )
  import Data.Morpheus.Types.Internal.AST.Type (TypeKind (KIND_OBJECT))
  import Data.Morpheus.Types.Internal.AST.TypeSystem (Schema)
  import Data.Morpheus.Types.Internal.Config (Config)
  import Data.Morpheus.Types.Internal.Validation (Scope (..), ScopeKind (TYPE), runValidator)
  import Data.Morpheus.Types.Internal.Validation.Validator
    ( Validator (..),
      renderField,
      withContext,
      withScope,
    )
  import Relude hiding (local)
  
  inInterface ::
    TypeName ->
    SchemaValidator (TypeEntity 'ON_INTERFACE) v ->
    SchemaValidator (TypeEntity 'ON_TYPE) v
  inInterface name = pushPath name . withLocalContext (\t -> t {interfaceName = OnInterface name})
  
  inType ::
    TypeName ->
    SchemaValidator (TypeEntity 'ON_TYPE) v ->
    SchemaValidator () v
  inType name = pushPath name . withLocalContext (const (TypeEntity OnType name))
  
  inField ::
    FieldName ->
    SchemaValidator (Field p) v ->
    SchemaValidator (TypeEntity p) v
  inField fieldName = pushPath fieldName . withLocalContext (Field fieldName Nothing)
  
  inArgument ::
    FieldName ->
    SchemaValidator (Field p) v ->
    SchemaValidator (Field p) v
  inArgument name = pushPath name . withLocalContext (\field -> field {fieldArgument = Just name})
  
  data PLACE = ON_INTERFACE | ON_TYPE
  
  type ON_INTERFACE = 'ON_INTERFACE
  
  type ON_TYPE = 'ON_TYPE
  
  data InterfaceName (p :: PLACE) where
    OnInterface :: TypeName -> InterfaceName 'ON_INTERFACE
    OnType :: InterfaceName 'ON_TYPE
  
  data TypeEntity (p :: PLACE) = TypeEntity
    { interfaceName :: InterfaceName p,
      typeName :: TypeName
    }
  
  data Field p = Field
    { fieldName :: FieldName,
      fieldArgument :: Maybe FieldName,
      fieldOf :: TypeEntity p
    }
  
  initialScope :: Scope
  initialScope =
    Scope
      { position = Nothing,
        currentTypeName = "Root",
        currentTypeKind = KIND_OBJECT Nothing,
        currentTypeWrappers = mkBaseType,
        kind = TYPE,
        fieldName = "Root",
        path = []
      }
  
  newtype TypeSystemContext c = TypeSystemContext
    {local :: c}
    deriving (Show)
  
  pushPath :: Name t -> SchemaValidator a v -> SchemaValidator a v
  pushPath name = withScope (\x -> x {path = path x <> [PropName (unpackName name)]})
  
  withLocalContext :: (a -> b) -> SchemaValidator b v -> SchemaValidator a v
  withLocalContext = withContext . updateLocal
  
  updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b
  updateLocal f ctx = ctx {local = f (local ctx)}
  
  type SchemaValidator c = Validator CONST (TypeSystemContext c)
  
  runSchemaValidator :: Validator s (TypeSystemContext ()) a -> Config -> Schema s -> GQLResult a
  runSchemaValidator value config sysSchema =
    runValidator
      value
      config
      sysSchema
      initialScope
      TypeSystemContext
        { local = ()
        }
  
  constraintInterface ::
    TypeDefinition ANY CONST ->
    SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
  constraintInterface
    TypeDefinition
      { typeName,
        typeContent = DataInterface fields
      } = pure (typeName, fields)
  constraintInterface TypeDefinition {typeName} =
    throwError $ "type " <> msg typeName <> " must be an interface"
  