{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Stitching
  ( Stitching (..),
  )
where

import Data.Morpheus.App.Internal.Resolving (RootResolverValue)
import qualified Data.Morpheus.App.Internal.Resolving as R (RootResolverValue (..))
import Data.Morpheus.Error (NameCollision (..))
import Data.Morpheus.Internal.Ext
  ( SemigroupM (..),
    resolveWith,
    runResolutionT,
    unsafeFromList,
  )
import Data.Morpheus.Internal.Utils
  ( Failure (..),
    mergeT,
    prop,
  )
import Data.Morpheus.Types.Internal.AST
  ( Directive,
    DirectiveDefinition,
    FieldDefinition,
    FieldsDefinition,
    Schema (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeLib,
    ValidationErrors,
  )
import Relude hiding (optional)

equal :: (Eq a, Applicative m, Failure ValidationErrors m) => ValidationErrors -> a -> a -> m a
equal :: ValidationErrors -> a -> a -> m a
equal ValidationErrors
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 = ValidationErrors -> m a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure ValidationErrors
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, Failure ValidationErrors 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, Failure ValidationErrors 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 =
    TypeLib s
-> TypeDefinition OBJECT s
-> Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> [DirectiveDefinition s]
-> Schema s
forall (s :: Stage).
TypeLib s
-> TypeDefinition OBJECT s
-> Maybe (TypeDefinition OBJECT s)
-> Maybe (TypeDefinition OBJECT s)
-> [DirectiveDefinition s]
-> Schema s
Schema
      (TypeLib s
 -> TypeDefinition OBJECT s
 -> Maybe (TypeDefinition OBJECT s)
 -> Maybe (TypeDefinition OBJECT s)
 -> [DirectiveDefinition s]
 -> Schema s)
-> m (TypeLib s)
-> m (TypeDefinition OBJECT s
      -> Maybe (TypeDefinition OBJECT s)
      -> Maybe (TypeDefinition OBJECT s)
      -> [DirectiveDefinition s]
      -> Schema s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeLib s -> TypeLib s -> m (TypeLib s))
-> (Schema s -> TypeLib s) -> Schema s -> Schema s -> m (TypeLib s)
forall b (m :: * -> *) a.
(b -> b -> m b) -> (a -> b) -> a -> a -> m b
prop TypeLib s -> TypeLib s -> m (TypeLib s)
forall a (m :: * -> *).
(Stitching a, Monad m, Failure ValidationErrors m) =>
a -> a -> m a
stitch Schema s -> TypeLib s
forall (s :: Stage). Schema s -> TypeLib s
types Schema s
s1 Schema s
s2
      m (TypeDefinition OBJECT s
   -> Maybe (TypeDefinition OBJECT s)
   -> Maybe (TypeDefinition OBJECT s)
   -> [DirectiveDefinition s]
   -> Schema s)
-> m (TypeDefinition OBJECT s)
-> m (Maybe (TypeDefinition OBJECT s)
      -> Maybe (TypeDefinition OBJECT s)
      -> [DirectiveDefinition 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, Failure ValidationErrors 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)
   -> [DirectiveDefinition s]
   -> Schema s)
-> m (Maybe (TypeDefinition OBJECT s))
-> m (Maybe (TypeDefinition OBJECT s)
      -> [DirectiveDefinition 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, Failure ValidationErrors 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)
   -> [DirectiveDefinition s] -> Schema s)
-> m (Maybe (TypeDefinition OBJECT s))
-> m ([DirectiveDefinition 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, Failure ValidationErrors 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 ([DirectiveDefinition s] -> Schema s)
-> m [DirectiveDefinition s] -> m (Schema s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([DirectiveDefinition s]
 -> [DirectiveDefinition s] -> m [DirectiveDefinition s])
-> (Schema s -> [DirectiveDefinition s])
-> Schema s
-> Schema s
-> m [DirectiveDefinition s]
forall b (m :: * -> *) a.
(b -> b -> m b) -> (a -> b) -> a -> a -> m b
prop [DirectiveDefinition s]
-> [DirectiveDefinition s] -> m [DirectiveDefinition s]
forall a (m :: * -> *).
(Stitching a, Monad m, Failure ValidationErrors m) =>
a -> a -> m a
stitch Schema s -> [DirectiveDefinition s]
forall (s :: Stage). Schema s -> [DirectiveDefinition s]
directiveDefinitions Schema s
s1 Schema s
s2

instance Stitching (TypeLib s) where
  stitch :: TypeLib s -> TypeLib s -> m (TypeLib s)
stitch TypeLib s
x TypeLib s
y = ResolutionT
  TypeName (TypeDefinition ANY s) (TypeLib s) m (TypeLib s)
-> ([(TypeName, TypeDefinition ANY s)] -> TypeLib s)
-> (NonEmpty (TypeDefinition ANY s) -> m (TypeDefinition ANY s))
-> m (TypeLib s)
forall k a coll (m :: * -> *) b.
ResolutionT k a coll m b
-> ([(k, a)] -> coll) -> (NonEmpty a -> m a) -> m b
runResolutionT (TypeLib s
-> TypeLib s
-> ResolutionT
     TypeName (TypeDefinition ANY s) (TypeLib s) m (TypeLib s)
forall k a (m :: * -> *) c.
(KeyOf k a, Monad m, Elems a c) =>
c -> c -> ResolutionT k a c m c
mergeT TypeLib s
x TypeLib s
y) [(TypeName, TypeDefinition ANY s)] -> TypeLib s
forall (f :: * -> * -> *) k a.
(UnsafeFromList f, Hashable k, KeyOf k a, Eq k) =>
[(k, a)] -> f k 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, Failure ValidationErrors m) =>
a -> a -> m a
stitch)

instance Stitching [DirectiveDefinition s] where
  stitch :: [DirectiveDefinition s]
-> [DirectiveDefinition s] -> m [DirectiveDefinition s]
stitch = [DirectiveDefinition s]
-> [DirectiveDefinition s] -> m [DirectiveDefinition s]
forall (m :: * -> *) a.
(Applicative m, Semigroup a) =>
a -> a -> m a
concatM

instance Stitching [Directive s] where
  stitch :: [Directive s] -> [Directive s] -> m [Directive s]
stitch = [Directive s] -> [Directive s] -> m [Directive s]
forall (m :: * -> *) a.
(Applicative m, Semigroup a) =>
a -> a -> m a
concatM

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, Failure ValidationErrors 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, Failure ValidationErrors 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, Failure ValidationErrors 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 (ValidationErrors -> TypeName -> TypeName -> m TypeName
forall a (m :: * -> *).
(Eq a, Applicative m, Failure ValidationErrors m) =>
ValidationErrors -> a -> a -> m a
equal [TypeDefinition cat s -> ValidationError
forall a. NameCollision a => a -> ValidationError
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, Failure ValidationErrors 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, Failure ValidationErrors 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, Failure ValidationErrors 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 = ValidationErrors -> m (TypeContent TRUE cat s)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure ([ValidationError
"Schema Stitching works only for objects"] :: ValidationErrors)

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 (m :: * -> *) c.
(KeyOf k a, Monad m, Elems a c) =>
c -> c -> ResolutionT k a c m c
mergeT FieldsDefinition cat s
x FieldsDefinition cat s
y) [(FieldName, FieldDefinition cat s)] -> FieldsDefinition cat s
forall (f :: * -> * -> *) k a.
(UnsafeFromList f, Hashable k, KeyOf k a, Eq k) =>
[(k, a)] -> f k 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, Failure ValidationErrors 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 = ValidationErrors -> m (FieldDefinition cat s)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure [FieldDefinition cat s -> ValidationError
forall a. NameCollision a => a -> ValidationError
nameCollision FieldDefinition cat s
new]

rootProp :: (Monad m, SemigroupM 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
  [Ref FieldName] -> b -> b -> m b
forall (m :: * -> *) a.
SemigroupM m a =>
[Ref FieldName] -> a -> a -> m a
mergeM [] b
x' b
y'

stitchSubscriptions :: Failure ValidationErrors m => Maybe a -> Maybe a -> m (Maybe a)
stitchSubscriptions :: Maybe a -> Maybe a -> m (Maybe a)
stitchSubscriptions Just {} Just {} = ValidationErrors -> m (Maybe a)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure ([ValidationError
"can't merge  subscription applications"] :: ValidationErrors)
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 Monad m => Stitching (RootResolverValue e m) where
  stitch :: RootResolverValue e m
-> RootResolverValue e m -> m (RootResolverValue e m)
stitch RootResolverValue e m
x RootResolverValue e m
y = 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.
Failure ValidationErrors 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))
R.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))
R.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 (ResolverValue (Resolver QUERY e m))
-> ResolverState (ResolverValue (Resolver MUTATION e m))
-> ResolverState (ResolverValue (Resolver SUBSCRIPTION e m))
-> Maybe (Selection VALID -> ResolverState (Channel e))
-> RootResolverValue e m
R.RootResolverValue
        { query :: ResolverState (ResolverValue (Resolver QUERY e m))
R.query = (RootResolverValue e m
 -> ResolverState (ResolverValue (Resolver QUERY e m)))
-> RootResolverValue e m
-> RootResolverValue e m
-> ResolverState (ResolverValue (Resolver QUERY e m))
forall (m :: * -> *) b a.
(Monad m, SemigroupM m b) =>
(a -> m b) -> a -> a -> m b
rootProp RootResolverValue e m
-> ResolverState (ResolverValue (Resolver QUERY e m))
forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ResolverValue (Resolver QUERY e m))
R.query RootResolverValue e m
x RootResolverValue e m
y,
          mutation :: ResolverState (ResolverValue (Resolver MUTATION e m))
R.mutation = (RootResolverValue e m
 -> ResolverState (ResolverValue (Resolver MUTATION e m)))
-> RootResolverValue e m
-> RootResolverValue e m
-> ResolverState (ResolverValue (Resolver MUTATION e m))
forall (m :: * -> *) b a.
(Monad m, SemigroupM m b) =>
(a -> m b) -> a -> a -> m b
rootProp RootResolverValue e m
-> ResolverState (ResolverValue (Resolver MUTATION e m))
forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ResolverValue (Resolver MUTATION e m))
R.mutation RootResolverValue e m
x RootResolverValue e m
y,
          subscription :: ResolverState (ResolverValue (Resolver SUBSCRIPTION e m))
R.subscription = (RootResolverValue e m
 -> ResolverState (ResolverValue (Resolver SUBSCRIPTION e m)))
-> RootResolverValue e m
-> RootResolverValue e m
-> ResolverState (ResolverValue (Resolver SUBSCRIPTION e m))
forall (m :: * -> *) b a.
(Monad m, SemigroupM m b) =>
(a -> m b) -> a -> a -> m b
rootProp RootResolverValue e m
-> ResolverState (ResolverValue (Resolver SUBSCRIPTION e m))
forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ResolverValue (Resolver SUBSCRIPTION e m))
R.subscription 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))
R.channelMap
        }