{-# 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)
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
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
..}