{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Types.Internal.Validation.SchemaValidator ( SchemaValidator, TypeSystemContext (..), constraintInterface, renderField, withLocalContext, runSchemaValidator, inInterface, inType, inField, inArgument, ON_INTERFACE, ON_TYPE, TypeEntity (..), Field (..), InterfaceName (..), PLACE, ) where import Control.Monad.Except (throwError) import Data.Morpheus.Ext.Result (GQLResult) import Data.Morpheus.Types.Internal.AST ( ANY, CONST, FieldName, FieldsDefinition, Name, OUT, PropName (PropName), TypeContent (..), TypeDefinition (..), TypeName, mkBaseType, msg, unpackName, ) import Data.Morpheus.Types.Internal.AST.Type (TypeKind (KindObject)) import Data.Morpheus.Types.Internal.AST.TypeSystem (Schema) import Data.Morpheus.Types.Internal.Config (Config) import Data.Morpheus.Types.Internal.Validation (Scope (..), ScopeKind (TYPE), runValidator) import Data.Morpheus.Types.Internal.Validation.Validator ( Validator (..), renderField, withContext, withScope, ) import Relude hiding (local) inInterface :: TypeName -> SchemaValidator (TypeEntity 'ON_INTERFACE) v -> SchemaValidator (TypeEntity 'ON_TYPE) v inInterface :: forall v. TypeName -> SchemaValidator (TypeEntity 'ON_INTERFACE) v -> SchemaValidator (TypeEntity 'ON_TYPE) v inInterface TypeName name = forall (t :: NAME) a v. Name t -> SchemaValidator a v -> SchemaValidator a v pushPath TypeName name forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (\TypeEntity 'ON_TYPE t -> TypeEntity 'ON_TYPE t {$sel:interfaceName:TypeEntity :: InterfaceName 'ON_INTERFACE interfaceName = TypeName -> InterfaceName 'ON_INTERFACE OnInterface TypeName name}) inType :: TypeName -> SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator () v inType :: forall v. TypeName -> SchemaValidator (TypeEntity 'ON_TYPE) v -> SchemaValidator () v inType TypeName name = forall (t :: NAME) a v. Name t -> SchemaValidator a v -> SchemaValidator a v pushPath TypeName name forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (forall a b. a -> b -> a const (forall (p :: PLACE). InterfaceName p -> TypeName -> TypeEntity p TypeEntity InterfaceName 'ON_TYPE OnType TypeName name)) inField :: FieldName -> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v inField :: forall (p :: PLACE) v. FieldName -> SchemaValidator (Field p) v -> SchemaValidator (TypeEntity p) v inField FieldName fieldName = forall (t :: NAME) a v. Name t -> SchemaValidator a v -> SchemaValidator a v pushPath FieldName fieldName forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (forall (p :: PLACE). FieldName -> Maybe FieldName -> TypeEntity p -> Field p Field FieldName fieldName forall a. Maybe a Nothing) inArgument :: FieldName -> SchemaValidator (Field p) v -> SchemaValidator (Field p) v inArgument :: forall (p :: PLACE) v. FieldName -> SchemaValidator (Field p) v -> SchemaValidator (Field p) v inArgument FieldName name = forall (t :: NAME) a v. Name t -> SchemaValidator a v -> SchemaValidator a v pushPath FieldName name forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext (\Field p field -> Field p field {$sel:fieldArgument:Field :: Maybe FieldName fieldArgument = forall a. a -> Maybe a Just FieldName name}) data PLACE = ON_INTERFACE | ON_TYPE type ON_INTERFACE = 'ON_INTERFACE type ON_TYPE = 'ON_TYPE data InterfaceName (p :: PLACE) where OnInterface :: TypeName -> InterfaceName 'ON_INTERFACE OnType :: InterfaceName 'ON_TYPE data TypeEntity (p :: PLACE) = TypeEntity { forall (p :: PLACE). TypeEntity p -> InterfaceName p interfaceName :: InterfaceName p, forall (p :: PLACE). TypeEntity p -> TypeName typeName :: TypeName } data Field p = Field { forall (p :: PLACE). Field p -> FieldName fieldName :: FieldName, forall (p :: PLACE). Field p -> Maybe FieldName fieldArgument :: Maybe FieldName, forall (p :: PLACE). Field p -> TypeEntity p fieldOf :: TypeEntity p } initialScope :: Scope initialScope :: Scope initialScope = Scope { position :: Maybe Position position = forall a. Maybe a Nothing, currentTypeName :: TypeName currentTypeName = TypeName "Root", currentTypeKind :: TypeKind currentTypeKind = Maybe OperationType -> TypeKind KindObject forall a. Maybe a Nothing, currentTypeWrappers :: TypeWrapper currentTypeWrappers = TypeWrapper mkBaseType, kind :: ScopeKind kind = ScopeKind TYPE, fieldName :: FieldName fieldName = FieldName "Root", path :: [PropName] path = [] } newtype TypeSystemContext c = TypeSystemContext {forall c. TypeSystemContext c -> c local :: c} deriving (Int -> TypeSystemContext c -> ShowS 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) pushPath :: Name t -> SchemaValidator a v -> SchemaValidator a v pushPath :: forall (t :: NAME) a v. Name t -> SchemaValidator a v -> SchemaValidator a v pushPath Name t name = forall (s :: Stage) c (m :: * -> *) b. MonadReader (ValidatorContext s c) m => (Scope -> Scope) -> m b -> m b withScope (\Scope x -> Scope x {path :: [PropName] path = Scope -> [PropName] path Scope x forall a. Semigroup a => a -> a -> a <> [Text -> PropName PropName (forall a (t :: NAME). NamePacking a => Name t -> a unpackName Name t name)]}) withLocalContext :: (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext :: forall a b v. (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext = forall c' c (s :: Stage) a. (c' -> c) -> Validator s c a -> Validator s c' a withContext forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> TypeSystemContext a -> TypeSystemContext b updateLocal updateLocal :: (a -> b) -> TypeSystemContext a -> TypeSystemContext b updateLocal :: forall a b. (a -> b) -> TypeSystemContext a -> TypeSystemContext b updateLocal a -> b f TypeSystemContext a ctx = TypeSystemContext a ctx {$sel:local:TypeSystemContext :: b local = a -> b f (forall c. TypeSystemContext c -> c local TypeSystemContext a ctx)} type SchemaValidator c = Validator CONST (TypeSystemContext c) runSchemaValidator :: Validator s (TypeSystemContext ()) a -> Config -> Schema s -> GQLResult a runSchemaValidator :: forall (s :: Stage) a. Validator s (TypeSystemContext ()) a -> Config -> Schema s -> GQLResult a runSchemaValidator Validator s (TypeSystemContext ()) a value Config config Schema s sysSchema = forall (s :: Stage) ctx a. Validator s ctx a -> Config -> Schema s -> Scope -> ctx -> GQLResult a runValidator Validator s (TypeSystemContext ()) a value Config config Schema s sysSchema Scope initialScope TypeSystemContext { $sel:local:TypeSystemContext :: () local = () } constraintInterface :: TypeDefinition ANY CONST -> SchemaValidator ctx (TypeName, FieldsDefinition OUT CONST) constraintInterface :: forall ctx. 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 } = 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} = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ GQLError "type " forall a. Semigroup a => a -> a -> a <> forall a. Msg a => a -> GQLError msg TypeName typeName forall a. Semigroup a => a -> a -> a <> GQLError " must be an interface"