{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
module Data.Morpheus.Validation.Document.Validation
( validatePartialDocument,
validateSchema,
)
where
import Data.Functor (($>))
import Data.Morpheus.Error.Document.Interface
( ImplementsError (..),
partialImplements,
unknownInterface,
)
import Data.Morpheus.Internal.Utils
( Selectable (..),
elems,
)
import Data.Morpheus.Types.Internal.AST
( ANY,
FieldDefinition (..),
FieldName (..),
FieldsDefinition,
OUT,
Schema,
TypeContent (..),
TypeDefinition (..),
TypeName,
TypeRef (..),
isWeaker,
lookupWith,
)
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
Failure (..),
)
validateSchema :: Schema -> Eventless Schema
validateSchema schema = validatePartialDocument (elems schema) $> schema
validatePartialDocument :: [TypeDefinition ANY] -> Eventless [TypeDefinition ANY]
validatePartialDocument lib = traverse validateType lib
where
validateType :: TypeDefinition ANY -> Eventless (TypeDefinition ANY)
validateType dt@TypeDefinition {typeName, typeContent = DataObject {objectImplements, objectFields}} = do
interface <- traverse getInterfaceByKey objectImplements
case concatMap (mustBeSubset objectFields) interface of
[] -> pure dt
errors -> failure $ partialImplements typeName errors
validateType x = pure x
mustBeSubset ::
FieldsDefinition OUT -> (TypeName, FieldsDefinition OUT) -> [(TypeName, FieldName, ImplementsError)]
mustBeSubset objFields (typeName, fields) = concatMap checkField (elems fields)
where
checkField :: FieldDefinition OUT -> [(TypeName, FieldName, ImplementsError)]
checkField FieldDefinition {fieldName, fieldType = interfaceT@TypeRef {typeConName = interfaceTypeName, typeWrappers = interfaceWrappers}} =
selectOr err checkTypeEq fieldName objFields
where
err = [(typeName, fieldName, UndefinedField)]
checkTypeEq FieldDefinition {fieldType = objT@TypeRef {typeConName, typeWrappers}}
| typeConName == interfaceTypeName && not (isWeaker typeWrappers interfaceWrappers) =
[]
| otherwise =
[ ( typeName,
fieldName,
UnexpectedType
{ expectedType = interfaceT,
foundType = objT
}
)
]
getInterfaceByKey :: TypeName -> Eventless (TypeName, FieldsDefinition OUT)
getInterfaceByKey interfaceName = case lookupWith typeName interfaceName lib of
Just TypeDefinition {typeContent = DataInterface {interfaceFields}} -> pure (interfaceName, interfaceFields)
_ -> failure $ unknownInterface interfaceName