{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Validation.Document.Validation
  ( ValidateSchema (..),
  )
where

import Data.Morpheus.Error.Document.Interface
  ( ImplementsError (..),
    PartialImplements (..),
  )
import Data.Morpheus.Ext.SemigroupM
  ( (<:>),
  )
import Data.Morpheus.Internal.Utils
  ( KeyOf (..),
    Selectable (..),
    elems,
    empty,
    failure,
  )
import Data.Morpheus.Schema.Schema
  ( internalSchema,
  )
import Data.Morpheus.Types.Internal.AST
  ( ArgumentDefinition,
    ArgumentsDefinition (..),
    CONST,
    DataEnumValue (..),
    DirectiveDefinition (..),
    DirectiveLocation (..),
    FieldContent (..),
    FieldDefinition (..),
    FieldName (..),
    FieldsDefinition,
    IN,
    OUT,
    Schema (..),
    Schema (..),
    TRUE,
    TypeCategory,
    TypeContent (..),
    TypeDefinition (..),
    TypeKind (..),
    TypeName,
    TypeRef (..),
    Typed (..),
    UnionMember (..),
    VALID,
    Value,
    isWeaker,
  )
import Data.Morpheus.Types.Internal.Config (Config (..))
import Data.Morpheus.Types.Internal.Resolving
  ( Eventless,
  )
import Data.Morpheus.Types.Internal.Validation
  ( InputSource (..),
    InputValidator,
    Scope (..),
    ScopeKind (..),
    runValidator,
    selectType,
    startInput,
  )
import Data.Morpheus.Types.Internal.Validation.SchemaValidator
  ( Field (..),
    Interface (..),
    SchemaValidator,
    TypeSystemContext (..),
    constraintInterface,
    inArgument,
    inField,
    inInterface,
    inType,
  )
import Data.Morpheus.Validation.Internal.Directive
  ( validateDirectives,
  )
import Data.Morpheus.Validation.Internal.Value
  ( validateInputByTypeRef,
  )
import Relude hiding (empty, local)

class ValidateSchema s where
  validateSchema :: Bool -> Config -> Schema s -> Eventless (Schema VALID)

instance ValidateSchema CONST where
  validateSchema :: Bool -> Config -> Schema CONST -> Eventless (Schema VALID)
validateSchema
    Bool
withSystem
    Config
config
    schema :: Schema CONST
schema@Schema
      { TypeLib CONST
types :: forall (s :: Stage). Schema s -> TypeLib s
types :: TypeLib CONST
types,
        TypeDefinition OBJECT CONST
query :: forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query :: TypeDefinition OBJECT CONST
query,
        Maybe (TypeDefinition OBJECT CONST)
mutation :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation :: Maybe (TypeDefinition OBJECT CONST)
mutation,
        Maybe (TypeDefinition OBJECT CONST)
subscription :: forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
subscription :: Maybe (TypeDefinition OBJECT CONST)
subscription,
        [DirectiveDefinition CONST]
directiveDefinitions :: forall (s :: Stage). Schema s -> [DirectiveDefinition s]
directiveDefinitions :: [DirectiveDefinition CONST]
directiveDefinitions
      } = do
      Schema CONST
sysSchema <-
        if Bool
withSystem
          then Schema CONST
forall (s :: Stage). Schema s
internalSchema Schema CONST -> Schema CONST -> Result () (Schema CONST)
forall (m :: * -> *) a. SemigroupM m a => a -> a -> m a
<:> Schema CONST
schema
          else Schema CONST -> Result () (Schema CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema CONST
schema
      Validator CONST (TypeSystemContext ()) (Schema VALID)
-> Config
-> Schema CONST
-> Scope
-> TypeSystemContext ()
-> Eventless (Schema VALID)
forall (s :: Stage) ctx a.
Validator s ctx a
-> Config -> Schema s -> Scope -> ctx -> Eventless a
runValidator
        Validator CONST (TypeSystemContext ()) (Schema VALID)
__validateSchema
        Config
config
        Schema CONST
sysSchema
        Scope :: Maybe Position
-> TypeName
-> TypeKind
-> [TypeWrapper]
-> FieldName
-> ScopeKind
-> Scope
Scope
          { position :: Maybe Position
position = Maybe Position
forall a. Maybe a
Nothing,
            currentTypeName :: TypeName
currentTypeName = TypeName
"Root",
            currentTypeKind :: TypeKind
currentTypeKind = Maybe OperationType -> TypeKind
KindObject Maybe OperationType
forall a. Maybe a
Nothing,
            currentTypeWrappers :: [TypeWrapper]
currentTypeWrappers = [],
            kind :: ScopeKind
kind = ScopeKind
TYPE,
            fieldname :: FieldName
fieldname = FieldName
"Root"
          }
        TypeSystemContext :: forall c. c -> TypeSystemContext c
TypeSystemContext
          { $sel:local:TypeSystemContext :: ()
local = ()
          }
      where
        __validateSchema :: SchemaValidator () (Schema VALID)
        __validateSchema :: Validator CONST (TypeSystemContext ()) (Schema VALID)
__validateSchema =
          TypeLib VALID
-> TypeDefinition OBJECT VALID
-> Maybe (TypeDefinition OBJECT VALID)
-> Maybe (TypeDefinition OBJECT VALID)
-> [DirectiveDefinition VALID]
-> Schema VALID
forall (s :: Stage).
TypeLib s
-> TypeDefinition OBJECT s
-> Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> [DirectiveDefinition s]
-> Schema s
Schema
            (TypeLib VALID
 -> TypeDefinition OBJECT VALID
 -> Maybe (TypeDefinition OBJECT VALID)
 -> Maybe (TypeDefinition OBJECT VALID)
 -> [DirectiveDefinition VALID]
 -> Schema VALID)
-> Validator CONST (TypeSystemContext ()) (TypeLib VALID)
-> Validator
     CONST
     (TypeSystemContext ())
     (TypeDefinition OBJECT VALID
      -> Maybe (TypeDefinition OBJECT VALID)
      -> Maybe (TypeDefinition OBJECT VALID)
      -> [DirectiveDefinition VALID]
      -> Schema VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeDefinition ANY CONST
 -> Validator
      CONST (TypeSystemContext ()) (TypeDefinition ANY VALID))
-> TypeLib CONST
-> Validator CONST (TypeSystemContext ()) (TypeLib VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeDefinition ANY CONST
-> Validator
     CONST (TypeSystemContext ()) (TypeDefinition ANY VALID)
forall (cat :: TypeCategory).
TypeDefinition cat CONST
-> SchemaValidator () (TypeDefinition cat VALID)
validateType TypeLib CONST
types
            Validator
  CONST
  (TypeSystemContext ())
  (TypeDefinition OBJECT VALID
   -> Maybe (TypeDefinition OBJECT VALID)
   -> Maybe (TypeDefinition OBJECT VALID)
   -> [DirectiveDefinition VALID]
   -> Schema VALID)
-> Validator
     CONST (TypeSystemContext ()) (TypeDefinition OBJECT VALID)
-> Validator
     CONST
     (TypeSystemContext ())
     (Maybe (TypeDefinition OBJECT VALID)
      -> Maybe (TypeDefinition OBJECT VALID)
      -> [DirectiveDefinition VALID]
      -> Schema VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeDefinition OBJECT CONST
-> Validator
     CONST (TypeSystemContext ()) (TypeDefinition OBJECT VALID)
forall (cat :: TypeCategory).
TypeDefinition cat CONST
-> SchemaValidator () (TypeDefinition cat VALID)
validateType TypeDefinition OBJECT CONST
query
            Validator
  CONST
  (TypeSystemContext ())
  (Maybe (TypeDefinition OBJECT VALID)
   -> Maybe (TypeDefinition OBJECT VALID)
   -> [DirectiveDefinition VALID]
   -> Schema VALID)
-> Validator
     CONST (TypeSystemContext ()) (Maybe (TypeDefinition OBJECT VALID))
-> Validator
     CONST
     (TypeSystemContext ())
     (Maybe (TypeDefinition OBJECT VALID)
      -> [DirectiveDefinition VALID] -> Schema VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TypeDefinition OBJECT CONST
 -> Validator
      CONST (TypeSystemContext ()) (TypeDefinition OBJECT VALID))
-> Maybe (TypeDefinition OBJECT CONST)
-> Validator
     CONST (TypeSystemContext ()) (Maybe (TypeDefinition OBJECT VALID))
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
validateOptional TypeDefinition OBJECT CONST
-> Validator
     CONST (TypeSystemContext ()) (TypeDefinition OBJECT VALID)
forall (cat :: TypeCategory).
TypeDefinition cat CONST
-> SchemaValidator () (TypeDefinition cat VALID)
validateType Maybe (TypeDefinition OBJECT CONST)
mutation
            Validator
  CONST
  (TypeSystemContext ())
  (Maybe (TypeDefinition OBJECT VALID)
   -> [DirectiveDefinition VALID] -> Schema VALID)
-> Validator
     CONST (TypeSystemContext ()) (Maybe (TypeDefinition OBJECT VALID))
-> Validator
     CONST
     (TypeSystemContext ())
     ([DirectiveDefinition VALID] -> Schema VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TypeDefinition OBJECT CONST
 -> Validator
      CONST (TypeSystemContext ()) (TypeDefinition OBJECT VALID))
-> Maybe (TypeDefinition OBJECT CONST)
-> Validator
     CONST (TypeSystemContext ()) (Maybe (TypeDefinition OBJECT VALID))
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
validateOptional TypeDefinition OBJECT CONST
-> Validator
     CONST (TypeSystemContext ()) (TypeDefinition OBJECT VALID)
forall (cat :: TypeCategory).
TypeDefinition cat CONST
-> SchemaValidator () (TypeDefinition cat VALID)
validateType Maybe (TypeDefinition OBJECT CONST)
subscription
            Validator
  CONST
  (TypeSystemContext ())
  ([DirectiveDefinition VALID] -> Schema VALID)
-> Validator
     CONST (TypeSystemContext ()) [DirectiveDefinition VALID]
-> Validator CONST (TypeSystemContext ()) (Schema VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DirectiveDefinition CONST
 -> Validator
      CONST (TypeSystemContext ()) (DirectiveDefinition VALID))
-> [DirectiveDefinition CONST]
-> Validator
     CONST (TypeSystemContext ()) [DirectiveDefinition VALID]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DirectiveDefinition CONST
-> Validator
     CONST (TypeSystemContext ()) (DirectiveDefinition VALID)
validateDirectiveDefinition [DirectiveDefinition CONST]
directiveDefinitions

validateOptional :: Applicative f => (a -> f b) -> Maybe a -> f (Maybe b)
validateOptional :: (a -> f b) -> Maybe a -> f (Maybe b)
validateOptional a -> f b
f = f (Maybe b) -> (a -> f (Maybe b)) -> Maybe a -> f (Maybe b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe b -> f (Maybe b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing) ((b -> Maybe b) -> f b -> f (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Maybe b
forall a. a -> Maybe a
Just (f b -> f (Maybe b)) -> (a -> f b) -> a -> f (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)

instance ValidateSchema VALID where
  validateSchema :: Bool -> Config -> Schema VALID -> Eventless (Schema VALID)
validateSchema Bool
_ Config
_ = Schema VALID -> Eventless (Schema VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

validateType ::
  TypeDefinition cat CONST ->
  SchemaValidator () (TypeDefinition cat VALID)
validateType :: TypeDefinition cat CONST
-> SchemaValidator () (TypeDefinition cat VALID)
validateType
  TypeDefinition
    { TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName,
      Maybe Description
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
typeDescription :: Maybe Description
typeDescription,
      Directives CONST
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeDirectives :: Directives CONST
typeDirectives,
      TypeContent TRUE cat CONST
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE cat CONST
typeContent
    } =
    TypeName
-> SchemaValidator TypeName (TypeDefinition cat VALID)
-> SchemaValidator () (TypeDefinition cat VALID)
forall v.
TypeName -> SchemaValidator TypeName v -> SchemaValidator () v
inType TypeName
typeName (SchemaValidator TypeName (TypeDefinition cat VALID)
 -> SchemaValidator () (TypeDefinition cat VALID))
-> SchemaValidator TypeName (TypeDefinition cat VALID)
-> SchemaValidator () (TypeDefinition cat VALID)
forall a b. (a -> b) -> a -> b
$
      Maybe Description
-> TypeName
-> Directives VALID
-> TypeContent TRUE cat VALID
-> TypeDefinition cat VALID
forall (a :: TypeCategory) (s :: Stage).
Maybe Description
-> TypeName
-> Directives s
-> TypeContent TRUE a s
-> TypeDefinition a s
TypeDefinition
        Maybe Description
typeDescription
        TypeName
typeName
        (Directives VALID
 -> TypeContent TRUE cat VALID -> TypeDefinition cat VALID)
-> Validator CONST (TypeSystemContext TypeName) (Directives VALID)
-> Validator
     CONST
     (TypeSystemContext TypeName)
     (TypeContent TRUE cat VALID -> TypeDefinition cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DirectiveLocation
-> Directives CONST
-> Validator CONST (TypeSystemContext TypeName) (Directives VALID)
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives (TypeContent TRUE cat CONST -> DirectiveLocation
forall (a :: Bool) (b :: TypeCategory) (c :: Stage).
TypeContent a b c -> DirectiveLocation
typeDirectiveLocation TypeContent TRUE cat CONST
typeContent) Directives CONST
typeDirectives
        Validator
  CONST
  (TypeSystemContext TypeName)
  (TypeContent TRUE cat VALID -> TypeDefinition cat VALID)
-> Validator
     CONST (TypeSystemContext TypeName) (TypeContent TRUE cat VALID)
-> SchemaValidator TypeName (TypeDefinition cat VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeContent TRUE cat CONST
-> Validator
     CONST (TypeSystemContext TypeName) (TypeContent TRUE cat VALID)
forall (cat :: TypeCategory).
TypeContent TRUE cat CONST
-> SchemaValidator TypeName (TypeContent TRUE cat VALID)
validateTypeContent TypeContent TRUE cat CONST
typeContent

typeDirectiveLocation :: TypeContent a b c -> DirectiveLocation
typeDirectiveLocation :: TypeContent a b c -> DirectiveLocation
typeDirectiveLocation DataObject {} = DirectiveLocation
OBJECT
typeDirectiveLocation DataInputObject {} = DirectiveLocation
INPUT_OBJECT
typeDirectiveLocation DataScalar {} = DirectiveLocation
SCALAR
typeDirectiveLocation DataEnum {} = DirectiveLocation
ENUM
typeDirectiveLocation DataInputUnion {} = DirectiveLocation
OBJECT
typeDirectiveLocation DataUnion {} = DirectiveLocation
UNION
typeDirectiveLocation DataInterface {} = DirectiveLocation
INTERFACE

validateTypeContent ::
  TypeContent TRUE cat CONST ->
  SchemaValidator TypeName (TypeContent TRUE cat VALID)
validateTypeContent :: TypeContent TRUE cat CONST
-> SchemaValidator TypeName (TypeContent TRUE cat VALID)
validateTypeContent
  DataObject
    { [TypeName]
objectImplements :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> [TypeName]
objectImplements :: [TypeName]
objectImplements,
      FieldsDefinition OUT CONST
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT CONST
objectFields
    } =
    [TypeName]
-> OrdMap FieldName (FieldDefinition OUT VALID)
-> TypeContent TRUE cat VALID
forall (s :: Stage) (a :: TypeCategory).
[TypeName]
-> FieldsDefinition OUT s -> TypeContent (ELEM OBJECT a) a s
DataObject
      ([TypeName]
 -> OrdMap FieldName (FieldDefinition OUT VALID)
 -> TypeContent TRUE cat VALID)
-> Validator CONST (TypeSystemContext TypeName) [TypeName]
-> Validator
     CONST
     (TypeSystemContext TypeName)
     (OrdMap FieldName (FieldDefinition OUT VALID)
      -> TypeContent TRUE cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeName]
-> FieldsDefinition OUT CONST
-> Validator CONST (TypeSystemContext TypeName) [TypeName]
validateImplements [TypeName]
objectImplements FieldsDefinition OUT CONST
objectFields
      Validator
  CONST
  (TypeSystemContext TypeName)
  (OrdMap FieldName (FieldDefinition OUT VALID)
   -> TypeContent TRUE cat VALID)
-> Validator
     CONST
     (TypeSystemContext TypeName)
     (OrdMap FieldName (FieldDefinition OUT VALID))
-> SchemaValidator TypeName (TypeContent TRUE cat VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (FieldDefinition OUT CONST
 -> Validator
      CONST (TypeSystemContext TypeName) (FieldDefinition OUT VALID))
-> FieldsDefinition OUT CONST
-> Validator
     CONST
     (TypeSystemContext TypeName)
     (OrdMap FieldName (FieldDefinition OUT VALID))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldDefinition OUT CONST
-> Validator
     CONST (TypeSystemContext TypeName) (FieldDefinition OUT VALID)
forall (cat :: TypeCategory).
FieldDirectiveLocation cat =>
FieldDefinition cat CONST
-> SchemaValidator TypeName (FieldDefinition cat VALID)
validateField FieldsDefinition OUT CONST
objectFields
validateTypeContent DataInputObject {FieldsDefinition IN CONST
inputObjectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IN a) a s -> FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN CONST
inputObjectFields} =
  FieldsDefinition IN VALID -> TypeContent TRUE cat VALID
forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition IN s -> TypeContent (ELEM IN a) a s
DataInputObject (FieldsDefinition IN VALID -> TypeContent TRUE cat VALID)
-> Validator
     CONST (TypeSystemContext TypeName) (FieldsDefinition IN VALID)
-> SchemaValidator TypeName (TypeContent TRUE cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDefinition IN CONST
 -> Validator
      CONST (TypeSystemContext TypeName) (FieldDefinition IN VALID))
-> FieldsDefinition IN CONST
-> Validator
     CONST (TypeSystemContext TypeName) (FieldsDefinition IN VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldDefinition IN CONST
-> Validator
     CONST (TypeSystemContext TypeName) (FieldDefinition IN VALID)
forall (cat :: TypeCategory).
FieldDirectiveLocation cat =>
FieldDefinition cat CONST
-> SchemaValidator TypeName (FieldDefinition cat VALID)
validateField FieldsDefinition IN CONST
inputObjectFields
validateTypeContent DataScalar {ScalarDefinition
dataScalar :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM LEAF a) a s -> ScalarDefinition
dataScalar :: ScalarDefinition
..} = TypeContent TRUE cat VALID
-> SchemaValidator TypeName (TypeContent TRUE cat VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DataScalar :: forall (a :: TypeCategory) (s :: Stage).
ScalarDefinition -> TypeContent (ELEM LEAF a) a s
DataScalar {ScalarDefinition
dataScalar :: ScalarDefinition
dataScalar :: ScalarDefinition
..}
validateTypeContent DataEnum {DataEnum CONST
enumMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM LEAF a) a s -> DataEnum s
enumMembers :: DataEnum CONST
enumMembers} = DataEnum VALID -> TypeContent TRUE cat VALID
forall (s :: Stage) (a :: TypeCategory).
DataEnum s -> TypeContent (ELEM LEAF a) a s
DataEnum (DataEnum VALID -> TypeContent TRUE cat VALID)
-> Validator CONST (TypeSystemContext TypeName) (DataEnum VALID)
-> SchemaValidator TypeName (TypeContent TRUE cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataEnumValue CONST
 -> Validator
      CONST (TypeSystemContext TypeName) (DataEnumValue VALID))
-> DataEnum CONST
-> Validator CONST (TypeSystemContext TypeName) (DataEnum VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DataEnumValue CONST
-> Validator
     CONST (TypeSystemContext TypeName) (DataEnumValue VALID)
validateEnumMember DataEnum CONST
enumMembers
validateTypeContent DataInputUnion {DataInputUnion CONST
inputUnionMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM IN a) a s -> DataInputUnion s
inputUnionMembers :: DataInputUnion CONST
inputUnionMembers} =
  DataInputUnion VALID -> TypeContent TRUE cat VALID
forall (s :: Stage) (a :: TypeCategory).
DataInputUnion s -> TypeContent (ELEM IN a) a s
DataInputUnion (DataInputUnion VALID -> TypeContent TRUE cat VALID)
-> Validator
     CONST (TypeSystemContext TypeName) (DataInputUnion VALID)
-> SchemaValidator TypeName (TypeContent TRUE cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnionMember IN CONST
 -> Validator
      CONST (TypeSystemContext TypeName) (UnionMember IN VALID))
-> DataInputUnion CONST
-> Validator
     CONST (TypeSystemContext TypeName) (DataInputUnion VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UnionMember IN CONST
-> Validator
     CONST (TypeSystemContext TypeName) (UnionMember IN VALID)
forall (cat :: TypeCategory).
UnionMember cat CONST
-> SchemaValidator TypeName (UnionMember cat VALID)
validateUnionMember DataInputUnion CONST
inputUnionMembers
validateTypeContent DataUnion {DataUnion CONST
unionMembers :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OUT a) a s -> DataUnion s
unionMembers :: DataUnion CONST
unionMembers} = DataUnion VALID -> TypeContent TRUE cat VALID
forall (s :: Stage) (a :: TypeCategory).
DataUnion s -> TypeContent (ELEM OUT a) a s
DataUnion (DataUnion VALID -> TypeContent TRUE cat VALID)
-> Validator CONST (TypeSystemContext TypeName) (DataUnion VALID)
-> SchemaValidator TypeName (TypeContent TRUE cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnionMember OUT CONST
 -> Validator
      CONST (TypeSystemContext TypeName) (UnionMember OUT VALID))
-> DataUnion CONST
-> Validator CONST (TypeSystemContext TypeName) (DataUnion VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UnionMember OUT CONST
-> Validator
     CONST (TypeSystemContext TypeName) (UnionMember OUT VALID)
forall (cat :: TypeCategory).
UnionMember cat CONST
-> SchemaValidator TypeName (UnionMember cat VALID)
validateUnionMember DataUnion CONST
unionMembers
validateTypeContent (DataInterface FieldsDefinition OUT CONST
fields) =
  OrdMap FieldName (FieldDefinition OUT VALID)
-> TypeContent TRUE cat VALID
forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent (ELEM IMPLEMENTABLE a) a s
DataInterface (OrdMap FieldName (FieldDefinition OUT VALID)
 -> TypeContent TRUE cat VALID)
-> Validator
     CONST
     (TypeSystemContext TypeName)
     (OrdMap FieldName (FieldDefinition OUT VALID))
-> SchemaValidator TypeName (TypeContent TRUE cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDefinition OUT CONST
 -> Validator
      CONST (TypeSystemContext TypeName) (FieldDefinition OUT VALID))
-> FieldsDefinition OUT CONST
-> Validator
     CONST
     (TypeSystemContext TypeName)
     (OrdMap FieldName (FieldDefinition OUT VALID))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldDefinition OUT CONST
-> Validator
     CONST (TypeSystemContext TypeName) (FieldDefinition OUT VALID)
forall (cat :: TypeCategory).
FieldDirectiveLocation cat =>
FieldDefinition cat CONST
-> SchemaValidator TypeName (FieldDefinition cat VALID)
validateField FieldsDefinition OUT CONST
fields

validateEnumMember ::
  DataEnumValue CONST -> SchemaValidator TypeName (DataEnumValue VALID)
validateEnumMember :: DataEnumValue CONST
-> Validator
     CONST (TypeSystemContext TypeName) (DataEnumValue VALID)
validateEnumMember DataEnumValue {enumDirectives :: forall (s :: Stage). DataEnumValue s -> [Directive s]
enumDirectives = Directives CONST
directives, Maybe Description
TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumDescription :: forall (s :: Stage). DataEnumValue s -> Maybe Description
enumName :: TypeName
enumDescription :: Maybe Description
..} =
  Maybe Description
-> TypeName -> Directives VALID -> DataEnumValue VALID
forall (s :: Stage).
Maybe Description -> TypeName -> [Directive s] -> DataEnumValue s
DataEnumValue Maybe Description
enumDescription TypeName
enumName
    (Directives VALID -> DataEnumValue VALID)
-> Validator CONST (TypeSystemContext TypeName) (Directives VALID)
-> Validator
     CONST (TypeSystemContext TypeName) (DataEnumValue VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DirectiveLocation
-> Directives CONST
-> Validator CONST (TypeSystemContext TypeName) (Directives VALID)
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives DirectiveLocation
ENUM_VALUE Directives CONST
directives

validateUnionMember ::
  UnionMember cat CONST -> SchemaValidator TypeName (UnionMember cat VALID)
validateUnionMember :: UnionMember cat CONST
-> SchemaValidator TypeName (UnionMember cat VALID)
validateUnionMember UnionMember {Bool
TypeName
visibility :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Bool
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
visibility :: Bool
memberName :: TypeName
..} = UnionMember cat VALID
-> SchemaValidator TypeName (UnionMember cat VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnionMember :: forall (cat :: TypeCategory) (s :: Stage).
TypeName -> Bool -> UnionMember cat s
UnionMember {Bool
TypeName
visibility :: Bool
memberName :: TypeName
visibility :: Bool
memberName :: TypeName
..}

class FieldDirectiveLocation (cat :: TypeCategory) where
  directiveLocation :: Proxy cat -> DirectiveLocation

instance FieldDirectiveLocation OUT where
  directiveLocation :: Proxy OUT -> DirectiveLocation
directiveLocation Proxy OUT
_ = DirectiveLocation
FIELD_DEFINITION

instance FieldDirectiveLocation IN where
  directiveLocation :: Proxy IN -> DirectiveLocation
directiveLocation Proxy IN
_ = DirectiveLocation
INPUT_FIELD_DEFINITION

validateField ::
  forall cat.
  FieldDirectiveLocation cat =>
  FieldDefinition cat CONST ->
  SchemaValidator TypeName (FieldDefinition cat VALID)
validateField :: FieldDefinition cat CONST
-> SchemaValidator TypeName (FieldDefinition cat VALID)
validateField field :: FieldDefinition cat CONST
field@FieldDefinition {Directives CONST
Maybe Description
Maybe (FieldContent TRUE cat CONST)
TypeRef
FieldName
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> [Directive s]
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Description
fieldDirectives :: Directives CONST
fieldContent :: Maybe (FieldContent TRUE cat CONST)
fieldType :: TypeRef
fieldName :: FieldName
fieldDescription :: Maybe Description
..} =
  FieldName
-> SchemaValidator
     (TypeName, FieldName) (FieldDefinition cat VALID)
-> SchemaValidator TypeName (FieldDefinition cat VALID)
forall t v.
FieldName
-> SchemaValidator (t, FieldName) v -> SchemaValidator t v
inField
    FieldName
fieldName
    ( Maybe Description
-> FieldName
-> TypeRef
-> Maybe (FieldContent TRUE cat VALID)
-> Directives VALID
-> FieldDefinition cat VALID
forall (cat :: TypeCategory) (s :: Stage).
Maybe Description
-> FieldName
-> TypeRef
-> Maybe (FieldContent TRUE cat s)
-> [Directive s]
-> FieldDefinition cat s
FieldDefinition
        Maybe Description
fieldDescription
        FieldName
fieldName
        TypeRef
fieldType
        (Maybe (FieldContent TRUE cat VALID)
 -> Directives VALID -> FieldDefinition cat VALID)
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (Maybe (FieldContent TRUE cat VALID))
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (Directives VALID -> FieldDefinition cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldContent TRUE cat CONST
 -> Validator
      CONST
      (TypeSystemContext (TypeName, FieldName))
      (FieldContent TRUE cat VALID))
-> Maybe (FieldContent TRUE cat CONST)
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (Maybe (FieldContent TRUE cat VALID))
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
validateOptional (FieldDefinition cat CONST
-> FieldContent TRUE cat CONST
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (FieldContent TRUE cat VALID)
forall (cat :: TypeCategory).
FieldDefinition cat CONST
-> FieldContent TRUE cat CONST
-> SchemaValidator
     (TypeName, FieldName) (FieldContent TRUE cat VALID)
checkFieldContent FieldDefinition cat CONST
field) Maybe (FieldContent TRUE cat CONST)
fieldContent
        Validator
  CONST
  (TypeSystemContext (TypeName, FieldName))
  (Directives VALID -> FieldDefinition cat VALID)
-> Validator
     CONST (TypeSystemContext (TypeName, FieldName)) (Directives VALID)
-> SchemaValidator
     (TypeName, FieldName) (FieldDefinition cat VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DirectiveLocation
-> Directives CONST
-> Validator
     CONST (TypeSystemContext (TypeName, FieldName)) (Directives VALID)
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives (Proxy cat -> DirectiveLocation
forall (cat :: TypeCategory).
FieldDirectiveLocation cat =>
Proxy cat -> DirectiveLocation
directiveLocation (Proxy cat
forall k (t :: k). Proxy t
Proxy @cat)) Directives CONST
fieldDirectives
    )

checkFieldContent ::
  FieldDefinition cat CONST ->
  FieldContent TRUE cat CONST ->
  SchemaValidator (TypeName, FieldName) (FieldContent TRUE cat VALID)
checkFieldContent :: FieldDefinition cat CONST
-> FieldContent TRUE cat CONST
-> SchemaValidator
     (TypeName, FieldName) (FieldContent TRUE cat VALID)
checkFieldContent FieldDefinition cat CONST
_ (FieldArgs ArgumentsDefinition CONST
argsDef) = ArgumentsDefinition VALID -> FieldContent TRUE cat VALID
forall (s :: Stage) (cat :: TypeCategory).
ArgumentsDefinition s -> FieldContent (ELEM OUT cat) cat s
FieldArgs (ArgumentsDefinition VALID -> FieldContent TRUE cat VALID)
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (ArgumentsDefinition VALID)
-> SchemaValidator
     (TypeName, FieldName) (FieldContent TRUE cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgumentsDefinition CONST
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (ArgumentsDefinition VALID)
validateArgumentsDefinition ArgumentsDefinition CONST
argsDef
checkFieldContent FieldDefinition {TypeRef
fieldType :: TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType} (DefaultInputValue Value CONST
value) = do
  (TypeName
typeName, FieldName
fName) <- (TypeSystemContext (TypeName, FieldName) -> (TypeName, FieldName))
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (TypeName, FieldName)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TypeSystemContext (TypeName, FieldName) -> (TypeName, FieldName)
forall c. TypeSystemContext c -> c
local
  Value VALID -> FieldContent TRUE cat VALID
forall (s :: Stage) (cat :: TypeCategory).
Value s -> FieldContent (ELEM IN cat) cat s
DefaultInputValue
    (Value VALID -> FieldContent TRUE cat VALID)
-> Validator
     CONST (TypeSystemContext (TypeName, FieldName)) (Value VALID)
-> SchemaValidator
     (TypeName, FieldName) (FieldContent TRUE cat VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputSource
-> InputValidator
     CONST (TypeSystemContext (TypeName, FieldName)) (Value VALID)
-> Validator
     CONST (TypeSystemContext (TypeName, FieldName)) (Value VALID)
forall (s :: Stage) ctx a.
InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput
      (TypeName -> FieldName -> Maybe FieldName -> InputSource
SourceInputField TypeName
typeName FieldName
fName Maybe FieldName
forall a. Maybe a
Nothing)
      (TypeRef
-> Value CONST
-> InputValidator
     CONST (TypeSystemContext (TypeName, FieldName)) (Value VALID)
validateDefaultValue TypeRef
fieldType Value CONST
value)

validateArgumentsDefinition ::
  ArgumentsDefinition CONST ->
  SchemaValidator (TypeName, FieldName) (ArgumentsDefinition VALID)
validateArgumentsDefinition :: ArgumentsDefinition CONST
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (ArgumentsDefinition VALID)
validateArgumentsDefinition (ArgumentsDefinition Maybe TypeName
meta FieldsDefinition IN CONST
args) =
  Maybe TypeName
-> FieldsDefinition IN VALID -> ArgumentsDefinition VALID
forall (s :: Stage).
Maybe TypeName
-> OrdMap FieldName (ArgumentDefinition s) -> ArgumentsDefinition s
ArgumentsDefinition Maybe TypeName
meta
    (FieldsDefinition IN VALID -> ArgumentsDefinition VALID)
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (FieldsDefinition IN VALID)
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (ArgumentsDefinition VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDefinition IN CONST
 -> Validator
      CONST
      (TypeSystemContext (TypeName, FieldName))
      (FieldDefinition IN VALID))
-> FieldsDefinition IN CONST
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (FieldsDefinition IN VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
      FieldDefinition IN CONST
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (FieldDefinition IN VALID)
validateArgumentDefinition
      FieldsDefinition IN CONST
args

validateArgumentDefinition ::
  ArgumentDefinition CONST ->
  SchemaValidator (TypeName, FieldName) (ArgumentDefinition VALID)
validateArgumentDefinition :: FieldDefinition IN CONST
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (FieldDefinition IN VALID)
validateArgumentDefinition FieldDefinition {Directives CONST
Maybe Description
Maybe (FieldContent TRUE IN CONST)
TypeRef
FieldName
fieldDirectives :: Directives CONST
fieldContent :: Maybe (FieldContent TRUE IN CONST)
fieldType :: TypeRef
fieldName :: FieldName
fieldDescription :: Maybe Description
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> [Directive s]
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Description
..} =
  Maybe Description
-> FieldName
-> TypeRef
-> Maybe (FieldContent TRUE IN VALID)
-> Directives VALID
-> FieldDefinition IN VALID
forall (cat :: TypeCategory) (s :: Stage).
Maybe Description
-> FieldName
-> TypeRef
-> Maybe (FieldContent TRUE cat s)
-> [Directive s]
-> FieldDefinition cat s
FieldDefinition
    Maybe Description
fieldDescription
    FieldName
fieldName
    TypeRef
fieldType
    (Maybe (FieldContent TRUE IN VALID)
 -> Directives VALID -> FieldDefinition IN VALID)
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (Maybe (FieldContent TRUE IN VALID))
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (Directives VALID -> FieldDefinition IN VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldContent TRUE IN CONST
 -> Validator
      CONST
      (TypeSystemContext (TypeName, FieldName))
      (FieldContent TRUE IN VALID))
-> Maybe (FieldContent TRUE IN CONST)
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (Maybe (FieldContent TRUE IN VALID))
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
validateOptional (FieldName
-> TypeRef
-> FieldContent TRUE IN CONST
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (FieldContent TRUE IN VALID)
validateArgumentDefaultValue FieldName
fieldName TypeRef
fieldType) Maybe (FieldContent TRUE IN CONST)
fieldContent
    Validator
  CONST
  (TypeSystemContext (TypeName, FieldName))
  (Directives VALID -> FieldDefinition IN VALID)
-> Validator
     CONST (TypeSystemContext (TypeName, FieldName)) (Directives VALID)
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (FieldDefinition IN VALID)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DirectiveLocation
-> Directives CONST
-> Validator
     CONST (TypeSystemContext (TypeName, FieldName)) (Directives VALID)
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives DirectiveLocation
ARGUMENT_DEFINITION Directives CONST
fieldDirectives

validateArgumentDefaultValue ::
  FieldName ->
  TypeRef ->
  FieldContent TRUE IN CONST ->
  SchemaValidator (TypeName, FieldName) (FieldContent TRUE IN VALID)
validateArgumentDefaultValue :: FieldName
-> TypeRef
-> FieldContent TRUE IN CONST
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (FieldContent TRUE IN VALID)
validateArgumentDefaultValue FieldName
argName TypeRef
fieldType (DefaultInputValue Value CONST
value) =
  do
    (TypeName
typeName, FieldName
fName) <- (TypeSystemContext (TypeName, FieldName) -> (TypeName, FieldName))
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (TypeName, FieldName)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TypeSystemContext (TypeName, FieldName) -> (TypeName, FieldName)
forall c. TypeSystemContext c -> c
local
    Value VALID
v <-
      InputSource
-> InputValidator
     CONST (TypeSystemContext (TypeName, FieldName)) (Value VALID)
-> Validator
     CONST (TypeSystemContext (TypeName, FieldName)) (Value VALID)
forall (s :: Stage) ctx a.
InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput
        (TypeName -> FieldName -> Maybe FieldName -> InputSource
SourceInputField TypeName
typeName FieldName
fName (FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just FieldName
argName))
        (TypeRef
-> Value CONST
-> InputValidator
     CONST (TypeSystemContext (TypeName, FieldName)) (Value VALID)
validateDefaultValue TypeRef
fieldType Value CONST
value)
    FieldContent TRUE IN VALID
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (FieldContent TRUE IN VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value VALID -> FieldContent (ELEM IN IN) IN VALID
forall (s :: Stage) (cat :: TypeCategory).
Value s -> FieldContent (ELEM IN cat) cat s
DefaultInputValue Value VALID
v)

-- INETRFACE
----------------------------
validateImplements ::
  [TypeName] ->
  FieldsDefinition OUT CONST ->
  SchemaValidator TypeName [TypeName]
validateImplements :: [TypeName]
-> FieldsDefinition OUT CONST
-> Validator CONST (TypeSystemContext TypeName) [TypeName]
validateImplements [TypeName]
objectImplements FieldsDefinition OUT CONST
objectFields =
  ( (TypeName
 -> Validator
      CONST
      (TypeSystemContext TypeName)
      (TypeName, FieldsDefinition OUT CONST))
-> [TypeName]
-> Validator
     CONST
     (TypeSystemContext TypeName)
     [(TypeName, FieldsDefinition OUT CONST)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeName
-> Validator
     CONST
     (TypeSystemContext TypeName)
     (TypeName, FieldsDefinition OUT CONST)
forall ctx.
TypeName
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
selectInterface [TypeName]
objectImplements
      Validator
  CONST
  (TypeSystemContext TypeName)
  [(TypeName, FieldsDefinition OUT CONST)]
-> ([(TypeName, FieldsDefinition OUT CONST)]
    -> Validator CONST (TypeSystemContext TypeName) ())
-> Validator CONST (TypeSystemContext TypeName) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((TypeName, FieldsDefinition OUT CONST)
 -> Validator CONST (TypeSystemContext TypeName) ())
-> [(TypeName, FieldsDefinition OUT CONST)]
-> Validator CONST (TypeSystemContext TypeName) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FieldsDefinition OUT CONST
-> (TypeName, FieldsDefinition OUT CONST)
-> Validator CONST (TypeSystemContext TypeName) ()
mustBeSubset FieldsDefinition OUT CONST
objectFields)
  )
    Validator CONST (TypeSystemContext TypeName) ()
-> [TypeName]
-> Validator CONST (TypeSystemContext TypeName) [TypeName]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [TypeName]
objectImplements

mustBeSubset ::
  FieldsDefinition OUT CONST ->
  (TypeName, FieldsDefinition OUT CONST) ->
  SchemaValidator TypeName ()
mustBeSubset :: FieldsDefinition OUT CONST
-> (TypeName, FieldsDefinition OUT CONST)
-> Validator CONST (TypeSystemContext TypeName) ()
mustBeSubset FieldsDefinition OUT CONST
objFields (TypeName
typeName, FieldsDefinition OUT CONST
fields) =
  TypeName
-> SchemaValidator Interface ()
-> Validator CONST (TypeSystemContext TypeName) ()
forall v.
TypeName
-> SchemaValidator Interface v -> SchemaValidator TypeName v
inInterface TypeName
typeName (SchemaValidator Interface ()
 -> Validator CONST (TypeSystemContext TypeName) ())
-> SchemaValidator Interface ()
-> Validator CONST (TypeSystemContext TypeName) ()
forall a b. (a -> b) -> a -> b
$
    (FieldDefinition OUT CONST -> SchemaValidator Interface ())
-> [FieldDefinition OUT CONST] -> SchemaValidator Interface ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FieldsDefinition OUT CONST
-> FieldDefinition OUT CONST -> SchemaValidator Interface ()
checkInterfaceField FieldsDefinition OUT CONST
objFields) (FieldsDefinition OUT CONST -> [FieldDefinition OUT CONST]
forall a coll. Elems a coll => coll -> [a]
elems FieldsDefinition OUT CONST
fields)

checkInterfaceField ::
  FieldsDefinition OUT CONST ->
  FieldDefinition OUT CONST ->
  SchemaValidator Interface ()
checkInterfaceField :: FieldsDefinition OUT CONST
-> FieldDefinition OUT CONST -> SchemaValidator Interface ()
checkInterfaceField
  FieldsDefinition OUT CONST
objFields
  interfaceField :: FieldDefinition OUT CONST
interfaceField@FieldDefinition
    { FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName,
      Directives CONST
fieldDirectives :: Directives CONST
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> [Directive s]
fieldDirectives
    } =
    FieldName
-> SchemaValidator (Interface, FieldName) ()
-> SchemaValidator Interface ()
forall t v.
FieldName
-> SchemaValidator (t, FieldName) v -> SchemaValidator t v
inField FieldName
fieldName (SchemaValidator (Interface, FieldName) ()
 -> SchemaValidator Interface ())
-> SchemaValidator (Interface, FieldName) ()
-> SchemaValidator Interface ()
forall a b. (a -> b) -> a -> b
$
      DirectiveLocation
-> Directives CONST
-> Validator
     CONST (TypeSystemContext (Interface, FieldName)) (Directives VALID)
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives DirectiveLocation
FIELD_DEFINITION Directives CONST
fieldDirectives
        Validator
  CONST (TypeSystemContext (Interface, FieldName)) (Directives VALID)
-> SchemaValidator (Interface, FieldName) ()
-> SchemaValidator (Interface, FieldName) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SchemaValidator (Interface, FieldName) ()
-> (FieldDefinition OUT CONST
    -> SchemaValidator (Interface, FieldName) ())
-> FieldName
-> FieldsDefinition OUT CONST
-> SchemaValidator (Interface, FieldName) ()
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr SchemaValidator (Interface, FieldName) ()
forall a. SchemaValidator (Interface, FieldName) a
err (FieldDefinition OUT CONST
-> FieldDefinition OUT CONST
-> SchemaValidator (Interface, FieldName) ()
forall a ctx. TypeEq a ctx => a -> a -> SchemaValidator ctx ()
isSuptype FieldDefinition OUT CONST
interfaceField) FieldName
fieldName FieldsDefinition OUT CONST
objFields
    where
      err :: SchemaValidator (Interface, FieldName) a
err = ImplementsError -> SchemaValidator (Interface, FieldName) a
forall ctx a.
PartialImplements ctx =>
ImplementsError -> SchemaValidator ctx a
failImplements ImplementsError
Missing

class PartialImplements ctx => TypeEq a ctx where
  isSuptype :: a -> a -> SchemaValidator ctx ()

instance TypeEq (FieldDefinition OUT CONST) (Interface, FieldName) where
  FieldDefinition
    { TypeRef
fieldType :: TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType,
      fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent = Maybe (FieldContent TRUE OUT CONST)
args1
    }
    isSuptype :: FieldDefinition OUT CONST
-> FieldDefinition OUT CONST
-> SchemaValidator (Interface, FieldName) ()
`isSuptype` FieldDefinition
      { fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef
fieldType',
        fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent = Maybe (FieldContent TRUE OUT CONST)
args2
      } = (TypeRef
fieldType TypeRef -> TypeRef -> SchemaValidator (Interface, FieldName) ()
forall a ctx. TypeEq a ctx => a -> a -> SchemaValidator ctx ()
`isSuptype` TypeRef
fieldType') SchemaValidator (Interface, FieldName) ()
-> SchemaValidator (Interface, FieldName) ()
-> SchemaValidator (Interface, FieldName) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Maybe (FieldContent TRUE OUT CONST)
args1 Maybe (FieldContent TRUE OUT CONST)
-> Maybe (FieldContent TRUE OUT CONST)
-> SchemaValidator (Interface, FieldName) ()
forall a ctx. TypeEq a ctx => a -> a -> SchemaValidator ctx ()
`isSuptype` Maybe (FieldContent TRUE OUT CONST)
args2)

instance TypeEq (Maybe (FieldContent TRUE OUT s)) (Interface, FieldName) where
  Maybe (FieldContent TRUE OUT s)
f1 isSuptype :: Maybe (FieldContent TRUE OUT s)
-> Maybe (FieldContent TRUE OUT s)
-> SchemaValidator (Interface, FieldName) ()
`isSuptype` Maybe (FieldContent TRUE OUT s)
f2 = Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
toARgs Maybe (FieldContent TRUE OUT s)
f1 ArgumentsDefinition s
-> ArgumentsDefinition s
-> SchemaValidator (Interface, FieldName) ()
forall a ctx. TypeEq a ctx => a -> a -> SchemaValidator ctx ()
`isSuptype` Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
toARgs Maybe (FieldContent TRUE OUT s)
f2
    where
      toARgs :: Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
      toARgs :: Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
toARgs (Just (FieldArgs ArgumentsDefinition s
args)) = ArgumentsDefinition s
args
      toARgs Maybe (FieldContent TRUE OUT s)
_ = ArgumentsDefinition s
forall a coll. Collection a coll => coll
empty

instance (PartialImplements ctx) => TypeEq TypeRef ctx where
  t1 :: TypeRef
t1@TypeRef
    { TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName,
      typeWrappers :: TypeRef -> [TypeWrapper]
typeWrappers = [TypeWrapper]
w1
    }
    isSuptype :: TypeRef -> TypeRef -> SchemaValidator ctx ()
`isSuptype` t2 :: TypeRef
t2@TypeRef
      { typeConName :: TypeRef -> TypeName
typeConName = TypeName
name',
        typeWrappers :: TypeRef -> [TypeWrapper]
typeWrappers = [TypeWrapper]
w2
      }
      | TypeName
typeConName TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeName
name' Bool -> Bool -> Bool
&& Bool -> Bool
not ([TypeWrapper] -> [TypeWrapper] -> Bool
isWeaker [TypeWrapper]
w2 [TypeWrapper]
w1) = () -> SchemaValidator ctx ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise =
        ImplementsError -> SchemaValidator ctx ()
forall ctx a.
PartialImplements ctx =>
ImplementsError -> SchemaValidator ctx a
failImplements UnexpectedType :: TypeRef -> TypeRef -> ImplementsError
UnexpectedType {expectedType :: TypeRef
expectedType = TypeRef
t1, foundType :: TypeRef
foundType = TypeRef
t2}

elemIn ::
  ( KeyOf k a,
    Selectable k a c,
    TypeEq a ctx
  ) =>
  a ->
  c ->
  SchemaValidator ctx ()
elemIn :: a -> c -> SchemaValidator ctx ()
elemIn a
el = SchemaValidator ctx ()
-> (a -> SchemaValidator ctx ())
-> k
-> c
-> SchemaValidator ctx ()
forall k a c d. Selectable k a c => d -> (a -> d) -> k -> c -> d
selectOr (ImplementsError -> SchemaValidator ctx ()
forall ctx a.
PartialImplements ctx =>
ImplementsError -> SchemaValidator ctx a
failImplements ImplementsError
Missing) (a -> a -> SchemaValidator ctx ()
forall a ctx. TypeEq a ctx => a -> a -> SchemaValidator ctx ()
isSuptype a
el) (a -> k
forall k a. KeyOf k a => a -> k
keyOf a
el)

instance TypeEq (ArgumentsDefinition s) (Interface, FieldName) where
  ArgumentsDefinition s
args1 isSuptype :: ArgumentsDefinition s
-> ArgumentsDefinition s
-> SchemaValidator (Interface, FieldName) ()
`isSuptype` ArgumentsDefinition s
args2 = (ArgumentDefinition s -> SchemaValidator (Interface, FieldName) ())
-> [ArgumentDefinition s]
-> SchemaValidator (Interface, FieldName) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ArgumentDefinition s -> SchemaValidator (Interface, FieldName) ()
validateArg (ArgumentsDefinition s -> [ArgumentDefinition s]
forall a coll. Elems a coll => coll -> [a]
elems ArgumentsDefinition s
args1)
    where
      validateArg :: ArgumentDefinition s -> SchemaValidator (Interface, FieldName) ()
validateArg ArgumentDefinition s
arg = FieldName
-> SchemaValidator (Interface, Field) ()
-> SchemaValidator (Interface, FieldName) ()
forall t v.
FieldName
-> SchemaValidator (t, Field) v -> SchemaValidator (t, FieldName) v
inArgument (ArgumentDefinition s -> FieldName
forall k a. KeyOf k a => a -> k
keyOf ArgumentDefinition s
arg) (SchemaValidator (Interface, Field) ()
 -> SchemaValidator (Interface, FieldName) ())
-> SchemaValidator (Interface, Field) ()
-> SchemaValidator (Interface, FieldName) ()
forall a b. (a -> b) -> a -> b
$ ArgumentDefinition s
-> ArgumentsDefinition s -> SchemaValidator (Interface, Field) ()
forall k a c ctx.
(KeyOf k a, Selectable k a c, TypeEq a ctx) =>
a -> c -> SchemaValidator ctx ()
elemIn ArgumentDefinition s
arg ArgumentsDefinition s
args2

instance TypeEq (ArgumentDefinition s) (Interface, Field) where
  ArgumentDefinition s
arg1 isSuptype :: ArgumentDefinition s
-> ArgumentDefinition s -> SchemaValidator (Interface, Field) ()
`isSuptype` ArgumentDefinition s
arg2 = ArgumentDefinition s -> TypeRef
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType ArgumentDefinition s
arg1 TypeRef -> TypeRef -> SchemaValidator (Interface, Field) ()
forall a ctx. TypeEq a ctx => a -> a -> SchemaValidator ctx ()
`isSuptype` ArgumentDefinition s -> TypeRef
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType ArgumentDefinition s
arg2

-------------------------------
selectInterface ::
  TypeName ->
  SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
selectInterface :: TypeName
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
selectInterface = TypeName
-> Validator
     CONST (TypeSystemContext ctx) (TypeDefinition ANY CONST)
forall (s :: Stage) ctx.
TypeName -> Validator s ctx (TypeDefinition ANY s)
selectType (TypeName
 -> Validator
      CONST (TypeSystemContext ctx) (TypeDefinition ANY CONST))
-> (TypeDefinition ANY CONST
    -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST))
-> TypeName
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TypeDefinition ANY CONST
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
forall ctx.
TypeDefinition ANY CONST
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
constraintInterface

failImplements ::
  PartialImplements ctx =>
  ImplementsError ->
  SchemaValidator ctx a
failImplements :: ImplementsError -> SchemaValidator ctx a
failImplements ImplementsError
err = do
  ctx
x <- (TypeSystemContext ctx -> ctx)
-> Validator CONST (TypeSystemContext ctx) ctx
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TypeSystemContext ctx -> ctx
forall c. TypeSystemContext c -> c
local
  ValidationError -> SchemaValidator ctx a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationError -> SchemaValidator ctx a)
-> ValidationError -> SchemaValidator ctx a
forall a b. (a -> b) -> a -> b
$ ctx -> ImplementsError -> ValidationError
forall ctx.
PartialImplements ctx =>
ctx -> ImplementsError -> ValidationError
partialImplements ctx
x ImplementsError
err

-- DEFAULT VALUE

validateDefaultValue ::
  TypeRef ->
  Value CONST ->
  InputValidator
    CONST
    (TypeSystemContext (TypeName, FieldName))
    (Value VALID)
validateDefaultValue :: TypeRef
-> Value CONST
-> InputValidator
     CONST (TypeSystemContext (TypeName, FieldName)) (Value VALID)
validateDefaultValue TypeRef
typeRef =
  Typed IN CONST TypeRef
-> Value CONST
-> InputValidator
     CONST (TypeSystemContext (TypeName, FieldName)) (Value VALID)
forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
Typed IN schemaS TypeRef
-> Value s -> Validator schemaS (InputContext c) (Value VALID)
validateInputByTypeRef (TypeRef -> Typed IN CONST TypeRef
forall (cat :: TypeCategory) (s :: Stage) a. a -> Typed cat s a
Typed TypeRef
typeRef)

validateDirectiveDefinition :: DirectiveDefinition CONST -> SchemaValidator () (DirectiveDefinition VALID)
validateDirectiveDefinition :: DirectiveDefinition CONST
-> Validator
     CONST (TypeSystemContext ()) (DirectiveDefinition VALID)
validateDirectiveDefinition DirectiveDefinition {directiveDefinitionArgs :: forall (s :: Stage). DirectiveDefinition s -> ArgumentsDefinition s
directiveDefinitionArgs = ArgumentsDefinition CONST
args, [DirectiveLocation]
Maybe Description
FieldName
directiveDefinitionLocations :: forall (s :: Stage). DirectiveDefinition s -> [DirectiveLocation]
directiveDefinitionDescription :: forall (s :: Stage). DirectiveDefinition s -> Maybe Description
directiveDefinitionName :: forall (s :: Stage). DirectiveDefinition s -> FieldName
directiveDefinitionLocations :: [DirectiveLocation]
directiveDefinitionDescription :: Maybe Description
directiveDefinitionName :: FieldName
..} =
  TypeName
-> SchemaValidator TypeName (DirectiveDefinition VALID)
-> Validator
     CONST (TypeSystemContext ()) (DirectiveDefinition VALID)
forall v.
TypeName -> SchemaValidator TypeName v -> SchemaValidator () v
inType TypeName
"Directive" (SchemaValidator TypeName (DirectiveDefinition VALID)
 -> Validator
      CONST (TypeSystemContext ()) (DirectiveDefinition VALID))
-> SchemaValidator TypeName (DirectiveDefinition VALID)
-> Validator
     CONST (TypeSystemContext ()) (DirectiveDefinition VALID)
forall a b. (a -> b) -> a -> b
$ FieldName
-> SchemaValidator
     (TypeName, FieldName) (DirectiveDefinition VALID)
-> SchemaValidator TypeName (DirectiveDefinition VALID)
forall t v.
FieldName
-> SchemaValidator (t, FieldName) v -> SchemaValidator t v
inField FieldName
directiveDefinitionName (SchemaValidator (TypeName, FieldName) (DirectiveDefinition VALID)
 -> SchemaValidator TypeName (DirectiveDefinition VALID))
-> SchemaValidator
     (TypeName, FieldName) (DirectiveDefinition VALID)
-> SchemaValidator TypeName (DirectiveDefinition VALID)
forall a b. (a -> b) -> a -> b
$ do
    ArgumentsDefinition VALID
directiveDefinitionArgs <- ArgumentsDefinition CONST
-> Validator
     CONST
     (TypeSystemContext (TypeName, FieldName))
     (ArgumentsDefinition VALID)
validateArgumentsDefinition ArgumentsDefinition CONST
args
    DirectiveDefinition VALID
-> SchemaValidator
     (TypeName, FieldName) (DirectiveDefinition VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DirectiveDefinition :: forall (s :: Stage).
FieldName
-> Maybe Description
-> ArgumentsDefinition s
-> [DirectiveLocation]
-> DirectiveDefinition s
DirectiveDefinition {[DirectiveLocation]
Maybe Description
FieldName
ArgumentsDefinition VALID
directiveDefinitionArgs :: ArgumentsDefinition VALID
directiveDefinitionLocations :: [DirectiveLocation]
directiveDefinitionDescription :: Maybe Description
directiveDefinitionName :: FieldName
directiveDefinitionLocations :: [DirectiveLocation]
directiveDefinitionDescription :: Maybe Description
directiveDefinitionName :: FieldName
directiveDefinitionArgs :: ArgumentsDefinition VALID
..}