{-# 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"