Stitching.hs

{-# 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
  ( DirectiveDefinition,
    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 err p1 p2
  | p1 == p2 = pure p2
  | otherwise = throwError err

fstM :: Applicative m => a -> a -> m a
fstM x _ = pure x

concatM :: (Applicative m, Semigroup a) => a -> a -> m a
concatM x = pure . (x <>)

class Stitching a where
  stitch :: (Monad m, MonadError GQLError m) => a -> a -> m a

instance Stitching a => Stitching (Maybe a) where
  stitch = optional stitch

instance Stitching (Schema s) where
  stitch s1 s2 =
    Schema
      <$> prop stitch types s1 s2
      <*> prop stitchOperation query s1 s2
      <*> prop (optional stitchOperation) mutation s1 s2
      <*> prop (optional stitchOperation) subscription s1 s2
      <*> prop stitch directiveDefinitions s1 s2

instance Stitching (TypeDefinitions s) where
  stitch x y = runResolutionT (mergeT x y) unsafeFromList (resolveWith stitch)

instance Stitching (DirectivesDefinition s) where
  stitch x y = runResolutionT (mergeT x y) unsafeFromList (resolveWith stitch)

instance Stitching (Directives s) where
  stitch = merge

optional :: Applicative f => (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t)
optional _ Nothing y = pure y
optional _ (Just x) Nothing = pure (Just x)
optional f (Just x) (Just y) = Just <$> f x y

stitchOperation ::
  (Monad m, MonadError GQLError m) =>
  TypeDefinition c s ->
  TypeDefinition c s ->
  m (TypeDefinition c s)
stitchOperation x y =
  TypeDefinition
    <$> prop concatM typeDescription x y
    <*> prop fstM typeName x y
    <*> prop stitch typeDirectives x y
    <*> prop stitch typeContent x y

instance Stitching (DirectiveDefinition s) where
  stitch x y
    | x == y = pure x
    | otherwise = throwError "only directives with same structure can be merged"

instance Stitching (TypeDefinition cat s) where
  stitch x y =
    TypeDefinition
      <$> prop concatM typeDescription x y
      <*> prop (equal $ nameCollision y) typeName x y
      <*> prop stitch typeDirectives x y
      <*> prop stitch typeContent x y

instance Stitching (TypeContent TRUE cat s) where
  stitch (DataObject i1 fields1) (DataObject i2 fields2) =
    DataObject (i1 <> i2) <$> stitch fields1 fields2
  stitch x y
    | x == y = pure y
    | otherwise = throwError ("Schema Stitching works only for objects" :: GQLError)

instance Stitching (FieldsDefinition cat s) where
  stitch x y = runResolutionT (mergeT x y) unsafeFromList (resolveWith stitch)

instance Stitching (FieldDefinition cat s) where
  stitch old new
    | old == new = pure old
    | otherwise = throwError $ nameCollision new

rootProp :: (Monad m, Merge m b) => (a -> m b) -> a -> a -> m b
rootProp f x y = do
  x' <- f x
  y' <- f y
  merge x' y'

stitchSubscriptions :: MonadError GQLError m => Maybe a -> Maybe a -> m (Maybe a)
stitchSubscriptions Just {} Just {} = throwError ("can't merge  subscription applications" :: GQLError)
stitchSubscriptions x Nothing = pure x
stitchSubscriptions Nothing x = pure x

instance Stitching (R.ObjectTypeResolver m) where
  stitch t1 t2 = pure $ R.ObjectTypeResolver (R.objectFields t1 <> R.objectFields t2)

instance (MonadError GQLError m) => Stitching (NamedResolverResult m) where
  stitch NamedEnumResolver {} (NamedEnumResolver x) = pure (NamedEnumResolver x)
  stitch NamedUnionResolver {} (NamedUnionResolver x) = pure (NamedUnionResolver x)
  stitch (NamedObjectResolver t1) (NamedObjectResolver t2) = NamedObjectResolver <$> stitch t1 t2
  stitch NamedNullResolver x = pure x
  stitch x NamedNullResolver = pure x
  stitch _ _ = throwError "ResolverMap must have same Kind"

instance (MonadError GQLError m) => Stitching (NamedResolver m) where
  stitch t1 t2
    | resolverName t1 == resolverName t2 =
        pure
          NamedResolver
            { resolverName = resolverName t1,
              resolverFun = \arg -> do
                t1' <- resolverFun t1 arg
                t2' <- resolverFun t2 arg
                let xs = zip t1' t2'
                traverse (uncurry stitch) xs
            }
    | otherwise = throwError "ResolverMap must have same resolverName"

instance Monad m => Stitching (RootResolverValue e m) where
  stitch x@RootResolverValue {} y@RootResolverValue {} = do
    channelMap <- stitchSubscriptions (channelMap x) (channelMap y)
    pure $
      RootResolverValue
        { queryResolver = rootProp queryResolver x y,
          mutationResolver = rootProp mutationResolver x y,
          subscriptionResolver = rootProp subscriptionResolver x y,
          channelMap
        }
  stitch
    NamedResolversValue
      { queryResolverMap = q1
      }
    NamedResolversValue
      { queryResolverMap = q2
      } =
      do
        result <- runResolutionT (mergeT q1 q2) unsafeFromList (resolveWith stitch)
        pure (NamedResolversValue {queryResolverMap = result})
  stitch _ _ = throwError "only apps with same resolver model can be merged"