{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.App.Internal.Stitching ( Stitching (..), ) where import Control.Monad.Except (MonadError (throwError)) import Data.Morpheus.App.Internal.Resolving (RootResolverValue (..)) import Data.Morpheus.App.Internal.Resolving.Types ( NamedResolver (..), NamedResolverResult (..), ) import qualified Data.Morpheus.App.Internal.Resolving.Types as R import Data.Morpheus.Error (NameCollision (..)) import Data.Morpheus.Internal.Ext ( Merge (merge), resolveWith, runResolutionT, unsafeFromList, ) import Data.Morpheus.Internal.Utils ( mergeT, prop, ) import Data.Morpheus.Types.Internal.AST ( Directives, DirectivesDefinition, FieldDefinition, FieldsDefinition, GQLError, Schema (..), TRUE, TypeContent (..), TypeDefinition (..), TypeDefinitions, ) import Relude hiding (optional) equal :: (Eq a, Applicative m, MonadError GQLError m) => GQLError -> a -> a -> m a equal :: GQLError -> a -> a -> m a equal GQLError err a p1 a p2 | a p1 a -> a -> Bool forall a. Eq a => a -> a -> Bool == a p2 = a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure a p2 | Bool otherwise = GQLError -> m a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError GQLError err fstM :: Applicative m => a -> a -> m a fstM :: a -> a -> m a fstM a x a _ = a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure a x concatM :: (Applicative m, Semigroup a) => a -> a -> m a concatM :: a -> a -> m a concatM a x = a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure (a -> m a) -> (a -> a) -> a -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . (a x a -> a -> a forall a. Semigroup a => a -> a -> a <>) class Stitching a where stitch :: (Monad m, MonadError GQLError m) => a -> a -> m a instance Stitching a => Stitching (Maybe a) where stitch :: Maybe a -> Maybe a -> m (Maybe a) stitch = (a -> a -> m a) -> Maybe a -> Maybe a -> m (Maybe a) forall (f :: * -> *) t. Applicative f => (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t) optional a -> a -> m a forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch instance Stitching (Schema s) where stitch :: Schema s -> Schema s -> m (Schema s) stitch Schema s s1 Schema s s2 = TypeDefinitions s -> TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> DirectivesDefinition s -> Schema s forall (s :: Stage). TypeDefinitions s -> TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> DirectivesDefinition s -> Schema s Schema (TypeDefinitions s -> TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> DirectivesDefinition s -> Schema s) -> m (TypeDefinitions s) -> m (TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> DirectivesDefinition s -> Schema s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (TypeDefinitions s -> TypeDefinitions s -> m (TypeDefinitions s)) -> (Schema s -> TypeDefinitions s) -> Schema s -> Schema s -> m (TypeDefinitions s) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop TypeDefinitions s -> TypeDefinitions s -> m (TypeDefinitions s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch Schema s -> TypeDefinitions s forall (s :: Stage). Schema s -> TypeDefinitions s types Schema s s1 Schema s s2 m (TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> DirectivesDefinition s -> Schema s) -> m (TypeDefinition OBJECT s) -> m (Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> DirectivesDefinition s -> Schema s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (TypeDefinition OBJECT s -> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)) -> (Schema s -> TypeDefinition OBJECT s) -> Schema s -> Schema s -> m (TypeDefinition OBJECT s) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop TypeDefinition OBJECT s -> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s) forall (m :: * -> *) (c :: TypeCategory) (s :: Stage). (Monad m, MonadError GQLError m) => TypeDefinition c s -> TypeDefinition c s -> m (TypeDefinition c s) stitchOperation Schema s -> TypeDefinition OBJECT s forall (s :: Stage). Schema s -> TypeDefinition OBJECT s query Schema s s1 Schema s s2 m (Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> DirectivesDefinition s -> Schema s) -> m (Maybe (TypeDefinition OBJECT s)) -> m (Maybe (TypeDefinition OBJECT s) -> DirectivesDefinition s -> Schema s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> m (Maybe (TypeDefinition OBJECT s))) -> (Schema s -> Maybe (TypeDefinition OBJECT s)) -> Schema s -> Schema s -> m (Maybe (TypeDefinition OBJECT s)) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop ((TypeDefinition OBJECT s -> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)) -> Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> m (Maybe (TypeDefinition OBJECT s)) forall (f :: * -> *) t. Applicative f => (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t) optional TypeDefinition OBJECT s -> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s) forall (m :: * -> *) (c :: TypeCategory) (s :: Stage). (Monad m, MonadError GQLError m) => TypeDefinition c s -> TypeDefinition c s -> m (TypeDefinition c s) stitchOperation) Schema s -> Maybe (TypeDefinition OBJECT s) forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s) mutation Schema s s1 Schema s s2 m (Maybe (TypeDefinition OBJECT s) -> DirectivesDefinition s -> Schema s) -> m (Maybe (TypeDefinition OBJECT s)) -> m (DirectivesDefinition s -> Schema s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> m (Maybe (TypeDefinition OBJECT s))) -> (Schema s -> Maybe (TypeDefinition OBJECT s)) -> Schema s -> Schema s -> m (Maybe (TypeDefinition OBJECT s)) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop ((TypeDefinition OBJECT s -> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s)) -> Maybe (TypeDefinition OBJECT s) -> Maybe (TypeDefinition OBJECT s) -> m (Maybe (TypeDefinition OBJECT s)) forall (f :: * -> *) t. Applicative f => (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t) optional TypeDefinition OBJECT s -> TypeDefinition OBJECT s -> m (TypeDefinition OBJECT s) forall (m :: * -> *) (c :: TypeCategory) (s :: Stage). (Monad m, MonadError GQLError m) => TypeDefinition c s -> TypeDefinition c s -> m (TypeDefinition c s) stitchOperation) Schema s -> Maybe (TypeDefinition OBJECT s) forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s) subscription Schema s s1 Schema s s2 m (DirectivesDefinition s -> Schema s) -> m (DirectivesDefinition s) -> m (Schema s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (DirectivesDefinition s -> DirectivesDefinition s -> m (DirectivesDefinition s)) -> (Schema s -> DirectivesDefinition s) -> Schema s -> Schema s -> m (DirectivesDefinition s) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop DirectivesDefinition s -> DirectivesDefinition s -> m (DirectivesDefinition s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch Schema s -> DirectivesDefinition s forall (s :: Stage). Schema s -> DirectivesDefinition s directiveDefinitions Schema s s1 Schema s s2 instance Stitching (TypeDefinitions s) where stitch :: TypeDefinitions s -> TypeDefinitions s -> m (TypeDefinitions s) stitch TypeDefinitions s x TypeDefinitions s y = ResolutionT TypeName (TypeDefinition ANY s) (TypeDefinitions s) m (TypeDefinitions s) -> ([(TypeName, TypeDefinition ANY s)] -> TypeDefinitions s) -> (NonEmpty (TypeDefinition ANY s) -> m (TypeDefinition ANY s)) -> m (TypeDefinitions s) forall k a coll (m :: * -> *) b. ResolutionT k a coll m b -> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b runResolutionT (TypeDefinitions s -> TypeDefinitions s -> ResolutionT TypeName (TypeDefinition ANY s) (TypeDefinitions s) m (TypeDefinitions s) forall k a (t :: * -> *) (m :: * -> *) c. (KeyOf k a, Foldable t, Monad m) => t a -> t a -> ResolutionT k a c m c mergeT TypeDefinitions s x TypeDefinitions s y) [(TypeName, TypeDefinition ANY s)] -> TypeDefinitions s forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a unsafeFromList ((TypeDefinition ANY s -> TypeDefinition ANY s -> m (TypeDefinition ANY s)) -> NonEmpty (TypeDefinition ANY s) -> m (TypeDefinition ANY s) forall (m :: * -> *) a. Monad m => (a -> a -> m a) -> NonEmpty a -> m a resolveWith TypeDefinition ANY s -> TypeDefinition ANY s -> m (TypeDefinition ANY s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch) instance Stitching (DirectivesDefinition s) where stitch :: DirectivesDefinition s -> DirectivesDefinition s -> m (DirectivesDefinition s) stitch = DirectivesDefinition s -> DirectivesDefinition s -> m (DirectivesDefinition s) forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a merge instance Stitching (Directives s) where stitch :: Directives s -> Directives s -> m (Directives s) stitch = Directives s -> Directives s -> m (Directives s) forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a merge optional :: Applicative f => (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t) optional :: (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t) optional t -> t -> f t _ Maybe t Nothing Maybe t y = Maybe t -> f (Maybe t) forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe t y optional t -> t -> f t _ (Just t x) Maybe t Nothing = Maybe t -> f (Maybe t) forall (f :: * -> *) a. Applicative f => a -> f a pure (t -> Maybe t forall a. a -> Maybe a Just t x) optional t -> t -> f t f (Just t x) (Just t y) = t -> Maybe t forall a. a -> Maybe a Just (t -> Maybe t) -> f t -> f (Maybe t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> t -> t -> f t f t x t y stitchOperation :: (Monad m, MonadError GQLError m) => TypeDefinition c s -> TypeDefinition c s -> m (TypeDefinition c s) stitchOperation :: TypeDefinition c s -> TypeDefinition c s -> m (TypeDefinition c s) stitchOperation TypeDefinition c s x TypeDefinition c s y = Maybe Description -> TypeName -> Directives s -> TypeContent TRUE c s -> TypeDefinition c s forall (a :: TypeCategory) (s :: Stage). Maybe Description -> TypeName -> Directives s -> TypeContent TRUE a s -> TypeDefinition a s TypeDefinition (Maybe Description -> TypeName -> Directives s -> TypeContent TRUE c s -> TypeDefinition c s) -> m (Maybe Description) -> m (TypeName -> Directives s -> TypeContent TRUE c s -> TypeDefinition c s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Maybe Description -> Maybe Description -> m (Maybe Description)) -> (TypeDefinition c s -> Maybe Description) -> TypeDefinition c s -> TypeDefinition c s -> m (Maybe Description) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop Maybe Description -> Maybe Description -> m (Maybe Description) forall (m :: * -> *) a. (Applicative m, Semigroup a) => a -> a -> m a concatM TypeDefinition c s -> Maybe Description forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> Maybe Description typeDescription TypeDefinition c s x TypeDefinition c s y m (TypeName -> Directives s -> TypeContent TRUE c s -> TypeDefinition c s) -> m TypeName -> m (Directives s -> TypeContent TRUE c s -> TypeDefinition c s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (TypeName -> TypeName -> m TypeName) -> (TypeDefinition c s -> TypeName) -> TypeDefinition c s -> TypeDefinition c s -> m TypeName forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop TypeName -> TypeName -> m TypeName forall (m :: * -> *) a. Applicative m => a -> a -> m a fstM TypeDefinition c s -> TypeName forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName TypeDefinition c s x TypeDefinition c s y m (Directives s -> TypeContent TRUE c s -> TypeDefinition c s) -> m (Directives s) -> m (TypeContent TRUE c s -> TypeDefinition c s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (Directives s -> Directives s -> m (Directives s)) -> (TypeDefinition c s -> Directives s) -> TypeDefinition c s -> TypeDefinition c s -> m (Directives s) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop Directives s -> Directives s -> m (Directives s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch TypeDefinition c s -> Directives s forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> Directives s typeDirectives TypeDefinition c s x TypeDefinition c s y m (TypeContent TRUE c s -> TypeDefinition c s) -> m (TypeContent TRUE c s) -> m (TypeDefinition c s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (TypeContent TRUE c s -> TypeContent TRUE c s -> m (TypeContent TRUE c s)) -> (TypeDefinition c s -> TypeContent TRUE c s) -> TypeDefinition c s -> TypeDefinition c s -> m (TypeContent TRUE c s) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop TypeContent TRUE c s -> TypeContent TRUE c s -> m (TypeContent TRUE c s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch TypeDefinition c s -> TypeContent TRUE c s forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeContent TRUE a s typeContent TypeDefinition c s x TypeDefinition c s y instance Stitching (TypeDefinition cat s) where stitch :: TypeDefinition cat s -> TypeDefinition cat s -> m (TypeDefinition cat s) stitch TypeDefinition cat s x TypeDefinition cat s y = Maybe Description -> TypeName -> Directives s -> TypeContent TRUE cat s -> TypeDefinition cat s forall (a :: TypeCategory) (s :: Stage). Maybe Description -> TypeName -> Directives s -> TypeContent TRUE a s -> TypeDefinition a s TypeDefinition (Maybe Description -> TypeName -> Directives s -> TypeContent TRUE cat s -> TypeDefinition cat s) -> m (Maybe Description) -> m (TypeName -> Directives s -> TypeContent TRUE cat s -> TypeDefinition cat s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Maybe Description -> Maybe Description -> m (Maybe Description)) -> (TypeDefinition cat s -> Maybe Description) -> TypeDefinition cat s -> TypeDefinition cat s -> m (Maybe Description) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop Maybe Description -> Maybe Description -> m (Maybe Description) forall (m :: * -> *) a. (Applicative m, Semigroup a) => a -> a -> m a concatM TypeDefinition cat s -> Maybe Description forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> Maybe Description typeDescription TypeDefinition cat s x TypeDefinition cat s y m (TypeName -> Directives s -> TypeContent TRUE cat s -> TypeDefinition cat s) -> m TypeName -> m (Directives s -> TypeContent TRUE cat s -> TypeDefinition cat s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (TypeName -> TypeName -> m TypeName) -> (TypeDefinition cat s -> TypeName) -> TypeDefinition cat s -> TypeDefinition cat s -> m TypeName forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop (GQLError -> TypeName -> TypeName -> m TypeName forall a (m :: * -> *). (Eq a, Applicative m, MonadError GQLError m) => GQLError -> a -> a -> m a equal (GQLError -> TypeName -> TypeName -> m TypeName) -> GQLError -> TypeName -> TypeName -> m TypeName forall a b. (a -> b) -> a -> b $ TypeDefinition cat s -> GQLError forall e a. NameCollision e a => a -> e nameCollision TypeDefinition cat s y) TypeDefinition cat s -> TypeName forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName TypeDefinition cat s x TypeDefinition cat s y m (Directives s -> TypeContent TRUE cat s -> TypeDefinition cat s) -> m (Directives s) -> m (TypeContent TRUE cat s -> TypeDefinition cat s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (Directives s -> Directives s -> m (Directives s)) -> (TypeDefinition cat s -> Directives s) -> TypeDefinition cat s -> TypeDefinition cat s -> m (Directives s) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop Directives s -> Directives s -> m (Directives s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch TypeDefinition cat s -> Directives s forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> Directives s typeDirectives TypeDefinition cat s x TypeDefinition cat s y m (TypeContent TRUE cat s -> TypeDefinition cat s) -> m (TypeContent TRUE cat s) -> m (TypeDefinition cat s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (TypeContent TRUE cat s -> TypeContent TRUE cat s -> m (TypeContent TRUE cat s)) -> (TypeDefinition cat s -> TypeContent TRUE cat s) -> TypeDefinition cat s -> TypeDefinition cat s -> m (TypeContent TRUE cat s) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop TypeContent TRUE cat s -> TypeContent TRUE cat s -> m (TypeContent TRUE cat s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch TypeDefinition cat s -> TypeContent TRUE cat s forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeContent TRUE a s typeContent TypeDefinition cat s x TypeDefinition cat s y instance Stitching (TypeContent TRUE cat s) where stitch :: TypeContent TRUE cat s -> TypeContent TRUE cat s -> m (TypeContent TRUE cat s) stitch (DataObject [TypeName] i1 FieldsDefinition OUT s fields1) (DataObject [TypeName] i2 FieldsDefinition OUT s fields2) = [TypeName] -> FieldsDefinition OUT s -> TypeContent (OBJECT <=? cat) cat s forall (s :: Stage) (a :: TypeCategory). [TypeName] -> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s DataObject ([TypeName] i1 [TypeName] -> [TypeName] -> [TypeName] forall a. Semigroup a => a -> a -> a <> [TypeName] i2) (FieldsDefinition OUT s -> TypeContent TRUE cat s) -> m (FieldsDefinition OUT s) -> m (TypeContent TRUE cat s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> FieldsDefinition OUT s -> FieldsDefinition OUT s -> m (FieldsDefinition OUT s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch FieldsDefinition OUT s fields1 FieldsDefinition OUT s fields2 stitch TypeContent TRUE cat s x TypeContent TRUE cat s y | TypeContent TRUE cat s x TypeContent TRUE cat s -> TypeContent TRUE cat s -> Bool forall a. Eq a => a -> a -> Bool == TypeContent TRUE cat s y = TypeContent TRUE cat s -> m (TypeContent TRUE cat s) forall (f :: * -> *) a. Applicative f => a -> f a pure TypeContent TRUE cat s y | Bool otherwise = GQLError -> m (TypeContent TRUE cat s) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError "Schema Stitching works only for objects" :: GQLError) instance Stitching (FieldsDefinition cat s) where stitch :: FieldsDefinition cat s -> FieldsDefinition cat s -> m (FieldsDefinition cat s) stitch FieldsDefinition cat s x FieldsDefinition cat s y = ResolutionT FieldName (FieldDefinition cat s) (FieldsDefinition cat s) m (FieldsDefinition cat s) -> ([(FieldName, FieldDefinition cat s)] -> FieldsDefinition cat s) -> (NonEmpty (FieldDefinition cat s) -> m (FieldDefinition cat s)) -> m (FieldsDefinition cat s) forall k a coll (m :: * -> *) b. ResolutionT k a coll m b -> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b runResolutionT (FieldsDefinition cat s -> FieldsDefinition cat s -> ResolutionT FieldName (FieldDefinition cat s) (FieldsDefinition cat s) m (FieldsDefinition cat s) forall k a (t :: * -> *) (m :: * -> *) c. (KeyOf k a, Foldable t, Monad m) => t a -> t a -> ResolutionT k a c m c mergeT FieldsDefinition cat s x FieldsDefinition cat s y) [(FieldName, FieldDefinition cat s)] -> FieldsDefinition cat s forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a unsafeFromList ((FieldDefinition cat s -> FieldDefinition cat s -> m (FieldDefinition cat s)) -> NonEmpty (FieldDefinition cat s) -> m (FieldDefinition cat s) forall (m :: * -> *) a. Monad m => (a -> a -> m a) -> NonEmpty a -> m a resolveWith FieldDefinition cat s -> FieldDefinition cat s -> m (FieldDefinition cat s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch) instance Stitching (FieldDefinition cat s) where stitch :: FieldDefinition cat s -> FieldDefinition cat s -> m (FieldDefinition cat s) stitch FieldDefinition cat s old FieldDefinition cat s new | FieldDefinition cat s old FieldDefinition cat s -> FieldDefinition cat s -> Bool forall a. Eq a => a -> a -> Bool == FieldDefinition cat s new = FieldDefinition cat s -> m (FieldDefinition cat s) forall (f :: * -> *) a. Applicative f => a -> f a pure FieldDefinition cat s old | Bool otherwise = GQLError -> m (FieldDefinition cat s) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> m (FieldDefinition cat s)) -> GQLError -> m (FieldDefinition cat s) forall a b. (a -> b) -> a -> b $ FieldDefinition cat s -> GQLError forall e a. NameCollision e a => a -> e nameCollision FieldDefinition cat s new rootProp :: (Monad m, Merge m b) => (a -> m b) -> a -> a -> m b rootProp :: (a -> m b) -> a -> a -> m b rootProp a -> m b f a x a y = do b x' <- a -> m b f a x b y' <- a -> m b f a y b -> b -> m b forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a merge b x' b y' stitchSubscriptions :: MonadError GQLError m => Maybe a -> Maybe a -> m (Maybe a) stitchSubscriptions :: Maybe a -> Maybe a -> m (Maybe a) stitchSubscriptions Just {} Just {} = GQLError -> m (Maybe a) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError "can't merge subscription applications" :: GQLError) stitchSubscriptions Maybe a x Maybe a Nothing = Maybe a -> m (Maybe a) forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe a x stitchSubscriptions Maybe a Nothing Maybe a x = Maybe a -> m (Maybe a) forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe a x instance Stitching (R.ObjectTypeResolver m) where stitch :: ObjectTypeResolver m -> ObjectTypeResolver m -> m (ObjectTypeResolver m) stitch ObjectTypeResolver m t1 ObjectTypeResolver m t2 = ObjectTypeResolver m -> m (ObjectTypeResolver m) forall (f :: * -> *) a. Applicative f => a -> f a pure (ObjectTypeResolver m -> m (ObjectTypeResolver m)) -> ObjectTypeResolver m -> m (ObjectTypeResolver m) forall a b. (a -> b) -> a -> b $ HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m forall (m :: * -> *). HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m R.ObjectTypeResolver (ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m)) forall (m :: * -> *). ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m)) R.objectFields ObjectTypeResolver m t1 HashMap FieldName (m (ResolverValue m)) -> HashMap FieldName (m (ResolverValue m)) -> HashMap FieldName (m (ResolverValue m)) forall a. Semigroup a => a -> a -> a <> ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m)) forall (m :: * -> *). ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m)) R.objectFields ObjectTypeResolver m t2) instance (MonadError GQLError m) => Stitching (NamedResolverResult m) where stitch :: NamedResolverResult m -> NamedResolverResult m -> m (NamedResolverResult m) stitch NamedEnumResolver {} (NamedEnumResolver TypeName x) = NamedResolverResult m -> m (NamedResolverResult m) forall (f :: * -> *) a. Applicative f => a -> f a pure (TypeName -> NamedResolverResult m forall (m :: * -> *). TypeName -> NamedResolverResult m NamedEnumResolver TypeName x) stitch NamedUnionResolver {} (NamedUnionResolver NamedResolverRef x) = NamedResolverResult m -> m (NamedResolverResult m) forall (f :: * -> *) a. Applicative f => a -> f a pure (NamedResolverRef -> NamedResolverResult m forall (m :: * -> *). NamedResolverRef -> NamedResolverResult m NamedUnionResolver NamedResolverRef x) stitch (NamedObjectResolver ObjectTypeResolver m t1) (NamedObjectResolver ObjectTypeResolver m t2) = ObjectTypeResolver m -> NamedResolverResult m forall (m :: * -> *). ObjectTypeResolver m -> NamedResolverResult m NamedObjectResolver (ObjectTypeResolver m -> NamedResolverResult m) -> m (ObjectTypeResolver m) -> m (NamedResolverResult m) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ObjectTypeResolver m -> ObjectTypeResolver m -> m (ObjectTypeResolver m) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch ObjectTypeResolver m t1 ObjectTypeResolver m t2 stitch NamedResolverResult m _ NamedResolverResult m _ = GQLError -> m (NamedResolverResult m) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError GQLError "ResolverMap must have same Kind" instance (MonadError GQLError m) => Stitching (NamedResolver m) where stitch :: NamedResolver m -> NamedResolver m -> m (NamedResolver m) stitch NamedResolver m t1 NamedResolver m t2 | NamedResolver m -> TypeName forall (m :: * -> *). NamedResolver m -> TypeName resolverName NamedResolver m t1 TypeName -> TypeName -> Bool forall a. Eq a => a -> a -> Bool == NamedResolver m -> TypeName forall (m :: * -> *). NamedResolver m -> TypeName resolverName NamedResolver m t2 = NamedResolver m -> m (NamedResolver m) forall (f :: * -> *) a. Applicative f => a -> f a pure NamedResolver :: forall (m :: * -> *). TypeName -> (ValidValue -> m (NamedResolverResult m)) -> NamedResolver m NamedResolver { resolverName :: TypeName resolverName = NamedResolver m -> TypeName forall (m :: * -> *). NamedResolver m -> TypeName resolverName NamedResolver m t1, resolver :: ValidValue -> m (NamedResolverResult m) resolver = \ValidValue arg -> do NamedResolverResult m t1' <- NamedResolver m -> ValidValue -> m (NamedResolverResult m) forall (m :: * -> *). NamedResolver m -> ValidValue -> m (NamedResolverResult m) resolver NamedResolver m t1 ValidValue arg NamedResolverResult m t2' <- NamedResolver m -> ValidValue -> m (NamedResolverResult m) forall (m :: * -> *). NamedResolver m -> ValidValue -> m (NamedResolverResult m) resolver NamedResolver m t2 ValidValue arg NamedResolverResult m -> NamedResolverResult m -> m (NamedResolverResult m) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch NamedResolverResult m t1' NamedResolverResult m t2' } | Bool otherwise = GQLError -> m (NamedResolver m) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError GQLError "ResolverMap must have same resolverName" instance Monad m => Stitching (RootResolverValue e m) where stitch :: RootResolverValue e m -> RootResolverValue e m -> m (RootResolverValue e m) stitch x :: RootResolverValue e m x@RootResolverValue {} y :: RootResolverValue e m y@RootResolverValue {} = do Maybe (Selection VALID -> ResolverState (Channel e)) channelMap <- Maybe (Selection VALID -> ResolverState (Channel e)) -> Maybe (Selection VALID -> ResolverState (Channel e)) -> m (Maybe (Selection VALID -> ResolverState (Channel e))) forall (m :: * -> *) a. MonadError GQLError m => Maybe a -> Maybe a -> m (Maybe a) stitchSubscriptions (RootResolverValue e m -> Maybe (Selection VALID -> ResolverState (Channel e)) forall e (m :: * -> *). RootResolverValue e m -> Maybe (Selection VALID -> ResolverState (Channel e)) channelMap RootResolverValue e m x) (RootResolverValue e m -> Maybe (Selection VALID -> ResolverState (Channel e)) forall e (m :: * -> *). RootResolverValue e m -> Maybe (Selection VALID -> ResolverState (Channel e)) channelMap RootResolverValue e m y) RootResolverValue e m -> m (RootResolverValue e m) forall (f :: * -> *) a. Applicative f => a -> f a pure (RootResolverValue e m -> m (RootResolverValue e m)) -> RootResolverValue e m -> m (RootResolverValue e m) forall a b. (a -> b) -> a -> b $ RootResolverValue :: forall e (m :: * -> *). ResolverState (ObjectTypeResolver (Resolver QUERY e m)) -> ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) -> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) -> Maybe (Selection VALID -> ResolverState (Channel e)) -> RootResolverValue e m RootResolverValue { queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m)) queryResolver = (RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver QUERY e m))) -> RootResolverValue e m -> RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver QUERY e m)) forall (m :: * -> *) b a. (Monad m, Merge m b) => (a -> m b) -> a -> a -> m b rootProp RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver QUERY e m)) forall e (m :: * -> *). RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver QUERY e m)) queryResolver RootResolverValue e m x RootResolverValue e m y, mutationResolver :: ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) mutationResolver = (RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver MUTATION e m))) -> RootResolverValue e m -> RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) forall (m :: * -> *) b a. (Monad m, Merge m b) => (a -> m b) -> a -> a -> m b rootProp RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) forall e (m :: * -> *). RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) mutationResolver RootResolverValue e m x RootResolverValue e m y, subscriptionResolver :: ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) subscriptionResolver = (RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))) -> RootResolverValue e m -> RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) forall (m :: * -> *) b a. (Monad m, Merge m b) => (a -> m b) -> a -> a -> m b rootProp RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) forall e (m :: * -> *). RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) subscriptionResolver RootResolverValue e m x RootResolverValue e m y, Maybe (Selection VALID -> ResolverState (Channel e)) channelMap :: Maybe (Selection VALID -> ResolverState (Channel e)) channelMap :: Maybe (Selection VALID -> ResolverState (Channel e)) channelMap } stitch NamedResolversValue { queryResolverMap :: forall e (m :: * -> *). RootResolverValue e m -> ResolverMap (Resolver QUERY e m) queryResolverMap = ResolverMap (Resolver QUERY e m) q1 } NamedResolversValue { queryResolverMap :: forall e (m :: * -> *). RootResolverValue e m -> ResolverMap (Resolver QUERY e m) queryResolverMap = ResolverMap (Resolver QUERY e m) q2 } = do ResolverMap (Resolver QUERY e m) result <- ResolutionT TypeName (NamedResolver (Resolver QUERY e m)) (ResolverMap (Resolver QUERY e m)) m (ResolverMap (Resolver QUERY e m)) -> ([(TypeName, NamedResolver (Resolver QUERY e m))] -> ResolverMap (Resolver QUERY e m)) -> (NonEmpty (NamedResolver (Resolver QUERY e m)) -> m (NamedResolver (Resolver QUERY e m))) -> m (ResolverMap (Resolver QUERY e m)) forall k a coll (m :: * -> *) b. ResolutionT k a coll m b -> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b runResolutionT (ResolverMap (Resolver QUERY e m) -> ResolverMap (Resolver QUERY e m) -> ResolutionT TypeName (NamedResolver (Resolver QUERY e m)) (ResolverMap (Resolver QUERY e m)) m (ResolverMap (Resolver QUERY e m)) forall k a (t :: * -> *) (m :: * -> *) c. (KeyOf k a, Foldable t, Monad m) => t a -> t a -> ResolutionT k a c m c mergeT ResolverMap (Resolver QUERY e m) q1 ResolverMap (Resolver QUERY e m) q2) [(TypeName, NamedResolver (Resolver QUERY e m))] -> ResolverMap (Resolver QUERY e m) forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a unsafeFromList ((NamedResolver (Resolver QUERY e m) -> NamedResolver (Resolver QUERY e m) -> m (NamedResolver (Resolver QUERY e m))) -> NonEmpty (NamedResolver (Resolver QUERY e m)) -> m (NamedResolver (Resolver QUERY e m)) forall (m :: * -> *) a. Monad m => (a -> a -> m a) -> NonEmpty a -> m a resolveWith NamedResolver (Resolver QUERY e m) -> NamedResolver (Resolver QUERY e m) -> m (NamedResolver (Resolver QUERY e m)) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch) RootResolverValue e m -> m (RootResolverValue e m) forall (f :: * -> *) a. Applicative f => a -> f a pure (NamedResolversValue :: forall e (m :: * -> *). ResolverMap (Resolver QUERY e m) -> RootResolverValue e m NamedResolversValue {queryResolverMap :: ResolverMap (Resolver QUERY e m) queryResolverMap = ResolverMap (Resolver QUERY e m) result}) stitch RootResolverValue e m _ RootResolverValue e m _ = GQLError -> m (RootResolverValue e m) forall e (m :: * -> *) a. MonadError e m => e -> m a throwError GQLError "only apps with same resolver model can be merged"