{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Morpheus.Validation.Document.Interface
( validateImplements,
)
where
import Control.Monad.Except (throwError)
import Data.Morpheus.Error.Document.Interface
( ImplementsError (..),
partialImplements,
)
import Data.Morpheus.Internal.Utils
( KeyOf (..),
empty,
selectOr,
)
import Data.Morpheus.Types.Internal.AST
( ArgumentDefinition (..),
ArgumentsDefinition,
CONST,
FieldContent (..),
FieldDefinition (..),
FieldsDefinition,
OUT,
Subtyping (..),
TRUE,
TypeName,
TypeRef (..),
)
import Data.Morpheus.Types.Internal.Validation
( ValidatorContext (localContext),
selectType,
)
import Data.Morpheus.Types.Internal.Validation.SchemaValidator
( Field (..),
ON_INTERFACE,
ON_TYPE,
PLACE,
SchemaValidator,
TypeEntity (..),
TypeSystemContext (..),
constraintInterface,
inArgument,
inField,
inInterface,
)
import Relude hiding (empty, local)
validateImplements ::
[TypeName] ->
FieldsDefinition OUT CONST ->
SchemaValidator (TypeEntity ON_TYPE) [TypeName]
validateImplements :: [TypeName]
-> FieldsDefinition OUT CONST
-> SchemaValidator (TypeEntity ON_TYPE) [TypeName]
validateImplements [TypeName]
interfaceNames FieldsDefinition OUT CONST
objectFields =
(TypeName
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ())
-> [TypeName]
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) [()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (TypeName
-> Validator
CONST
(TypeSystemContext (TypeEntity ON_TYPE))
(TypeDefinition ANY CONST)
forall (s :: Stage) ctx.
TypeName -> Validator s ctx (TypeDefinition ANY s)
selectType (TypeName
-> Validator
CONST
(TypeSystemContext (TypeEntity ON_TYPE))
(TypeDefinition ANY CONST))
-> (TypeDefinition ANY CONST
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ())
-> TypeName
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> TypeDefinition ANY CONST
-> SchemaValidator
(TypeEntity ON_TYPE) (TypeName, FieldsDefinition OUT CONST)
forall ctx.
TypeDefinition ANY CONST
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
constraintInterface (TypeDefinition ANY CONST
-> SchemaValidator
(TypeEntity ON_TYPE) (TypeName, FieldsDefinition OUT CONST))
-> ((TypeName, FieldsDefinition OUT CONST)
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ())
-> TypeDefinition ANY CONST
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (TypeName, FieldsDefinition OUT CONST)
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ()
hasCompatibleFields) [TypeName]
interfaceNames
Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) [()]
-> [TypeName] -> SchemaValidator (TypeEntity ON_TYPE) [TypeName]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [TypeName]
interfaceNames
where
hasCompatibleFields :: (TypeName, FieldsDefinition OUT CONST) -> SchemaValidator (TypeEntity ON_TYPE) ()
hasCompatibleFields :: (TypeName, FieldsDefinition OUT CONST)
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ()
hasCompatibleFields (TypeName
typeName, FieldsDefinition OUT CONST
fields) = TypeName
-> SchemaValidator (TypeEntity 'ON_INTERFACE) ()
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ()
forall v.
TypeName
-> SchemaValidator (TypeEntity 'ON_INTERFACE) v
-> SchemaValidator (TypeEntity ON_TYPE) v
inInterface TypeName
typeName (SchemaValidator (TypeEntity 'ON_INTERFACE) ()
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ())
-> SchemaValidator (TypeEntity 'ON_INTERFACE) ()
-> Validator CONST (TypeSystemContext (TypeEntity ON_TYPE)) ()
forall a b. (a -> b) -> a -> b
$ FieldsDefinition OUT CONST
-> FieldsDefinition OUT CONST
-> SchemaValidator
(Context (FieldsDefinition OUT CONST) 'ON_INTERFACE) ()
forall a.
StructuralCompatibility a =>
a -> a -> SchemaValidator (Context a 'ON_INTERFACE) ()
isCompatibleTo FieldsDefinition OUT CONST
objectFields FieldsDefinition OUT CONST
fields
class StructuralCompatibility a where
type Context a :: PLACE -> Type
type Context a = Field
isCompatibleTo :: a -> a -> SchemaValidator ((Context a) ON_INTERFACE) ()
isCompatibleBy :: (t -> a) -> t -> t -> SchemaValidator ((Context a) ON_INTERFACE) ()
isCompatibleBy t -> a
f t
a t
b = t -> a
f t
a a -> a -> SchemaValidator (Context a 'ON_INTERFACE) ()
forall a.
StructuralCompatibility a =>
a -> a -> SchemaValidator (Context a 'ON_INTERFACE) ()
`isCompatibleTo` t -> a
f t
b
instance StructuralCompatibility (FieldsDefinition OUT s) where
type Context (FieldsDefinition OUT s) = TypeEntity
isCompatibleTo :: FieldsDefinition OUT s
-> FieldsDefinition OUT s
-> SchemaValidator
(Context (FieldsDefinition OUT s) 'ON_INTERFACE) ()
isCompatibleTo FieldsDefinition OUT s
objFields = (FieldDefinition OUT s
-> SchemaValidator (TypeEntity 'ON_INTERFACE) ())
-> FieldsDefinition OUT s
-> SchemaValidator (TypeEntity 'ON_INTERFACE) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FieldDefinition OUT s
-> SchemaValidator (TypeEntity 'ON_INTERFACE) ()
checkInterfaceField
where
checkInterfaceField :: FieldDefinition OUT s
-> SchemaValidator (TypeEntity 'ON_INTERFACE) ()
checkInterfaceField interfaceField :: FieldDefinition OUT s
interfaceField@FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName} =
FieldName
-> SchemaValidator (Field 'ON_INTERFACE) ()
-> SchemaValidator (TypeEntity 'ON_INTERFACE) ()
forall (p :: PLACE) v.
FieldName
-> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v
inField FieldName
fieldName (SchemaValidator (Field 'ON_INTERFACE) ()
-> SchemaValidator (TypeEntity 'ON_INTERFACE) ())
-> SchemaValidator (Field 'ON_INTERFACE) ()
-> SchemaValidator (TypeEntity 'ON_INTERFACE) ()
forall a b. (a -> b) -> a -> b
$ SchemaValidator (Field 'ON_INTERFACE) ()
-> (FieldDefinition OUT s
-> SchemaValidator (Field 'ON_INTERFACE) ())
-> FieldName
-> FieldsDefinition OUT s
-> SchemaValidator (Field 'ON_INTERFACE) ()
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr SchemaValidator (Field 'ON_INTERFACE) ()
forall a. SchemaValidator (Field 'ON_INTERFACE) a
err (FieldDefinition OUT s
-> FieldDefinition OUT s
-> SchemaValidator
(Context (FieldDefinition OUT s) 'ON_INTERFACE) ()
forall a.
StructuralCompatibility a =>
a -> a -> SchemaValidator (Context a 'ON_INTERFACE) ()
`isCompatibleTo` FieldDefinition OUT s
interfaceField) FieldName
fieldName FieldsDefinition OUT s
objFields
where
err :: SchemaValidator (Field 'ON_INTERFACE) a
err = ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) a
forall a.
ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) a
failImplements ImplementsError
Missing
instance StructuralCompatibility (FieldDefinition OUT s) where
FieldDefinition OUT s
f1 isCompatibleTo :: FieldDefinition OUT s
-> FieldDefinition OUT s
-> SchemaValidator
(Context (FieldDefinition OUT s) 'ON_INTERFACE) ()
`isCompatibleTo` FieldDefinition OUT s
f2 =
(FieldDefinition OUT s -> TypeRef)
-> FieldDefinition OUT s
-> FieldDefinition OUT s
-> SchemaValidator (Context TypeRef 'ON_INTERFACE) ()
forall a t.
StructuralCompatibility a =>
(t -> a) -> t -> t -> SchemaValidator (Context a 'ON_INTERFACE) ()
isCompatibleBy FieldDefinition OUT s -> TypeRef
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType FieldDefinition OUT s
f1 FieldDefinition OUT s
f2
SchemaValidator (Field 'ON_INTERFACE) ()
-> SchemaValidator (Field 'ON_INTERFACE) ()
-> SchemaValidator (Field 'ON_INTERFACE) ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (FieldDefinition OUT s -> ArgumentsDefinition s)
-> FieldDefinition OUT s
-> FieldDefinition OUT s
-> SchemaValidator
(Context (ArgumentsDefinition s) 'ON_INTERFACE) ()
forall a t.
StructuralCompatibility a =>
(t -> a) -> t -> t -> SchemaValidator (Context a 'ON_INTERFACE) ()
isCompatibleBy (Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
forall (s :: Stage).
Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
fieldArgs (Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s)
-> (FieldDefinition OUT s -> Maybe (FieldContent TRUE OUT s))
-> FieldDefinition OUT s
-> ArgumentsDefinition s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDefinition OUT s -> Maybe (FieldContent TRUE OUT s)
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent) FieldDefinition OUT s
f1 FieldDefinition OUT s
f2
fieldArgs :: Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
fieldArgs :: Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
fieldArgs (Just (FieldArgs ArgumentsDefinition s
args)) = ArgumentsDefinition s
args
fieldArgs Maybe (FieldContent TRUE OUT s)
_ = ArgumentsDefinition s
forall coll. Empty coll => coll
empty
instance StructuralCompatibility (ArgumentsDefinition s) where
ArgumentsDefinition s
subArguments isCompatibleTo :: ArgumentsDefinition s
-> ArgumentsDefinition s
-> SchemaValidator
(Context (ArgumentsDefinition s) 'ON_INTERFACE) ()
`isCompatibleTo` ArgumentsDefinition s
arguments = (ArgumentDefinition s -> SchemaValidator (Field 'ON_INTERFACE) ())
-> ArgumentsDefinition s
-> SchemaValidator (Field 'ON_INTERFACE) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ArgumentDefinition s -> SchemaValidator (Field 'ON_INTERFACE) ()
hasCompatibleSubArgument ArgumentsDefinition s
arguments
where
hasCompatibleSubArgument :: ArgumentDefinition s -> SchemaValidator (Field 'ON_INTERFACE) ()
hasCompatibleSubArgument ArgumentDefinition s
argument =
FieldName
-> SchemaValidator (Field 'ON_INTERFACE) ()
-> SchemaValidator (Field 'ON_INTERFACE) ()
forall (p :: PLACE) v.
FieldName
-> SchemaValidator (Field p) v -> SchemaValidator (Field p) v
inArgument (ArgumentDefinition s -> FieldName
forall k a. KeyOf k a => a -> k
keyOf ArgumentDefinition s
argument) (SchemaValidator (Field 'ON_INTERFACE) ()
-> SchemaValidator (Field 'ON_INTERFACE) ())
-> SchemaValidator (Field 'ON_INTERFACE) ()
-> SchemaValidator (Field 'ON_INTERFACE) ()
forall a b. (a -> b) -> a -> b
$
SchemaValidator (Field 'ON_INTERFACE) ()
-> (ArgumentDefinition s
-> SchemaValidator (Field 'ON_INTERFACE) ())
-> FieldName
-> ArgumentsDefinition s
-> SchemaValidator (Field 'ON_INTERFACE) ()
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) ()
forall a.
ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) a
failImplements ImplementsError
Missing) (ArgumentDefinition s
-> ArgumentDefinition s
-> SchemaValidator
(Context (ArgumentDefinition s) 'ON_INTERFACE) ()
forall a.
StructuralCompatibility a =>
a -> a -> SchemaValidator (Context a 'ON_INTERFACE) ()
`isCompatibleTo` ArgumentDefinition s
argument) (ArgumentDefinition s -> FieldName
forall k a. KeyOf k a => a -> k
keyOf ArgumentDefinition s
argument) ArgumentsDefinition s
subArguments
instance StructuralCompatibility (ArgumentDefinition s) where
isCompatibleTo :: ArgumentDefinition s
-> ArgumentDefinition s
-> SchemaValidator
(Context (ArgumentDefinition s) 'ON_INTERFACE) ()
isCompatibleTo = (ArgumentDefinition s -> TypeRef)
-> ArgumentDefinition s
-> ArgumentDefinition s
-> SchemaValidator (Context TypeRef 'ON_INTERFACE) ()
forall a t.
StructuralCompatibility a =>
(t -> a) -> t -> t -> SchemaValidator (Context a 'ON_INTERFACE) ()
isCompatibleBy (FieldDefinition IN s -> TypeRef
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType (FieldDefinition IN s -> TypeRef)
-> (ArgumentDefinition s -> FieldDefinition IN s)
-> ArgumentDefinition s
-> TypeRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgumentDefinition s -> FieldDefinition IN s
forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument)
instance StructuralCompatibility TypeRef where
TypeRef
t1 isCompatibleTo :: TypeRef
-> TypeRef -> SchemaValidator (Context TypeRef 'ON_INTERFACE) ()
`isCompatibleTo` TypeRef
t2
| TypeRef
t1 TypeRef -> TypeRef -> Bool
forall t. Subtyping t => t -> t -> Bool
`isSubtype` TypeRef
t2 = () -> SchemaValidator (Field 'ON_INTERFACE) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) ()
forall a.
ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) a
failImplements UnexpectedType :: TypeRef -> TypeRef -> ImplementsError
UnexpectedType {expectedType :: TypeRef
expectedType = TypeRef
t2, foundType :: TypeRef
foundType = TypeRef
t1}
failImplements ::
ImplementsError ->
SchemaValidator (Field ON_INTERFACE) a
failImplements :: ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) a
failImplements ImplementsError
err = do
Field 'ON_INTERFACE
x <- (ValidatorContext CONST (TypeSystemContext (Field 'ON_INTERFACE))
-> Field 'ON_INTERFACE)
-> Validator
CONST
(TypeSystemContext (Field 'ON_INTERFACE))
(Field 'ON_INTERFACE)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TypeSystemContext (Field 'ON_INTERFACE) -> Field 'ON_INTERFACE
forall c. TypeSystemContext c -> c
local (TypeSystemContext (Field 'ON_INTERFACE) -> Field 'ON_INTERFACE)
-> (ValidatorContext
CONST (TypeSystemContext (Field 'ON_INTERFACE))
-> TypeSystemContext (Field 'ON_INTERFACE))
-> ValidatorContext CONST (TypeSystemContext (Field 'ON_INTERFACE))
-> Field 'ON_INTERFACE
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext CONST (TypeSystemContext (Field 'ON_INTERFACE))
-> TypeSystemContext (Field 'ON_INTERFACE)
forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext)
GQLError -> SchemaValidator (Field 'ON_INTERFACE) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> SchemaValidator (Field 'ON_INTERFACE) a)
-> GQLError -> SchemaValidator (Field 'ON_INTERFACE) a
forall a b. (a -> b) -> a -> b
$ Field 'ON_INTERFACE -> ImplementsError -> GQLError
partialImplements Field 'ON_INTERFACE
x ImplementsError
err