{-# 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 Data.Morpheus.Internal.Utils ( Failure (..), selectBy, ) import Data.Morpheus.Types.Internal.AST ( ANY, FieldsDefinition, FromCategory, IMPLEMENTABLE, IN, InternalError, OBJECT, OUT, Operation, Operation (..), Stage, TRUE, Token, TypeCategory, TypeContent (..), TypeContent, TypeDefinition (..), TypeName (..), TypeRef, Typed, UnionMember (..), VALID, fromAny, fromCategory, getOperationDataType, msgInternal, possibleInterfaceTypes, typeConName, typed, untyped, ) import Data.Morpheus.Types.Internal.Validation.Validator ( MonadContext, SelectionValidator, askSchema, ) import Relude askType :: Constraints m c cat s => Typed cat s TypeRef -> m c (TypeDefinition cat s) askType :: Typed cat s TypeRef -> m c (TypeDefinition cat s) askType = (TypeRef -> m c (TypeDefinition cat s)) -> Typed cat s TypeRef -> m c (TypeDefinition cat s) forall a b (c :: TypeCategory) (s :: Stage). (a -> b) -> Typed c s a -> b untyped (TypeName -> m c (TypeDefinition cat s) forall (m :: * -> * -> *) c (cat :: TypeCategory) (s :: Stage). Constraints m c cat s => TypeName -> m c (TypeDefinition cat s) __askType (TypeName -> m c (TypeDefinition cat s)) -> (TypeRef -> TypeName) -> TypeRef -> m c (TypeDefinition cat s) forall b c a. (b -> c) -> (a -> b) -> a -> c . TypeRef -> TypeName typeConName) askType2 :: Constraints m c cat s => Typed cat s TypeName -> m c (TypeDefinition cat s) askType2 :: Typed cat s TypeName -> m c (TypeDefinition cat s) askType2 = (TypeName -> m c (TypeDefinition cat s)) -> Typed cat s TypeName -> m c (TypeDefinition cat s) forall a b (c :: TypeCategory) (s :: Stage). (a -> b) -> Typed c s a -> b untyped TypeName -> m c (TypeDefinition cat s) forall (m :: * -> * -> *) c (cat :: TypeCategory) (s :: Stage). Constraints m c cat s => TypeName -> m c (TypeDefinition cat s) __askType __askType :: Constraints m c cat s => TypeName -> m c (TypeDefinition cat s) __askType :: TypeName -> m c (TypeDefinition cat s) __askType TypeName name = m c (Schema s) forall (m :: * -> * -> *) (s :: Stage) c. MonadContext m s c => m c (Schema s) askSchema m c (Schema s) -> (Schema s -> m c (TypeDefinition ANY s)) -> m c (TypeDefinition ANY s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= InternalError -> TypeName -> Schema s -> m c (TypeDefinition ANY s) forall e (m :: * -> *) k a c. (Failure e m, Selectable k a c, Monad m) => e -> k -> c -> m a selectBy (TypeName -> InternalError unknownType TypeName name) TypeName name m c (TypeDefinition ANY s) -> (TypeDefinition ANY s -> m c (TypeDefinition cat s)) -> m c (TypeDefinition cat s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= TypeDefinition ANY s -> m c (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 => UnionMember cat s -> m c (TypeMemberResponse cat s) askTypeMember :: UnionMember cat s -> m c (TypeMemberResponse cat s) askTypeMember = Typed cat s TypeName -> m c (TypeDefinition cat s) forall (m :: * -> * -> *) c (cat :: TypeCategory) (s :: Stage). Constraints m c cat s => Typed cat s TypeName -> m c (TypeDefinition cat s) askType2 (Typed cat s TypeName -> m c (TypeDefinition cat s)) -> (UnionMember cat s -> Typed cat s TypeName) -> UnionMember cat s -> m c (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 c (TypeDefinition cat s)) -> (TypeDefinition cat s -> m c (TypeMemberResponse cat s)) -> UnionMember cat s -> m c (TypeMemberResponse cat s) forall (m :: * -> *) a b c. Monad m => (a -> m b) -> (b -> m c) -> a -> m c >=> TypeDefinition cat s -> m c (TypeMemberResponse cat s) forall (c :: TypeCategory) (f :: * -> *) (s :: Stage). (KindErrors c, Applicative f, Failure InternalError f) => TypeDefinition c s -> f (TypeMemberResponse c s) constraintObject askInterfaceTypes :: ( Failure InternalError (m c), Monad (m c), MonadContext m s c, FromCategory (TypeContent TRUE) ANY IMPLEMENTABLE ) => TypeDefinition IMPLEMENTABLE s -> m c [TypeDefinition IMPLEMENTABLE s] askInterfaceTypes :: TypeDefinition IMPLEMENTABLE s -> m c [TypeDefinition IMPLEMENTABLE s] askInterfaceTypes typeDef :: TypeDefinition IMPLEMENTABLE s typeDef@TypeDefinition {TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName :: TypeName typeName} = (TypeDefinition IMPLEMENTABLE s typeDef TypeDefinition IMPLEMENTABLE s -> [TypeDefinition IMPLEMENTABLE s] -> [TypeDefinition IMPLEMENTABLE s] forall a. a -> [a] -> [a] :) ([TypeDefinition IMPLEMENTABLE s] -> [TypeDefinition IMPLEMENTABLE s]) -> m c [TypeDefinition IMPLEMENTABLE s] -> m c [TypeDefinition IMPLEMENTABLE s] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ( m c (Schema s) forall (m :: * -> * -> *) (s :: Stage) c. MonadContext m s c => m c (Schema s) askSchema m c (Schema s) -> (Schema s -> m c [TypeDefinition IMPLEMENTABLE s]) -> m c [TypeDefinition IMPLEMENTABLE s] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (TypeDefinition ANY s -> m c (TypeDefinition IMPLEMENTABLE s)) -> [TypeDefinition ANY s] -> m c [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 c (TypeDefinition IMPLEMENTABLE s) forall (f :: * -> *) a. Failure InternalError f => Maybe a -> f a validate (Maybe (TypeDefinition IMPLEMENTABLE s) -> m c (TypeDefinition IMPLEMENTABLE s)) -> (TypeDefinition ANY s -> Maybe (TypeDefinition IMPLEMENTABLE s)) -> TypeDefinition ANY s -> m c (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 c [TypeDefinition IMPLEMENTABLE s]) -> (Schema s -> [TypeDefinition ANY s]) -> Schema s -> m c [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 ) 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 = InternalError -> f a forall error (f :: * -> *) v. Failure error f => error -> f v failure (InternalError "TODO: invalid interface Types" :: InternalError) type family TypeMemberResponse (cat :: TypeCategory) (s :: Stage) type instance TypeMemberResponse OUT s = TypeDefinition OBJECT s type instance TypeMemberResponse IN s = (TypeDefinition IN s, FieldsDefinition IN s) type Constraints m c cat s = ( Failure InternalError (m c), Monad (m c), MonadContext m s c, 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 = Validator VALID (OperationContext VALID VALID) (Schema VALID) forall (m :: * -> * -> *) (s :: Stage) c. MonadContext m s c => m c (Schema s) askSchema Validator VALID (OperationContext VALID VALID) (Schema VALID) -> (Schema VALID -> SelectionValidator (TypeDefinition OBJECT VALID)) -> SelectionValidator (TypeDefinition OBJECT VALID) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Operation a -> Schema VALID -> SelectionValidator (TypeDefinition OBJECT VALID) forall (m :: * -> *) (s :: Stage). Failure ValidationError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID) getOperationDataType Operation a operation unknownType :: TypeName -> InternalError unknownType :: TypeName -> InternalError unknownType TypeName name = InternalError "Type \"" InternalError -> InternalError -> InternalError forall a. Semigroup a => a -> a -> a <> TypeName -> InternalError forall a. Msg a => a -> InternalError msgInternal TypeName name InternalError -> InternalError -> InternalError forall a. Semigroup a => a -> a -> a <> InternalError "\" can't found in Schema." type KindConstraint f c = ( Failure InternalError 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 (InternalError -> f (TypeDefinition k s) forall error (f :: * -> *) v. Failure error f => error -> f v failure (InternalError -> f (TypeDefinition k s)) -> InternalError -> f (TypeDefinition k s) forall a b. (a -> b) -> a -> b $ Token -> TypeName -> InternalError 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, Failure InternalError f ) => TypeDefinition c s -> f (TypeMemberResponse 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 (TypeMemberResponse IN s) constraintObject typeDef :: TypeDefinition IN s typeDef@TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeContent TRUE a s typeContent = DataInputObject FieldsDefinition IN s inputFields} = (TypeDefinition IN s, FieldsDefinition IN s) -> f (TypeDefinition IN s, FieldsDefinition IN s) forall (f :: * -> *) a. Applicative f => a -> f a pure (TypeDefinition IN s typeDef, FieldsDefinition IN s inputFields) constraintObject TypeDefinition {TypeName typeName :: TypeName typeName :: forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName} = InternalError -> f (TypeDefinition IN s, FieldsDefinition IN s) forall error (f :: * -> *) v. Failure error f => error -> f v failure (Token -> TypeName -> InternalError 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 (TypeMemberResponse 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). TypeContent (ELEM OBJECT a) a s -> FieldsDefinition OUT s objectImplements :: forall (a :: TypeCategory) (s :: Stage). TypeContent (ELEM OBJECT a) a s -> [TypeName] objectFields :: FieldsDefinition OUT s objectImplements :: [TypeName] ..}, Directives s Maybe Token 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 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 -> TypeContent (ELEM OBJECT a) a s DataObject {[TypeName] FieldsDefinition OUT s objectFields :: FieldsDefinition OUT s objectImplements :: [TypeName] objectFields :: FieldsDefinition OUT s objectImplements :: [TypeName] ..}, Directives s Maybe Token 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} = InternalError -> f (TypeDefinition OBJECT s) forall error (f :: * -> *) v. Failure error f => error -> f v failure (Token -> TypeName -> InternalError violation Token "object" TypeName typeName) violation :: Token -> TypeName -> InternalError violation :: Token -> TypeName -> InternalError violation Token kind TypeName typeName = InternalError "Type \"" InternalError -> InternalError -> InternalError forall a. Semigroup a => a -> a -> a <> TypeName -> InternalError forall a. Msg a => a -> InternalError msgInternal TypeName typeName InternalError -> InternalError -> InternalError forall a. Semigroup a => a -> a -> a <> InternalError "\" must be an" InternalError -> InternalError -> InternalError forall a. Semigroup a => a -> a -> a <> Token -> InternalError forall a. Msg a => a -> InternalError msgInternal Token kind InternalError -> InternalError -> InternalError forall a. Semigroup a => a -> a -> a <> InternalError "."