{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Types.SchemaT
( SchemaT,
updateSchema,
insertType,
TypeFingerprint (..),
toSchema,
withInput,
extendImplements,
insertDirectiveDefinition,
outToAny,
)
where
import Control.Monad.Except (MonadError (..))
import qualified Data.Map as Map
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Server.Types.TypeName
import Data.Morpheus.Types.Internal.AST
( ANY,
CONST,
DirectiveDefinition,
GQLError,
IN,
OBJECT,
OUT,
Schema,
TypeCategory (..),
TypeContent (..),
TypeDefinition (..),
TypeName,
defineDirective,
defineSchemaWith,
msg,
toAny,
)
import Relude hiding (empty)
data SchemaState where
SchemaState ::
{ SchemaState -> Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST),
SchemaState -> Map TypeName [TypeName]
implements :: Map TypeName [TypeName],
SchemaState -> Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)
} ->
SchemaState
emptyMyMap :: SchemaState
emptyMyMap :: SchemaState
emptyMyMap =
SchemaState
{ typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions = forall k a. Map k a
Map.empty,
implements :: Map TypeName [TypeName]
implements = forall k a. Map k a
Map.empty,
directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions = forall k a. Map k a
Map.empty
}
newtype SchemaT (cat :: TypeCategory) a = SchemaT
{ forall (cat :: TypeCategory) a.
SchemaT cat a
-> GQLResult (a, [SchemaState -> GQLResult SchemaState])
runSchemaT ::
GQLResult
( a,
[SchemaState -> GQLResult SchemaState]
)
}
deriving (forall a b. a -> SchemaT cat b -> SchemaT cat a
forall a b. (a -> b) -> SchemaT cat a -> SchemaT cat b
forall (cat :: TypeCategory) a b.
a -> SchemaT cat b -> SchemaT cat a
forall (cat :: TypeCategory) a b.
(a -> b) -> SchemaT cat a -> SchemaT cat b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> SchemaT cat b -> SchemaT cat a
$c<$ :: forall (cat :: TypeCategory) a b.
a -> SchemaT cat b -> SchemaT cat a
fmap :: forall a b. (a -> b) -> SchemaT cat a -> SchemaT cat b
$cfmap :: forall (cat :: TypeCategory) a b.
(a -> b) -> SchemaT cat a -> SchemaT cat b
Functor)
instance MonadError GQLError (SchemaT c) where
throwError :: forall a. GQLError -> SchemaT c a
throwError = forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
catchError :: forall a. SchemaT c a -> (GQLError -> SchemaT c a) -> SchemaT c a
catchError (SchemaT GQLResult (a, [SchemaState -> GQLResult SchemaState])
mx) GQLError -> SchemaT c a
f = forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT (forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError GQLResult (a, [SchemaState -> GQLResult SchemaState])
mx (forall (cat :: TypeCategory) a.
SchemaT cat a
-> GQLResult (a, [SchemaState -> GQLResult SchemaState])
runSchemaT forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> SchemaT c a
f))
instance Applicative (SchemaT c) where
pure :: forall a. a -> SchemaT c a
pure = forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,[])
(SchemaT GQLResult (a -> b, [SchemaState -> GQLResult SchemaState])
v1) <*> :: forall a b. SchemaT c (a -> b) -> SchemaT c a -> SchemaT c b
<*> (SchemaT GQLResult (a, [SchemaState -> GQLResult SchemaState])
v2) = forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT forall a b. (a -> b) -> a -> b
$ do
(a -> b
f, [SchemaState -> GQLResult SchemaState]
u1) <- GQLResult (a -> b, [SchemaState -> GQLResult SchemaState])
v1
(a
a, [SchemaState -> GQLResult SchemaState]
u2) <- GQLResult (a, [SchemaState -> GQLResult SchemaState])
v2
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
a, [SchemaState -> GQLResult SchemaState]
u1 forall a. Semigroup a => a -> a -> a
<> [SchemaState -> GQLResult SchemaState]
u2)
instance Monad (SchemaT c) where
return :: forall a. a -> SchemaT c a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
(SchemaT GQLResult (a, [SchemaState -> GQLResult SchemaState])
v1) >>= :: forall a b. SchemaT c a -> (a -> SchemaT c b) -> SchemaT c b
>>= a -> SchemaT c b
f =
forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT forall a b. (a -> b) -> a -> b
$ do
(a
x, [SchemaState -> GQLResult SchemaState]
up1) <- GQLResult (a, [SchemaState -> GQLResult SchemaState])
v1
(b
y, [SchemaState -> GQLResult SchemaState]
up2) <- forall (cat :: TypeCategory) a.
SchemaT cat a
-> GQLResult (a, [SchemaState -> GQLResult SchemaState])
runSchemaT (a -> SchemaT c b
f a
x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
y, [SchemaState -> GQLResult SchemaState]
up1 forall a. Semigroup a => a -> a -> a
<> [SchemaState -> GQLResult SchemaState]
up2)
toSchema ::
SchemaT
c
( TypeDefinition OBJECT CONST,
Maybe (TypeDefinition OBJECT CONST),
Maybe (TypeDefinition OBJECT CONST)
) ->
GQLResult (Schema CONST)
toSchema :: forall (c :: TypeCategory).
SchemaT
c
(TypeDefinition OBJECT CONST, Maybe (TypeDefinition OBJECT CONST),
Maybe (TypeDefinition OBJECT CONST))
-> GQLResult (Schema CONST)
toSchema (SchemaT GQLResult
((TypeDefinition OBJECT CONST, Maybe (TypeDefinition OBJECT CONST),
Maybe (TypeDefinition OBJECT CONST)),
[SchemaState -> GQLResult SchemaState])
v) = do
((TypeDefinition OBJECT CONST
q, Maybe (TypeDefinition OBJECT CONST)
m, Maybe (TypeDefinition OBJECT CONST)
s), [SchemaState -> GQLResult SchemaState]
typeDefs) <- GQLResult
((TypeDefinition OBJECT CONST, Maybe (TypeDefinition OBJECT CONST),
Maybe (TypeDefinition OBJECT CONST)),
[SchemaState -> GQLResult SchemaState])
v
SchemaState {Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions :: SchemaState -> Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions, Map TypeName [TypeName]
implements :: Map TypeName [TypeName]
implements :: SchemaState -> Map TypeName [TypeName]
implements, Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions :: SchemaState -> Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions} <- forall (m :: * -> *) a. Monad m => a -> [a -> m a] -> m a
execUpdates SchemaState
emptyMyMap [SchemaState -> GQLResult SchemaState]
typeDefs
[TypeDefinition ANY CONST]
types <- forall a b. (a -> b) -> [a] -> [b]
map (forall (c :: TypeCategory).
Map TypeName [TypeName]
-> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements Map TypeName [TypeName]
implements) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (k :: TypeCategory) (a :: Stage).
[(TypeFingerprint, TypeDefinition k a)]
-> GQLResult [TypeDefinition k a]
checkTypeCollisions (forall k a. Map k a -> [(k, a)]
Map.toList Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions)
Schema CONST
schema <- forall (f :: * -> *) (cat :: TypeCategory) (s :: Stage).
(Monad f, MonadError GQLError f) =>
[TypeDefinition cat s]
-> (Maybe (TypeDefinition OBJECT s),
Maybe (TypeDefinition OBJECT s), Maybe (TypeDefinition OBJECT s))
-> f (Schema s)
defineSchemaWith [TypeDefinition ANY CONST]
types (forall a. a -> Maybe a
Just TypeDefinition OBJECT CONST
q, Maybe (TypeDefinition OBJECT CONST)
m, Maybe (TypeDefinition OBJECT CONST)
s)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM forall (m :: * -> *) (s :: Stage).
(Monad m, MonadError GQLError m) =>
Schema s -> DirectiveDefinition s -> m (Schema s)
defineDirective Schema CONST
schema Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions
insertImplements :: Map TypeName [TypeName] -> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements :: forall (c :: TypeCategory).
Map TypeName [TypeName]
-> TypeDefinition c CONST -> TypeDefinition c CONST
insertImplements Map TypeName [TypeName]
x TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {[TypeName]
FieldsDefinition OUT CONST
objectImplements :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> [TypeName]
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT CONST
objectImplements :: [TypeName]
..}, Maybe Description
TypeName
Directives CONST
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeDirectives :: Directives CONST
typeName :: TypeName
typeDescription :: Maybe Description
..} =
TypeDefinition
{ typeContent :: TypeContent TRUE c CONST
typeContent =
DataObject
{ objectImplements :: [TypeName]
objectImplements = [TypeName]
objectImplements forall a. Semigroup a => a -> a -> a
<> [TypeName]
implements,
FieldsDefinition OUT CONST
objectFields :: FieldsDefinition OUT CONST
objectFields :: FieldsDefinition OUT CONST
..
},
Maybe Description
TypeName
Directives CONST
typeDescription :: Maybe Description
typeName :: TypeName
typeDirectives :: Directives CONST
typeDirectives :: Directives CONST
typeName :: TypeName
typeDescription :: Maybe Description
..
}
where
implements :: [TypeName]
implements :: [TypeName]
implements = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] TypeName
typeName Map TypeName [TypeName]
x
insertImplements Map TypeName [TypeName]
_ TypeDefinition c CONST
t = TypeDefinition c CONST
t
withInput :: SchemaT IN a -> SchemaT OUT a
withInput :: forall a. SchemaT IN a -> SchemaT OUT a
withInput (SchemaT GQLResult (a, [SchemaState -> GQLResult SchemaState])
x) = forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT GQLResult (a, [SchemaState -> GQLResult SchemaState])
x
outToAny :: SchemaT OUT a -> SchemaT k' a
outToAny :: forall a (k' :: TypeCategory). SchemaT OUT a -> SchemaT k' a
outToAny (SchemaT GQLResult (a, [SchemaState -> GQLResult SchemaState])
x) = forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT GQLResult (a, [SchemaState -> GQLResult SchemaState])
x
checkTypeCollisions :: [(TypeFingerprint, TypeDefinition k a)] -> GQLResult [TypeDefinition k a]
checkTypeCollisions :: forall (k :: TypeCategory) (a :: Stage).
[(TypeFingerprint, TypeDefinition k a)]
-> GQLResult [TypeDefinition k a]
checkTypeCollisions = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM forall (k :: TypeCategory) (a :: Stage).
Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> (TypeFingerprint, TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
collectTypes forall k a. Map k a
Map.empty
where
collectTypes :: Map (TypeName, TypeFingerprint) (TypeDefinition k a) -> (TypeFingerprint, TypeDefinition k a) -> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
collectTypes :: forall (k :: TypeCategory) (a :: Stage).
Map (TypeName, TypeFingerprint) (TypeDefinition k a)
-> (TypeFingerprint, TypeDefinition k a)
-> GQLResult (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
collectTypes Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum (TypeFingerprint
fp, TypeDefinition k a
typ) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Result
GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
addType (TypeDefinition k a
-> TypeDefinition k a
-> Result
GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
handleCollision TypeDefinition k a
typ) ((TypeName, TypeFingerprint)
key forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum)
where
addType :: Result
GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
addType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TypeName, TypeFingerprint)
key TypeDefinition k a
typ Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum
key :: (TypeName, TypeFingerprint)
key = (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition k a
typ, TypeFingerprint -> TypeFingerprint
withSameCategory TypeFingerprint
fp)
handleCollision :: TypeDefinition k a
-> TypeDefinition k a
-> Result
GQLError (Map (TypeName, TypeFingerprint) (TypeDefinition k a))
handleCollision t1 :: TypeDefinition k a
t1@TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataEnum {}} TypeDefinition k a
t2 | TypeDefinition k a
t1 forall a. Eq a => a -> a -> Bool
== TypeDefinition k a
t2 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum
handleCollision TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataScalar {}} TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataScalar {}} = forall (f :: * -> *) a. Applicative f => a -> f a
pure Map (TypeName, TypeFingerprint) (TypeDefinition k a)
accum
handleCollision TypeDefinition {typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName = TypeName
name1} TypeDefinition k a
_ = forall b. TypeName -> GQLResult b
failureRequirePrefix TypeName
name1
failureRequirePrefix :: TypeName -> GQLResult b
failureRequirePrefix :: forall b. TypeName -> GQLResult b
failureRequirePrefix TypeName
typename =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
GQLError
"It appears that the Haskell type "
forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
typename
forall a. Semigroup a => a -> a -> a
<> GQLError
" was used as both input and output type, which is not allowed by GraphQL specifications."
forall a. Semigroup a => a -> a -> a
<> GQLError
"\n\n "
forall a. Semigroup a => a -> a -> a
<> GQLError
"If you supply \"typeNameModifier\" in \"GQLType.typeOptions\", "
forall a. Semigroup a => a -> a -> a
<> GQLError
"you can override the default type names for "
forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
typename
forall a. Semigroup a => a -> a -> a
<> GQLError
" to solve this problem."
withSameCategory :: TypeFingerprint -> TypeFingerprint
withSameCategory :: TypeFingerprint -> TypeFingerprint
withSameCategory (TypeableFingerprint TypeCategory
_ [Fingerprint]
xs) = TypeCategory -> [Fingerprint] -> TypeFingerprint
TypeableFingerprint TypeCategory
OUT [Fingerprint]
xs
withSameCategory TypeFingerprint
x = TypeFingerprint
x
execUpdates :: Monad m => a -> [a -> m a] -> m a
execUpdates :: forall (m :: * -> *) a. Monad m => a -> [a -> m a] -> m a
execUpdates = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM forall a b. a -> (a -> b) -> b
(&)
insertType :: TypeDefinition cat CONST -> SchemaT cat' ()
insertType :: forall (cat :: TypeCategory) (cat' :: TypeCategory).
TypeDefinition cat CONST -> SchemaT cat' ()
insertType TypeDefinition cat CONST
dt = forall a (cat' :: TypeCategory) (cat :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (TypeDefinition cat CONST))
-> a
-> SchemaT cat' ()
updateSchema (TypeName -> TypeFingerprint
CustomFingerprint (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition cat CONST
dt)) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition cat CONST
dt) ()
updateSchema ::
TypeFingerprint ->
(a -> SchemaT cat' (TypeDefinition cat CONST)) ->
a ->
SchemaT cat' ()
updateSchema :: forall a (cat' :: TypeCategory) (cat :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (TypeDefinition cat CONST))
-> a
-> SchemaT cat' ()
updateSchema InternalFingerprint {} a -> SchemaT cat' (TypeDefinition cat CONST)
_ a
_ = forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [])
updateSchema TypeFingerprint
fingerprint a -> SchemaT cat' (TypeDefinition cat CONST)
f a
x =
forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [SchemaState -> GQLResult SchemaState
upLib])
where
upLib :: SchemaState -> GQLResult SchemaState
upLib :: SchemaState -> GQLResult SchemaState
upLib SchemaState
schema
| forall k a. Ord k => k -> Map k a -> Bool
Map.member TypeFingerprint
fingerprint (SchemaState -> Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions SchemaState
schema) = forall (f :: * -> *) a. Applicative f => a -> f a
pure SchemaState
schema
| Bool
otherwise = do
(TypeDefinition cat CONST
type', [SchemaState -> GQLResult SchemaState]
updates) <- forall (cat :: TypeCategory) a.
SchemaT cat a
-> GQLResult (a, [SchemaState -> GQLResult SchemaState])
runSchemaT (a -> SchemaT cat' (TypeDefinition cat CONST)
f a
x)
forall (m :: * -> *) a. Monad m => a -> [a -> m a] -> m a
execUpdates SchemaState
schema (TypeDefinition cat CONST -> SchemaState -> GQLResult SchemaState
update TypeDefinition cat CONST
type' forall a. a -> [a] -> [a]
: [SchemaState -> GQLResult SchemaState]
updates)
where
update :: TypeDefinition cat CONST -> SchemaState -> GQLResult SchemaState
update TypeDefinition cat CONST
t SchemaState
schemaState =
forall (f :: * -> *) a. Applicative f => a -> f a
pure
SchemaState
schemaState
{ typeDefinitions :: Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeFingerprint
fingerprint (forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
(s :: Stage).
ToCategory a k ANY =>
a k s -> a ANY s
toAny TypeDefinition cat CONST
t) (SchemaState -> Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions SchemaState
schemaState)
}
insertDirectiveDefinition ::
TypeFingerprint ->
(a -> SchemaT cat' (DirectiveDefinition CONST)) ->
a ->
SchemaT cat' ()
insertDirectiveDefinition :: forall a (cat' :: TypeCategory).
TypeFingerprint
-> (a -> SchemaT cat' (DirectiveDefinition CONST))
-> a
-> SchemaT cat' ()
insertDirectiveDefinition InternalFingerprint {} a -> SchemaT cat' (DirectiveDefinition CONST)
_ a
_ = forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [])
insertDirectiveDefinition TypeFingerprint
fingerprint a -> SchemaT cat' (DirectiveDefinition CONST)
f a
x =
forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [SchemaState -> GQLResult SchemaState
upLib])
where
upLib :: SchemaState -> GQLResult SchemaState
upLib :: SchemaState -> GQLResult SchemaState
upLib SchemaState
schema
| forall k a. Ord k => k -> Map k a -> Bool
Map.member TypeFingerprint
fingerprint (SchemaState -> Map TypeFingerprint (TypeDefinition ANY CONST)
typeDefinitions SchemaState
schema) = forall (f :: * -> *) a. Applicative f => a -> f a
pure SchemaState
schema
| Bool
otherwise = do
(DirectiveDefinition CONST
type', [SchemaState -> GQLResult SchemaState]
updates) <- forall (cat :: TypeCategory) a.
SchemaT cat a
-> GQLResult (a, [SchemaState -> GQLResult SchemaState])
runSchemaT (a -> SchemaT cat' (DirectiveDefinition CONST)
f a
x)
forall (m :: * -> *) a. Monad m => a -> [a -> m a] -> m a
execUpdates SchemaState
schema (DirectiveDefinition CONST -> SchemaState -> GQLResult SchemaState
update DirectiveDefinition CONST
type' forall a. a -> [a] -> [a]
: [SchemaState -> GQLResult SchemaState]
updates)
where
update :: DirectiveDefinition CONST -> SchemaState -> GQLResult SchemaState
update DirectiveDefinition CONST
t SchemaState
schemaState =
forall (f :: * -> *) a. Applicative f => a -> f a
pure
SchemaState
schemaState
{ directiveDefinitions :: Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TypeFingerprint
fingerprint DirectiveDefinition CONST
t (SchemaState -> Map TypeFingerprint (DirectiveDefinition CONST)
directiveDefinitions SchemaState
schemaState)
}
extendImplements :: TypeName -> [TypeName] -> SchemaT cat' ()
extendImplements :: forall (cat' :: TypeCategory).
TypeName -> [TypeName] -> SchemaT cat' ()
extendImplements TypeName
interface [TypeName]
types = forall (cat :: TypeCategory) a.
GQLResult (a, [SchemaState -> GQLResult SchemaState])
-> SchemaT cat a
SchemaT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ((), [SchemaState -> GQLResult SchemaState
upLib])
where
upLib :: SchemaState -> GQLResult SchemaState
upLib :: SchemaState -> GQLResult SchemaState
upLib SchemaState
schema = forall (f :: * -> *) a. Applicative f => a -> f a
pure SchemaState
schema {implements :: Map TypeName [TypeName]
implements = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]
insertInterface (SchemaState -> Map TypeName [TypeName]
implements SchemaState
schema) [TypeName]
types}
insertInterface :: TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]
insertInterface :: TypeName -> Map TypeName [TypeName] -> Map TypeName [TypeName]
insertInterface = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeName
interface forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe [])