{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Types.SchemaT
( SchemaT,
closeWith,
updateSchema,
insertType,
setMutation,
setSubscription,
)
where
import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..), foldM)
import Data.Function ((&))
import Data.Functor (Functor (..))
import Data.Morpheus.Error (nameCollisionError)
import Data.Morpheus.Internal.Utils
( Failure (..),
)
import Data.Morpheus.Types.Internal.AST
( CONST,
DataFingerprint,
OBJECT,
Schema (..),
TypeContent (..),
TypeDefinition (..),
TypeName (..),
isNotSystemTypeName,
isTypeDefined,
safeDefineType,
)
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
)
import Data.Semigroup (Semigroup (..))
import Prelude
( ($),
(.),
Eq (..),
Maybe (..),
const,
null,
otherwise,
uncurry,
)
newtype SchemaT a = SchemaT
{ runSchemaT ::
Eventless
( a,
[Schema CONST -> Eventless (Schema CONST)]
)
}
deriving (Functor)
instance
Failure err Eventless =>
Failure err SchemaT
where
failure = SchemaT . failure
instance Applicative SchemaT where
pure = SchemaT . pure . (,[])
(SchemaT v1) <*> (SchemaT v2) =
SchemaT $ do
(f, u1) <- v1
(a, u2) <- v2
pure (f a, u1 <> u2)
instance Monad SchemaT where
return = pure
(SchemaT v1) >>= f =
SchemaT $ do
(x, up1) <- v1
(y, up2) <- runSchemaT (f x)
pure (y, up1 <> up2)
closeWith :: SchemaT (Schema CONST) -> Eventless (Schema CONST)
closeWith (SchemaT v) = v >>= uncurry execUpdates
init :: (Schema CONST -> Eventless (Schema CONST)) -> SchemaT ()
init f = SchemaT $ pure ((), [f])
setMutation :: TypeDefinition OBJECT CONST -> SchemaT ()
setMutation mut = init (\schema -> pure $ schema {mutation = optionalType mut})
setSubscription :: TypeDefinition OBJECT CONST -> SchemaT ()
setSubscription x = init (\schema -> pure $ schema {subscription = optionalType x})
optionalType :: TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST)
optionalType td@TypeDefinition {typeContent = DataObject {objectFields}}
| null objectFields = Nothing
| otherwise = Just td
execUpdates :: Monad m => a -> [a -> m a] -> m a
execUpdates = foldM (&)
insertType ::
TypeDefinition cat CONST ->
SchemaT ()
insertType dt@TypeDefinition {typeName, typeFingerprint} =
updateSchema typeName typeFingerprint (const $ pure dt) ()
updateSchema ::
TypeName ->
DataFingerprint ->
(a -> SchemaT (TypeDefinition cat CONST)) ->
a ->
SchemaT ()
updateSchema typeName typeFingerprint f x
| isNotSystemTypeName typeName = SchemaT (pure ((), [upLib]))
| otherwise = SchemaT (pure ((), []))
where
upLib :: Schema CONST -> Eventless (Schema CONST)
upLib lib = case isTypeDefined typeName lib of
Nothing -> do
(tyDef, updater) <- runSchemaT (f x)
execUpdates lib (safeDefineType tyDef : updater)
Just fingerprint'
| fingerprint' == typeFingerprint -> pure lib
| otherwise -> failure [nameCollisionError typeName]