{-# 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 =
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (s :: Stage) ctx.
TypeName -> Validator s ctx (TypeDefinition ANY s)
selectType forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall ctx.
TypeDefinition ANY CONST
-> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST)
constraintInterface 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
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) = forall v.
TypeName
-> SchemaValidator (TypeEntity 'ON_INTERFACE) v
-> SchemaValidator (TypeEntity ON_TYPE) v
inInterface TypeName
typeName forall a b. (a -> b) -> a -> b
$ 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 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 = 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} =
forall (p :: PLACE) v.
FieldName
-> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v
inField FieldName
fieldName forall a b. (a -> b) -> a -> b
$ forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr forall {a}. SchemaValidator (Field 'ON_INTERFACE) a
err (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 = 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 =
forall a t.
StructuralCompatibility a =>
(t -> a) -> t -> t -> SchemaValidator (Context a 'ON_INTERFACE) ()
isCompatibleBy forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType FieldDefinition OUT s
f1 FieldDefinition OUT s
f2
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a t.
StructuralCompatibility a =>
(t -> a) -> t -> t -> SchemaValidator (Context a 'ON_INTERFACE) ()
isCompatibleBy (forall (s :: Stage).
Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
fieldArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (s :: Stage).
Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
fieldArgs (Just (FieldArgs ArgumentsDefinition s
args)) = ArgumentsDefinition s
args
fieldArgs Maybe (FieldContent TRUE OUT 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ArgumentDefinition s
-> Validator CONST (TypeSystemContext (Field 'ON_INTERFACE)) ()
hasCompatibleSubArgument ArgumentsDefinition s
arguments
where
hasCompatibleSubArgument :: ArgumentDefinition s
-> Validator CONST (TypeSystemContext (Field 'ON_INTERFACE)) ()
hasCompatibleSubArgument ArgumentDefinition s
argument =
forall (p :: PLACE) v.
FieldName
-> SchemaValidator (Field p) v -> SchemaValidator (Field p) v
inArgument (forall k a. KeyOf k a => a -> k
keyOf ArgumentDefinition s
argument) forall a b. (a -> b) -> a -> b
$
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall a.
ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) a
failImplements ImplementsError
Missing) (forall a.
StructuralCompatibility a =>
a -> a -> SchemaValidator (Context a 'ON_INTERFACE) ()
`isCompatibleTo` ArgumentDefinition s
argument) (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 = forall a t.
StructuralCompatibility a =>
(t -> a) -> t -> t -> SchemaValidator (Context a 'ON_INTERFACE) ()
isCompatibleBy (forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall t. Subtyping t => t -> t -> Bool
`isSubtype` TypeRef
t2 = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| Bool
otherwise = forall a.
ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) a
failImplements UnexpectedType {expectedType :: TypeRef
expectedType = TypeRef
t2, foundType :: TypeRef
foundType = TypeRef
t1}
failImplements ::
ImplementsError ->
SchemaValidator (Field ON_INTERFACE) a
failImplements :: forall a.
ImplementsError -> SchemaValidator (Field 'ON_INTERFACE) a
failImplements ImplementsError
err = do
Field 'ON_INTERFACE
x <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall c. TypeSystemContext c -> c
local forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Field 'ON_INTERFACE -> ImplementsError -> GQLError
partialImplements Field 'ON_INTERFACE
x ImplementsError
err