morpheus-graphql-core-0.28.2: src/Data/Morpheus/Validation/Document/Interface.hs

{-# 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 interfaceNames objectFields =
  traverse (selectType >=> constraintInterface >=> hasCompatibleFields) interfaceNames
    $> interfaceNames
  where
    hasCompatibleFields :: (TypeName, FieldsDefinition OUT CONST) -> SchemaValidator (TypeEntity ON_TYPE) ()
    hasCompatibleFields (typeName, fields) = inInterface typeName $ isCompatibleTo objectFields 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 f a b = f a `isCompatibleTo` f b

instance StructuralCompatibility (FieldsDefinition OUT s) where
  type Context (FieldsDefinition OUT s) = TypeEntity
  isCompatibleTo objFields = traverse_ checkInterfaceField
    where
      checkInterfaceField interfaceField@FieldDefinition {fieldName} =
        inField fieldName $ selectOr err (`isCompatibleTo` interfaceField) fieldName objFields
        where
          err = failImplements Missing

instance StructuralCompatibility (FieldDefinition OUT s) where
  f1 `isCompatibleTo` f2 =
    isCompatibleBy fieldType f1 f2
      *> isCompatibleBy (fieldArgs . fieldContent) f1 f2

fieldArgs :: Maybe (FieldContent TRUE OUT s) -> ArgumentsDefinition s
fieldArgs (Just (FieldArgs args)) = args
fieldArgs _ = empty

instance StructuralCompatibility (ArgumentsDefinition s) where
  subArguments `isCompatibleTo` arguments = traverse_ hasCompatibleSubArgument arguments
    where
      hasCompatibleSubArgument argument =
        inArgument (keyOf argument)
          $ selectOr (failImplements Missing) (`isCompatibleTo` argument) (keyOf argument) subArguments

instance StructuralCompatibility (ArgumentDefinition s) where
  isCompatibleTo = isCompatibleBy (fieldType . argument)

instance StructuralCompatibility TypeRef where
  t1 `isCompatibleTo` t2
    | t1 `isSubtype` t2 = pure ()
    | otherwise = failImplements UnexpectedType {expectedType = t2, foundType = t1}

failImplements ::
  ImplementsError ->
  SchemaValidator (Field ON_INTERFACE) a
failImplements err = do
  x <- asks (local . localContext)
  throwError $ partialImplements x err