{-# 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

  -- Object (which implements interface) -> Interface -> Validation
  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