{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Types.Internal.Validation.SchemaValidator ( SchemaValidator, TypeSystemContext (..), constraintInterface, inField, inType, inArgument, inInterface, Field (..), Interface (..), renderField, ) where import Data.Morpheus.Internal.Utils ( Failure (..), ) import Data.Morpheus.Types.Internal.AST ( ANY, CONST, FieldName, FieldsDefinition, OUT, TypeContent (..), TypeDefinition (..), TypeName, ValidationError, msgValidation, ) import Data.Morpheus.Types.Internal.Validation.Validator ( Validator (..), renderField, withContext, ) import Relude hiding (local) newtype TypeSystemContext c = TypeSystemContext {TypeSystemContext c -> c local :: c} deriving (Int -> TypeSystemContext c -> ShowS [TypeSystemContext c] -> ShowS TypeSystemContext c -> String (Int -> TypeSystemContext c -> ShowS) -> (TypeSystemContext c -> String) -> ([TypeSystemContext c] -> ShowS) -> Show (TypeSystemContext c) forall c. Show c => Int -> TypeSystemContext c -> ShowS forall c. Show c => [TypeSystemContext c] -> ShowS forall c. Show c => TypeSystemContext c -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TypeSystemContext c] -> ShowS $cshowList :: forall c. Show c => [TypeSystemContext c] -> ShowS show :: TypeSystemContext c -> String $cshow :: forall c. Show c => TypeSystemContext c -> String showsPrec :: Int -> TypeSystemContext c -> ShowS $cshowsPrec :: forall c. Show c => Int -> TypeSystemContext c -> ShowS Show) inType :: TypeName -> SchemaValidator TypeName v -> SchemaValidator () v inType :: TypeName -> SchemaValidator TypeName v -> SchemaValidator () v inType TypeName name = (() -> TypeName) -> SchemaValidator TypeName v -> SchemaValidator () v forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (TypeName -> () -> TypeName forall a b. a -> b -> a const TypeName name) inInterface :: TypeName -> SchemaValidator Interface v -> SchemaValidator TypeName v inInterface :: TypeName -> SchemaValidator Interface v -> SchemaValidator TypeName v inInterface TypeName interfaceName = (TypeName -> Interface) -> SchemaValidator Interface v -> SchemaValidator TypeName v forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (TypeName -> TypeName -> Interface Interface TypeName interfaceName) inField :: FieldName -> SchemaValidator (t, FieldName) v -> SchemaValidator t v inField :: FieldName -> SchemaValidator (t, FieldName) v -> SchemaValidator t v inField FieldName fname = (t -> (t, FieldName)) -> SchemaValidator (t, FieldName) v -> SchemaValidator t v forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (,FieldName fname) inArgument :: FieldName -> SchemaValidator (t, Field) v -> SchemaValidator (t, FieldName) v inArgument :: FieldName -> SchemaValidator (t, Field) v -> SchemaValidator (t, FieldName) v inArgument FieldName aname = ((t, FieldName) -> (t, Field)) -> SchemaValidator (t, Field) v -> SchemaValidator (t, FieldName) v forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (\(t t1, FieldName f1) -> (t t1, FieldName -> FieldName -> Field Field FieldName f1 FieldName aname)) data Interface = Interface { Interface -> TypeName interfaceName :: TypeName, Interface -> TypeName typeName :: TypeName } data Field = Field { Field -> FieldName fieldName :: FieldName, Field -> FieldName fieldArgument :: FieldName } withLocalContext :: (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext :: (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext = (TypeSystemContext a -> TypeSystemContext b) -> SchemaValidator b v -> SchemaValidator a v forall c' c (s :: Stage) a. (c' -> c) -> Validator s c a -> Validator s c' a withContext ((TypeSystemContext a -> TypeSystemContext b) -> SchemaValidator b v -> SchemaValidator a v) -> ((a -> b) -> TypeSystemContext a -> TypeSystemContext b) -> (a -> b) -> SchemaValidator b v -> SchemaValidator a v forall b c a. (b -> c) -> (a -> b) -> a -> c . (a -> b) -> TypeSystemContext a -> TypeSystemContext b forall a b. (a -> b) -> TypeSystemContext a -> TypeSystemContext b updateLocal updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b updateLocal a -> b f TypeSystemContext a ctx = TypeSystemContext a ctx {$sel:local:TypeSystemContext :: b local = a -> b f (TypeSystemContext a -> a forall c. TypeSystemContext c -> c local TypeSystemContext a ctx)} type SchemaValidator c = Validator CONST (TypeSystemContext c) constraintInterface :: TypeDefinition ANY CONST -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) constraintInterface :: TypeDefinition ANY CONST -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) constraintInterface TypeDefinition { TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName :: TypeName typeName, typeContent :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeContent TRUE a s typeContent = DataInterface FieldsDefinition OUT CONST fields } = (TypeName, FieldsDefinition OUT CONST) -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) forall (f :: * -> *) a. Applicative f => a -> f a pure (TypeName typeName, FieldsDefinition OUT CONST fields) constraintInterface TypeDefinition {TypeName typeName :: TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName} = [ValidationError] -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) forall error (f :: * -> *) v. Failure error f => error -> f v failure [ValidationError "type " 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 " must be an interface" :: ValidationError]