{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Error.Document.Interface
  ( unknownInterface,
    PartialImplements (..),
    ImplementsError (..),
    Place (..),
  )
where

import Data.Maybe (Maybe (..))
import Data.Morpheus.Types.Internal.AST.Base
  ( FieldName (..),
    TypeName (..),
    TypeRef,
    ValidationError,
    msgValidation,
  )
import Data.Morpheus.Types.Internal.Validation.SchemaValidator
  ( Field (..),
    Interface (..),
    renderField,
  )
import Data.Semigroup ((<>))

unknownInterface :: TypeName -> ValidationError
unknownInterface :: TypeName -> ValidationError
unknownInterface TypeName
name = ValidationError
"Unknown Interface " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation TypeName
name ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"."

data ImplementsError
  = UnexpectedType
      { ImplementsError -> TypeRef
expectedType :: TypeRef,
        ImplementsError -> TypeRef
foundType :: TypeRef
      }
  | Missing

data Place = Place
  { Place -> TypeName
fieldname :: TypeName,
    Place -> FieldName
typename :: FieldName,
    Place -> Maybe (FieldName, TypeName)
fieldArg :: Maybe (FieldName, TypeName)
  }

class PartialImplements ctx where
  partialImplements :: ctx -> ImplementsError -> ValidationError

instance PartialImplements (Interface, FieldName) where
  partialImplements :: (Interface, FieldName) -> ImplementsError -> ValidationError
partialImplements (Interface TypeName
interfaceName TypeName
typename, FieldName
fieldname) ImplementsError
errorType =
    ValidationError
"Interface field "
      ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName -> Maybe FieldName -> ValidationError
renderField TypeName
interfaceName FieldName
fieldname Maybe FieldName
forall a. Maybe a
Nothing
      ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ImplementsError -> ValidationError
detailedMessage ImplementsError
errorType
    where
      detailedMessage :: ImplementsError -> ValidationError
detailedMessage UnexpectedType {TypeRef
expectedType :: TypeRef
expectedType :: ImplementsError -> TypeRef
expectedType, TypeRef
foundType :: TypeRef
foundType :: ImplementsError -> TypeRef
foundType} =
        ValidationError
" expects type "
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeRef -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation TypeRef
expectedType
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" but "
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName -> Maybe FieldName -> ValidationError
renderField TypeName
typename FieldName
fieldname Maybe FieldName
forall a. Maybe a
Nothing
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" is type "
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeRef -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation TypeRef
foundType
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"."
      detailedMessage ImplementsError
Missing =
        ValidationError
" expected but "
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation TypeName
typename
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" does not provide it."

-- Interface field TestInterface.name expected but User does not provide it.
-- Interface field TestInterface.name expects type String! but User.name is type Int!.

instance PartialImplements (Interface, Field) where
  partialImplements :: (Interface, Field) -> ImplementsError -> ValidationError
partialImplements (Interface TypeName
interfaceName TypeName
typename, Field FieldName
fieldname FieldName
argName) ImplementsError
errorType =
    ValidationError
"Interface field argument "
      ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName -> Maybe FieldName -> ValidationError
renderField TypeName
interfaceName FieldName
fieldname (FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just FieldName
argName)
      ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ImplementsError -> ValidationError
detailedMessage ImplementsError
errorType
    where
      detailedMessage :: ImplementsError -> ValidationError
detailedMessage UnexpectedType {TypeRef
expectedType :: TypeRef
expectedType :: ImplementsError -> TypeRef
expectedType, TypeRef
foundType :: TypeRef
foundType :: ImplementsError -> TypeRef
foundType} =
        ValidationError
" expects type"
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeRef -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation TypeRef
expectedType
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" but "
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName -> Maybe FieldName -> ValidationError
renderField TypeName
typename FieldName
fieldname (FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just FieldName
argName)
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" is type "
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeRef -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation TypeRef
foundType
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
"."
      detailedMessage ImplementsError
Missing =
        ValidationError
" expected but "
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName -> Maybe FieldName -> ValidationError
renderField TypeName
typename FieldName
fieldname Maybe FieldName
forall a. Maybe a
Nothing
          ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
" does not provide it."

-- Interface field argument TestInterface.name(id:) expected but User.name does not provide it.
-- Interface field argument TestInterface.name(id:) expects type ID but User.name(id:) is type String.