{-# 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 :: forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx. Constraints m c cat s ctx => Typed cat s TypeRef -> m (TypeDefinition cat s) askType = forall a b (c :: TypeCategory) (s :: Stage). (a -> b) -> Typed c s a -> b untyped (forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx. Constraints m c cat s ctx => TypeName -> m (TypeDefinition cat s) __askType 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 :: forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx. Constraints m c cat s ctx => Typed cat s TypeName -> m (TypeDefinition cat s) askType2 = forall a b (c :: TypeCategory) (s :: Stage). (a -> b) -> Typed c s a -> b untyped 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 :: forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx. Constraints m c cat s ctx => TypeName -> m (TypeDefinition cat s) __askType TypeName name = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s schema forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (TypeName -> GQLError unknownType TypeName name)) forall (f :: * -> *) a. Applicative f => a -> f a pure forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (s :: Stage). TypeName -> Schema s -> Maybe (TypeDefinition ANY s) lookupDataType TypeName name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= 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 :: forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx. Constraints m c cat s ctx => UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s) askTypeMember = forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx. Constraints m c cat s ctx => Typed cat s TypeName -> m (TypeDefinition cat s) askType2 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory) (s :: Stage) b. (a c s -> b) -> a c s -> Typed c s b typed forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName forall (m :: * -> *) a b c. Monad m => (a -> m b) -> (b -> m c) -> a -> m c >=> 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 :: forall (m :: * -> *) (s :: Stage) ctx. (MonadError GQLError m, MonadReader (ValidatorContext s ctx) m, FromCategory (TypeContent TRUE) ANY IMPLEMENTABLE) => 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} = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s schema forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (forall {f :: * -> *} {a}. MonadError GQLError f => Maybe a -> f a validate forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory) (k' :: TypeCategory) (s :: Stage). FromCategory a k k' => a k s -> Maybe (a k' s) fromCategory) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (s :: Stage). TypeName -> Schema s -> [TypeDefinition ANY s] possibleInterfaceTypes TypeName typeName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *) k a (map :: * -> * -> *). (Monad m, KeyOf k a, FromList m map k a) => [a] -> m (map k a) fromElems forall b c a. (b -> c) -> (a -> b) -> a -> c . (TypeDefinition IMPLEMENTABLE s typeDef forall a. a -> [a] -> [a] :) where validate :: Maybe a -> f a validate (Just a x) = forall (f :: * -> *) a. Applicative f => a -> f a pure a x validate Maybe a Nothing = 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 :: forall (a :: Stage). Operation a -> SelectionValidator (TypeDefinition OBJECT VALID) getOperationType Operation a operation = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s schema forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= 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 forall a b. (a -> b) -> a -> b $ GQLError "Type \"" forall a. Semigroup a => a -> a -> a <> forall a. Msg a => a -> GQLError msg TypeName name 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 :: forall (f :: * -> *) (k :: TypeCategory) (s :: Stage). KindConstraint f k => Token -> TypeDefinition ANY s -> f (TypeDefinition k s) _kindConstraint Token err TypeDefinition ANY s anyType = forall b a. b -> (a -> b) -> Maybe a -> b maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ Token -> TypeName -> GQLError violation Token err (forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName TypeDefinition ANY s anyType)) forall (f :: * -> *) a. Applicative f => a -> f a pure (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 :: forall (f :: * -> *) (s :: Stage). KindConstraint f IN => TypeDefinition ANY s -> f (TypeDefinition IN s) kindConstraint = forall (f :: * -> *) (k :: TypeCategory) (s :: Stage). KindConstraint f k => Token -> TypeDefinition ANY s -> f (TypeDefinition k s) _kindConstraint Token "input type" constraintObject :: forall (f :: * -> *) (s :: Stage). (Applicative f, MonadError GQLError f) => 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 (s :: Stage) (a :: TypeCategory). 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 ..} = forall (f :: * -> *) a. Applicative f => a -> f a pure TypeDefinition {typeContent :: TypeContent TRUE INPUT_OBJECT s typeContent = 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} = 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 :: forall (f :: * -> *) (s :: Stage). KindConstraint f OUT => TypeDefinition ANY s -> f (TypeDefinition OUT s) kindConstraint = forall (f :: * -> *) (k :: TypeCategory) (s :: Stage). KindConstraint f k => Token -> TypeDefinition ANY s -> f (TypeDefinition k s) _kindConstraint Token "output type" constraintObject :: forall (f :: * -> *) (s :: Stage). (Applicative f, MonadError GQLError f) => 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 (s :: Stage) (a :: TypeCategory). CondTypeContent OBJECT a s -> FieldsDefinition OUT s objectImplements :: forall (s :: Stage) (a :: TypeCategory). 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 ..} = forall (f :: * -> *) a. Applicative f => a -> f a pure TypeDefinition {typeContent :: TypeContent TRUE OBJECT s typeContent = 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} = 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 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" forall a. Semigroup a => a -> a -> a <> forall a. Msg a => a -> GQLError msg Token kind forall a. Semigroup a => a -> a -> a <> GQLError "."