{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Types.Internal.Validation.Internal ( askType, askTypeMember, getOperationType, askInterfaceTypes, ) where import Control.Monad.Except (MonadError (throwError)) import Data.Morpheus.Internal.Utils ( fromElems, ) import Data.Morpheus.Types.Internal.AST ( ANY, FromCategory, GQLError, IMPLEMENTABLE, IN, OBJECT, OUT, Operation (..), OrdMap, TRUE, ToOBJECT, Token, TypeName, TypeRef, UnionMember (..), VALID, fromAny, fromCategory, getOperationDataType, internal, msg, typeConName, ) import Data.Morpheus.Types.Internal.AST.TypeSystem import Data.Morpheus.Types.Internal.Validation.Validator ( SelectionValidator, ValidatorContext (schema), ) import Relude askType :: Constraints m c cat s ctx => Typed cat s TypeRef -> m (TypeDefinition cat s) askType :: Typed cat s TypeRef -> m (TypeDefinition cat s) askType = (TypeRef -> m (TypeDefinition cat s)) -> Typed cat s TypeRef -> m (TypeDefinition cat s) forall a b (c :: TypeCategory) (s :: Stage). (a -> b) -> Typed c s a -> b untyped (TypeName -> m (TypeDefinition cat s) forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx. Constraints m c cat s ctx => TypeName -> m (TypeDefinition cat s) __askType (TypeName -> m (TypeDefinition cat s)) -> (TypeRef -> TypeName) -> TypeRef -> m (TypeDefinition cat s) forall b c a. (b -> c) -> (a -> b) -> a -> c . TypeRef -> TypeName typeConName) askType2 :: Constraints m c cat s ctx => Typed cat s TypeName -> m (TypeDefinition cat s) askType2 :: Typed cat s TypeName -> m (TypeDefinition cat s) askType2 = (TypeName -> m (TypeDefinition cat s)) -> Typed cat s TypeName -> m (TypeDefinition cat s) forall a b (c :: TypeCategory) (s :: Stage). (a -> b) -> Typed c s a -> b untyped TypeName -> m (TypeDefinition cat s) forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx. Constraints m c cat s ctx => TypeName -> m (TypeDefinition cat s) __askType __askType :: Constraints m c cat s ctx => TypeName -> m (TypeDefinition cat s) __askType :: TypeName -> m (TypeDefinition cat s) __askType TypeName name = (ValidatorContext s ctx -> Schema s) -> m (Schema s) forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ValidatorContext s ctx -> Schema s forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s schema m (Schema s) -> (Schema s -> m (TypeDefinition ANY s)) -> m (TypeDefinition ANY s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= m (TypeDefinition ANY s) -> (TypeDefinition ANY s -> m (TypeDefinition ANY s)) -> Maybe (TypeDefinition ANY s) -> m (TypeDefinition ANY s) forall b a. b -> (a -> b) -> Maybe a -> b maybe (GQLError -> m (TypeDefinition ANY s) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (TypeName -> GQLError unknownType TypeName name)) TypeDefinition ANY s -> m (TypeDefinition ANY s) forall (f :: * -> *) a. Applicative f => a -> f a pure (Maybe (TypeDefinition ANY s) -> m (TypeDefinition ANY s)) -> (Schema s -> Maybe (TypeDefinition ANY s)) -> Schema s -> m (TypeDefinition ANY s) forall b c a. (b -> c) -> (a -> b) -> a -> c . TypeName -> Schema s -> Maybe (TypeDefinition ANY s) forall (s :: Stage). TypeName -> Schema s -> Maybe (TypeDefinition ANY s) lookupDataType TypeName name m (TypeDefinition ANY s) -> (TypeDefinition ANY s -> m (TypeDefinition cat s)) -> m (TypeDefinition cat s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= TypeDefinition ANY s -> m (TypeDefinition cat s) forall (c :: TypeCategory) (f :: * -> *) (s :: Stage). (KindErrors c, KindConstraint f c) => TypeDefinition ANY s -> f (TypeDefinition c s) kindConstraint askTypeMember :: Constraints m c cat s ctx => UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s) askTypeMember :: UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s) askTypeMember = Typed cat s TypeName -> m (TypeDefinition cat s) forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx. Constraints m c cat s ctx => Typed cat s TypeName -> m (TypeDefinition cat s) askType2 (Typed cat s TypeName -> m (TypeDefinition cat s)) -> (UnionMember cat s -> Typed cat s TypeName) -> UnionMember cat s -> m (TypeDefinition cat s) forall b c a. (b -> c) -> (a -> b) -> a -> c . (UnionMember cat s -> TypeName) -> UnionMember cat s -> Typed cat s TypeName forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory) (s :: Stage) b. (a c s -> b) -> a c s -> Typed c s b typed UnionMember cat s -> TypeName forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName (UnionMember cat s -> m (TypeDefinition cat s)) -> (TypeDefinition cat s -> m (TypeDefinition (ToOBJECT cat) s)) -> UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s) forall (m :: * -> *) a b c. Monad m => (a -> m b) -> (b -> m c) -> a -> m c >=> TypeDefinition cat s -> m (TypeDefinition (ToOBJECT cat) s) forall (c :: TypeCategory) (f :: * -> *) (s :: Stage). (KindErrors c, Applicative f, MonadError GQLError f) => TypeDefinition c s -> f (TypeDefinition (ToOBJECT c) s) constraintObject askInterfaceTypes :: ( MonadError GQLError m, MonadReader (ValidatorContext s ctx) m, FromCategory (TypeContent TRUE) ANY IMPLEMENTABLE ) => TypeDefinition IMPLEMENTABLE s -> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s)) askInterfaceTypes :: TypeDefinition IMPLEMENTABLE s -> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s)) askInterfaceTypes typeDef :: TypeDefinition IMPLEMENTABLE s typeDef@TypeDefinition {TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName :: TypeName typeName} = (ValidatorContext s ctx -> Schema s) -> m (Schema s) forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ValidatorContext s ctx -> Schema s forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s schema m (Schema s) -> (Schema s -> m [TypeDefinition IMPLEMENTABLE s]) -> m [TypeDefinition IMPLEMENTABLE s] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (TypeDefinition ANY s -> m (TypeDefinition IMPLEMENTABLE s)) -> [TypeDefinition ANY s] -> m [TypeDefinition IMPLEMENTABLE s] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (Maybe (TypeDefinition IMPLEMENTABLE s) -> m (TypeDefinition IMPLEMENTABLE s) forall (f :: * -> *) a. MonadError GQLError f => Maybe a -> f a validate (Maybe (TypeDefinition IMPLEMENTABLE s) -> m (TypeDefinition IMPLEMENTABLE s)) -> (TypeDefinition ANY s -> Maybe (TypeDefinition IMPLEMENTABLE s)) -> TypeDefinition ANY s -> m (TypeDefinition IMPLEMENTABLE s) forall b c a. (b -> c) -> (a -> b) -> a -> c . TypeDefinition ANY s -> Maybe (TypeDefinition IMPLEMENTABLE s) forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory) (k' :: TypeCategory) (s :: Stage). FromCategory a k k' => a k s -> Maybe (a k' s) fromCategory) ([TypeDefinition ANY s] -> m [TypeDefinition IMPLEMENTABLE s]) -> (Schema s -> [TypeDefinition ANY s]) -> Schema s -> m [TypeDefinition IMPLEMENTABLE s] forall b c a. (b -> c) -> (a -> b) -> a -> c . TypeName -> Schema s -> [TypeDefinition ANY s] forall (s :: Stage). TypeName -> Schema s -> [TypeDefinition ANY s] possibleInterfaceTypes TypeName typeName m [TypeDefinition IMPLEMENTABLE s] -> ([TypeDefinition IMPLEMENTABLE s] -> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s))) -> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= [TypeDefinition IMPLEMENTABLE s] -> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s)) forall (m :: * -> *) k a (map :: * -> * -> *). (Monad m, KeyOf k a, FromList m map k a) => [a] -> m (map k a) fromElems ([TypeDefinition IMPLEMENTABLE s] -> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s))) -> ([TypeDefinition IMPLEMENTABLE s] -> [TypeDefinition IMPLEMENTABLE s]) -> [TypeDefinition IMPLEMENTABLE s] -> m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s)) forall b c a. (b -> c) -> (a -> b) -> a -> c . (TypeDefinition IMPLEMENTABLE s typeDef TypeDefinition IMPLEMENTABLE s -> [TypeDefinition IMPLEMENTABLE s] -> [TypeDefinition IMPLEMENTABLE s] forall a. a -> [a] -> [a] :) where validate :: Maybe a -> f a validate (Just a x) = a -> f a forall (f :: * -> *) a. Applicative f => a -> f a pure a x validate Maybe a Nothing = GQLError -> f a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> GQLError internal GQLError "Invalid interface Types") type Constraints m c cat s ctx = ( MonadError GQLError m, Monad m, MonadReader (ValidatorContext s ctx) m, KindErrors cat, FromCategory (TypeContent TRUE) ANY cat ) getOperationType :: Operation a -> SelectionValidator (TypeDefinition OBJECT VALID) getOperationType :: Operation a -> SelectionValidator (TypeDefinition OBJECT VALID) getOperationType Operation a operation = (ValidatorContext VALID (OperationContext VALID VALID) -> Schema VALID) -> Validator VALID (OperationContext VALID VALID) (Schema VALID) forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks ValidatorContext VALID (OperationContext VALID VALID) -> Schema VALID forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s schema Validator VALID (OperationContext VALID VALID) (Schema VALID) -> (Schema VALID -> Validator VALID (OperationContext VALID VALID) (TypeDefinition OBJECT VALID)) -> Validator VALID (OperationContext VALID VALID) (TypeDefinition OBJECT VALID) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Operation a -> Schema VALID -> Validator VALID (OperationContext VALID VALID) (TypeDefinition OBJECT VALID) forall (m :: * -> *) (s :: Stage). MonadError GQLError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID) getOperationDataType Operation a operation unknownType :: TypeName -> GQLError unknownType :: TypeName -> GQLError unknownType TypeName name = GQLError -> GQLError internal (GQLError -> GQLError) -> GQLError -> GQLError forall a b. (a -> b) -> a -> b $ GQLError "Type \"" GQLError -> GQLError -> GQLError forall a. Semigroup a => a -> a -> a <> TypeName -> GQLError forall a. Msg a => a -> GQLError msg TypeName name GQLError -> GQLError -> GQLError forall a. Semigroup a => a -> a -> a <> GQLError "\" can't found in Schema." type KindConstraint f c = ( MonadError GQLError f, FromCategory TypeDefinition ANY c ) _kindConstraint :: KindConstraint f k => Token -> TypeDefinition ANY s -> f (TypeDefinition k s) _kindConstraint :: Token -> TypeDefinition ANY s -> f (TypeDefinition k s) _kindConstraint Token err TypeDefinition ANY s anyType = f (TypeDefinition k s) -> (TypeDefinition k s -> f (TypeDefinition k s)) -> Maybe (TypeDefinition k s) -> f (TypeDefinition k s) forall b a. b -> (a -> b) -> Maybe a -> b maybe (GQLError -> f (TypeDefinition k s) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> f (TypeDefinition k s)) -> GQLError -> f (TypeDefinition k s) forall a b. (a -> b) -> a -> b $ Token -> TypeName -> GQLError violation Token err (TypeDefinition ANY s -> TypeName forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName TypeDefinition ANY s anyType)) TypeDefinition k s -> f (TypeDefinition k s) forall (f :: * -> *) a. Applicative f => a -> f a pure (TypeDefinition ANY s -> Maybe (TypeDefinition k s) forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory) (s :: Stage). FromCategory a ANY k => a ANY s -> Maybe (a k s) fromAny TypeDefinition ANY s anyType) class KindErrors c where kindConstraint :: KindConstraint f c => TypeDefinition ANY s -> f (TypeDefinition c s) constraintObject :: ( Applicative f, MonadError GQLError f ) => TypeDefinition c s -> f (TypeDefinition (ToOBJECT c) s) instance KindErrors IN where kindConstraint :: TypeDefinition ANY s -> f (TypeDefinition IN s) kindConstraint = Token -> TypeDefinition ANY s -> f (TypeDefinition IN s) forall (f :: * -> *) (k :: TypeCategory) (s :: Stage). KindConstraint f k => Token -> TypeDefinition ANY s -> f (TypeDefinition k s) _kindConstraint Token "input type" constraintObject :: TypeDefinition IN s -> f (TypeDefinition (ToOBJECT IN) s) constraintObject TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeContent TRUE a s typeContent = DataInputObject {FieldsDefinition IN s inputObjectFields :: forall (a :: TypeCategory) (s :: Stage). CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s inputObjectFields :: FieldsDefinition IN s ..}, Maybe Token Directives s TypeName typeDirectives :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> Directives s typeDescription :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> Maybe Token typeDirectives :: Directives s typeName :: TypeName typeDescription :: Maybe Token typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName ..} = TypeDefinition INPUT_OBJECT s -> f (TypeDefinition INPUT_OBJECT s) forall (f :: * -> *) a. Applicative f => a -> f a pure TypeDefinition :: forall (a :: TypeCategory) (s :: Stage). Maybe Token -> TypeName -> Directives s -> TypeContent TRUE a s -> TypeDefinition a s TypeDefinition {typeContent :: TypeContent TRUE INPUT_OBJECT s typeContent = DataInputObject :: forall (s :: Stage) (a :: TypeCategory). FieldsDefinition IN s -> CondTypeContent INPUT_OBJECT a s DataInputObject {FieldsDefinition IN s inputObjectFields :: FieldsDefinition IN s inputObjectFields :: FieldsDefinition IN s ..}, Maybe Token Directives s TypeName typeDirectives :: Directives s typeDescription :: Maybe Token typeDirectives :: Directives s typeName :: TypeName typeDescription :: Maybe Token typeName :: TypeName ..} constraintObject TypeDefinition {TypeName typeName :: TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName} = GQLError -> f (TypeDefinition INPUT_OBJECT s) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (Token -> TypeName -> GQLError violation Token "input object" TypeName typeName) instance KindErrors OUT where kindConstraint :: TypeDefinition ANY s -> f (TypeDefinition OUT s) kindConstraint = Token -> TypeDefinition ANY s -> f (TypeDefinition OUT s) forall (f :: * -> *) (k :: TypeCategory) (s :: Stage). KindConstraint f k => Token -> TypeDefinition ANY s -> f (TypeDefinition k s) _kindConstraint Token "output type" constraintObject :: TypeDefinition OUT s -> f (TypeDefinition (ToOBJECT OUT) s) constraintObject TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeContent TRUE a s typeContent = DataObject {[TypeName] FieldsDefinition OUT s objectFields :: forall (a :: TypeCategory) (s :: Stage). CondTypeContent OBJECT a s -> FieldsDefinition OUT s objectImplements :: forall (a :: TypeCategory) (s :: Stage). CondTypeContent OBJECT a s -> [TypeName] objectFields :: FieldsDefinition OUT s objectImplements :: [TypeName] ..}, Maybe Token Directives s TypeName typeDirectives :: Directives s typeName :: TypeName typeDescription :: Maybe Token typeDirectives :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> Directives s typeDescription :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> Maybe Token typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName ..} = TypeDefinition OBJECT s -> f (TypeDefinition OBJECT s) forall (f :: * -> *) a. Applicative f => a -> f a pure TypeDefinition :: forall (a :: TypeCategory) (s :: Stage). Maybe Token -> TypeName -> Directives s -> TypeContent TRUE a s -> TypeDefinition a s TypeDefinition {typeContent :: TypeContent TRUE OBJECT s typeContent = DataObject :: forall (s :: Stage) (a :: TypeCategory). [TypeName] -> FieldsDefinition OUT s -> CondTypeContent OBJECT a s DataObject {[TypeName] FieldsDefinition OUT s objectFields :: FieldsDefinition OUT s objectImplements :: [TypeName] objectFields :: FieldsDefinition OUT s objectImplements :: [TypeName] ..}, Maybe Token Directives s TypeName typeDirectives :: Directives s typeName :: TypeName typeDescription :: Maybe Token typeDirectives :: Directives s typeDescription :: Maybe Token typeName :: TypeName ..} constraintObject TypeDefinition {TypeName typeName :: TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName} = GQLError -> f (TypeDefinition OBJECT s) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (Token -> TypeName -> GQLError violation Token "object" TypeName typeName) violation :: Token -> TypeName -> GQLError violation :: Token -> TypeName -> GQLError violation Token kind TypeName typeName = GQLError -> GQLError internal (GQLError -> GQLError) -> GQLError -> GQLError forall a b. (a -> b) -> a -> b $ GQLError "Type \"" GQLError -> GQLError -> GQLError forall a. Semigroup a => a -> a -> a <> TypeName -> GQLError forall a. Msg a => a -> GQLError msg TypeName typeName GQLError -> GQLError -> GQLError forall a. Semigroup a => a -> a -> a <> GQLError "\" must be an" GQLError -> GQLError -> GQLError forall a. Semigroup a => a -> a -> a <> Token -> GQLError forall a. Msg a => a -> GQLError msg Token kind GQLError -> GQLError -> GQLError forall a. Semigroup a => a -> a -> a <> GQLError "."