{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Deriving.Schema
( compileTimeSchemaValidation,
DeriveType,
deriveSchema,
SchemaConstraints,
SchemaT,
)
where
import Control.Monad.Except (throwError)
import Data.Morpheus.App.Internal.Resolving
( Resolver,
)
import Data.Morpheus.Core (defaultConfig, validateSchema)
import Data.Morpheus.Internal.Ext
import Data.Morpheus.Internal.Utils (singleton)
import Data.Morpheus.Kind
( CUSTOM,
DerivingKind,
SCALAR,
TYPE,
WRAPPER,
)
import Data.Morpheus.Server.Deriving.Schema.Internal
( KindedType (..),
TyContentM,
fromSchema,
updateByContent,
)
import Data.Morpheus.Server.Deriving.Schema.Object
( asObjectType,
withObject,
)
import Data.Morpheus.Server.Deriving.Schema.TypeContent
import Data.Morpheus.Server.Deriving.Utils
( TypeConstraint (..),
TypeRep (..),
deriveTypeRef,
symbolName,
toRep,
unpackMonad,
withKind,
)
import Data.Morpheus.Server.Deriving.Utils.Kinded
( CategoryValue (..),
KindedProxy (..),
inputType,
outputType,
setKind,
)
import Data.Morpheus.Server.Types.GQLType
( GQLType (..),
TypeData (..),
__typeData,
)
import Data.Morpheus.Server.Types.SchemaT
( SchemaT,
extendImplements,
toSchema,
withInput,
)
import Data.Morpheus.Server.Types.Types
( Arg (..),
TypeGuard,
)
import Data.Morpheus.Types.GQLScalar
( DecodeScalar (..),
scalarValidator,
)
import Data.Morpheus.Types.Internal.AST
( ArgumentsDefinition,
CONST,
CONST,
FieldContent (..),
FieldContent (..),
FieldsDefinition,
IN,
LEAF,
MUTATION,
OBJECT,
OUT,
QUERY,
SUBSCRIPTION,
Schema (..),
TRUE,
TypeCategory,
TypeContent (..),
TypeDefinition (..),
TypeName,
UnionMember (memberName),
fieldsToArguments,
mkField,
)
import GHC.Generics (Rep)
import GHC.TypeLits
import Language.Haskell.TH (Exp, Q)
import Relude
type SchemaConstraints event (m :: Type -> Type) query mutation subscription =
( DeriveTypeConstraintOpt OUT (query (Resolver QUERY event m)),
DeriveTypeConstraintOpt OUT (mutation (Resolver MUTATION event m)),
DeriveTypeConstraintOpt OUT (subscription (Resolver SUBSCRIPTION event m))
)
type DeriveTypeConstraintOpt kind a =
( Generic a,
GQLType a,
TypeRep (DeriveType kind) (TyContentM kind) (Rep a),
TypeRep (DeriveType kind) (SchemaT kind ()) (Rep a)
)
compileTimeSchemaValidation ::
(SchemaConstraints event m qu mu su) =>
proxy (root m event qu mu su) ->
Q Exp
compileTimeSchemaValidation :: proxy (root m event qu mu su) -> Q Exp
compileTimeSchemaValidation =
GQLResult (Schema VALID) -> Q Exp
fromSchema (GQLResult (Schema VALID) -> Q Exp)
-> (proxy (root m event qu mu su) -> GQLResult (Schema VALID))
-> proxy (root m event qu mu su)
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (proxy (root m event qu mu su) -> GQLResult (Schema CONST)
forall k
(root :: (* -> *)
-> * -> ((* -> *) -> *) -> ((* -> *) -> *) -> ((* -> *) -> *) -> k)
(proxy :: k -> *) (m :: * -> *) e (query :: (* -> *) -> *)
(mut :: (* -> *) -> *) (subs :: (* -> *) -> *).
SchemaConstraints e m query mut subs =>
proxy (root m e query mut subs) -> GQLResult (Schema CONST)
deriveSchema (proxy (root m event qu mu su) -> GQLResult (Schema CONST))
-> (Schema CONST -> GQLResult (Schema VALID))
-> proxy (root m event qu mu su)
-> GQLResult (Schema VALID)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool -> Config -> Schema CONST -> GQLResult (Schema VALID)
forall (s :: Stage).
ValidateSchema s =>
Bool -> Config -> Schema s -> GQLResult (Schema VALID)
validateSchema Bool
True Config
defaultConfig)
deriveSchema ::
forall
root
proxy
m
e
query
mut
subs.
( SchemaConstraints e m query mut subs
) =>
proxy (root m e query mut subs) ->
GQLResult (Schema CONST)
deriveSchema :: proxy (root m e query mut subs) -> GQLResult (Schema CONST)
deriveSchema proxy (root m e query mut subs)
_ = SchemaT
OUT
(TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST)
-> GQLResult (Schema CONST)
forall (c :: TypeCategory).
SchemaT
c
(TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST)
-> GQLResult (Schema CONST)
toSchema SchemaT
OUT
(TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST)
schemaT
where
schemaT ::
SchemaT
OUT
( TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST
)
schemaT :: SchemaT
OUT
(TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST)
schemaT =
(,,)
(TypeDefinition OBJECT CONST
-> TypeDefinition OBJECT CONST
-> TypeDefinition OBJECT CONST
-> (TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST))
-> SchemaT OUT (TypeDefinition OBJECT CONST)
-> SchemaT
OUT
(TypeDefinition OBJECT CONST
-> TypeDefinition OBJECT CONST
-> (TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (query (Resolver QUERY e m))
-> SchemaT OUT (TypeDefinition OBJECT CONST)
forall a (f :: * -> *).
DeriveTypeConstraint OUT a =>
f a -> SchemaT OUT (TypeDefinition OBJECT CONST)
deriveObjectType (Proxy (query (Resolver QUERY e m))
forall k (t :: k). Proxy t
Proxy @(query (Resolver QUERY e m)))
SchemaT
OUT
(TypeDefinition OBJECT CONST
-> TypeDefinition OBJECT CONST
-> (TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST))
-> SchemaT OUT (TypeDefinition OBJECT CONST)
-> SchemaT
OUT
(TypeDefinition OBJECT CONST
-> (TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Proxy (mut (Resolver MUTATION e m))
-> SchemaT OUT (TypeDefinition OBJECT CONST)
forall a (f :: * -> *).
DeriveTypeConstraint OUT a =>
f a -> SchemaT OUT (TypeDefinition OBJECT CONST)
deriveObjectType (Proxy (mut (Resolver MUTATION e m))
forall k (t :: k). Proxy t
Proxy @(mut (Resolver MUTATION e m)))
SchemaT
OUT
(TypeDefinition OBJECT CONST
-> (TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST))
-> SchemaT OUT (TypeDefinition OBJECT CONST)
-> SchemaT
OUT
(TypeDefinition OBJECT CONST, TypeDefinition OBJECT CONST,
TypeDefinition OBJECT CONST)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Proxy (subs (Resolver SUBSCRIPTION e m))
-> SchemaT OUT (TypeDefinition OBJECT CONST)
forall a (f :: * -> *).
DeriveTypeConstraint OUT a =>
f a -> SchemaT OUT (TypeDefinition OBJECT CONST)
deriveObjectType (Proxy (subs (Resolver SUBSCRIPTION e m))
forall k (t :: k). Proxy t
Proxy @(subs (Resolver SUBSCRIPTION e m)))
class DeriveType (kind :: TypeCategory) (a :: Type) where
deriveType :: f a -> SchemaT kind ()
deriveContent :: f a -> TyContentM kind
instance (GQLType a, DeriveKindedType cat (KIND a) a) => DeriveType cat a where
deriveType :: f a -> SchemaT cat ()
deriveType f a
_ = KindedProxy (KIND a) a -> SchemaT cat ()
forall k (cat :: TypeCategory) (kind :: DerivingKind) (a :: k)
(kinded :: DerivingKind -> k -> *).
DeriveKindedType cat kind a =>
kinded kind a -> SchemaT cat ()
deriveKindedType (KindedProxy (KIND a) a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND a) a)
deriveContent :: f a -> TyContentM cat
deriveContent f a
_ = KindedProxy (KIND a) a -> TyContentM cat
forall k (cat :: TypeCategory) (kind :: DerivingKind) (a :: k)
(kinded :: DerivingKind -> k -> *).
DeriveKindedType cat kind a =>
kinded kind a -> TyContentM cat
deriveKindedContent (KindedProxy (KIND a) a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND a) a)
class DeriveKindedType (cat :: TypeCategory) (kind :: DerivingKind) a where
deriveKindedType :: kinded kind a -> SchemaT cat ()
deriveKindedContent :: kinded kind a -> TyContentM cat
deriveKindedContent kinded kind a
_ = Maybe (FieldContent TRUE cat CONST) -> TyContentM cat
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (FieldContent TRUE cat CONST)
forall a. Maybe a
Nothing
type DeriveTypeConstraint kind a =
( DeriveTypeConstraintOpt kind a,
CategoryValue kind
)
instance (GQLType a, DeriveType cat a) => DeriveKindedType cat WRAPPER (f a) where
deriveKindedType :: kinded WRAPPER (f a) -> SchemaT cat ()
deriveKindedType kinded WRAPPER (f a)
_ = KindedProxy cat a -> SchemaT cat ()
forall (kind :: TypeCategory) a (f :: * -> *).
DeriveType kind a =>
f a -> SchemaT kind ()
deriveType (KindedProxy cat a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy cat a)
instance (GQLType a, DecodeScalar a) => DeriveKindedType cat SCALAR a where
deriveKindedType :: kinded SCALAR a -> SchemaT cat ()
deriveKindedType = (KindedProxy LEAF a -> SchemaT cat (TypeContent TRUE LEAF CONST))
-> KindedProxy LEAF a -> SchemaT cat ()
forall a (kind :: TypeCategory) (f :: TypeCategory -> * -> *)
(c :: TypeCategory).
(GQLType a, CategoryValue kind) =>
(f kind a -> SchemaT c (TypeContent TRUE kind CONST))
-> f kind a -> SchemaT c ()
updateByContent KindedProxy LEAF a -> SchemaT cat (TypeContent TRUE LEAF CONST)
forall k a (f :: k -> * -> *) (k :: k) (cat :: TypeCategory).
DecodeScalar a =>
f k a -> SchemaT cat (TypeContent TRUE LEAF CONST)
deriveScalarContent (KindedProxy LEAF a -> SchemaT cat ())
-> (kinded SCALAR a -> KindedProxy LEAF a)
-> kinded SCALAR a
-> SchemaT cat ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy LEAF -> kinded SCALAR a -> KindedProxy LEAF a
forall k1 k2 (f :: k1 -> *) (k3 :: k1) t (kinded :: t -> k2 -> *)
(k' :: t) (a :: k2).
f k3 -> kinded k' a -> KindedProxy k3 a
setKind (Proxy LEAF
forall k (t :: k). Proxy t
Proxy @LEAF)
instance DeriveTypeConstraint OUT a => DeriveKindedType OUT TYPE a where
deriveKindedType :: kinded TYPE a -> SchemaT OUT ()
deriveKindedType = kinded TYPE a -> SchemaT OUT ()
forall a (f :: * -> *).
DeriveTypeConstraint OUT a =>
f a -> SchemaT OUT ()
deriveOutputType
instance DeriveTypeConstraint IN a => DeriveKindedType IN TYPE a where
deriveKindedType :: kinded TYPE a -> SchemaT IN ()
deriveKindedType = kinded TYPE a -> SchemaT IN ()
forall a (f :: * -> *).
DeriveTypeConstraint IN a =>
f a -> SchemaT IN ()
deriveInputType
instance DeriveType cat a => DeriveKindedType cat CUSTOM (Resolver o e m a) where
deriveKindedType :: kinded CUSTOM (Resolver o e m a) -> SchemaT cat ()
deriveKindedType kinded CUSTOM (Resolver o e m a)
_ = Proxy a -> SchemaT cat ()
forall (kind :: TypeCategory) a (f :: * -> *).
DeriveType kind a =>
f a -> SchemaT kind ()
deriveType (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
instance DeriveType cat [(k, v)] => DeriveKindedType cat CUSTOM (Map k v) where
deriveKindedType :: kinded CUSTOM (Map k v) -> SchemaT cat ()
deriveKindedType kinded CUSTOM (Map k v)
_ = Proxy [(k, v)] -> SchemaT cat ()
forall (kind :: TypeCategory) a (f :: * -> *).
DeriveType kind a =>
f a -> SchemaT kind ()
deriveType (Proxy [(k, v)]
forall k (t :: k). Proxy t
Proxy @[(k, v)])
instance
( DeriveTypeConstraint OUT interface,
DeriveTypeConstraint OUT union
) =>
DeriveKindedType OUT CUSTOM (TypeGuard interface union)
where
deriveKindedType :: kinded CUSTOM (TypeGuard interface union) -> SchemaT OUT ()
deriveKindedType kinded CUSTOM (TypeGuard interface union)
_ = do
(KindedProxy OUT interface
-> SchemaT OUT (TypeContent TRUE OUT CONST))
-> KindedProxy OUT interface -> SchemaT OUT ()
forall a (kind :: TypeCategory) (f :: TypeCategory -> * -> *)
(c :: TypeCategory).
(GQLType a, CategoryValue kind) =>
(f kind a -> SchemaT c (TypeContent TRUE kind CONST))
-> f kind a -> SchemaT c ()
updateByContent KindedProxy OUT interface
-> SchemaT OUT (TypeContent TRUE OUT CONST)
forall a (f :: * -> *).
DeriveTypeConstraint OUT a =>
f a -> SchemaT OUT (TypeContent TRUE OUT CONST)
deriveInterfaceContent KindedProxy OUT interface
interfaceProxy
TypeContent TRUE OUT CONST
content <- KindedType OUT union -> SchemaT OUT (TypeContent TRUE OUT CONST)
forall (kind :: TypeCategory) a.
DeriveTypeConstraint kind a =>
KindedType kind a -> SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContent (KindedType OUT union
forall k (a :: k). KindedType OUT a
OutputType :: KindedType OUT union)
[TypeName]
unionNames <- TypeContent TRUE OUT CONST -> SchemaT OUT [TypeName]
getUnionNames TypeContent TRUE OUT CONST
content
TypeName -> [TypeName] -> SchemaT OUT ()
forall (cat' :: TypeCategory).
TypeName -> [TypeName] -> SchemaT cat' ()
extendImplements TypeName
interfaceName [TypeName]
unionNames
where
interfaceName :: TypeName
interfaceName :: TypeName
interfaceName = TypeData -> TypeName
gqlTypeName (KindedProxy OUT interface -> TypeData
forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData KindedProxy OUT interface
interfaceProxy)
interfaceProxy :: KindedProxy OUT interface
interfaceProxy :: KindedProxy OUT interface
interfaceProxy = KindedProxy OUT interface
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy
unionProxy :: KindedProxy OUT union
unionProxy :: KindedProxy OUT union
unionProxy = KindedProxy OUT union
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy
getUnionNames :: TypeContent TRUE OUT CONST -> SchemaT OUT [TypeName]
getUnionNames :: TypeContent TRUE OUT CONST -> SchemaT OUT [TypeName]
getUnionNames DataUnion {UnionTypeDefinition OUT CONST
unionMembers :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent OUT a s -> UnionTypeDefinition OUT s
unionMembers :: UnionTypeDefinition OUT CONST
unionMembers} = [TypeName] -> SchemaT OUT [TypeName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypeName] -> SchemaT OUT [TypeName])
-> [TypeName] -> SchemaT OUT [TypeName]
forall a b. (a -> b) -> a -> b
$ OrdMap TypeName TypeName -> [TypeName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (OrdMap TypeName TypeName -> [TypeName])
-> OrdMap TypeName TypeName -> [TypeName]
forall a b. (a -> b) -> a -> b
$ UnionMember OUT CONST -> TypeName
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName (UnionMember OUT CONST -> TypeName)
-> UnionTypeDefinition OUT CONST -> OrdMap TypeName TypeName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnionTypeDefinition OUT CONST
unionMembers
getUnionNames DataObject {} = [TypeName] -> SchemaT OUT [TypeName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TypeData -> TypeName
gqlTypeName (KindedProxy OUT union -> TypeData
forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData KindedProxy OUT union
unionProxy)]
getUnionNames TypeContent TRUE OUT CONST
_ = GQLError -> SchemaT OUT [TypeName]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"guarded type must be an union or object"
instance
( GQLType b,
DeriveKindedType OUT (KIND b) b,
DeriveArguments (KIND a) a
) =>
DeriveKindedType OUT CUSTOM (a -> b)
where
deriveKindedContent :: kinded CUSTOM (a -> b) -> TyContentM OUT
deriveKindedContent kinded CUSTOM (a -> b)
_ = do
ArgumentsDefinition CONST
a <- KindedProxy (KIND a) a -> SchemaT OUT (ArgumentsDefinition CONST)
forall k (k :: DerivingKind) (a :: k)
(f :: DerivingKind -> k -> *).
DeriveArguments k a =>
f k a -> SchemaT OUT (ArgumentsDefinition CONST)
deriveArgumentsDefinition (Proxy a -> KindedProxy (KIND a) a
forall a. Proxy a -> KindedProxy (KIND a) a
withKind (Proxy a
forall k (t :: k). Proxy t
Proxy @a))
TyContent OUT
b <- KindedProxy (KIND b) b -> TyContentM OUT
forall k (cat :: TypeCategory) (kind :: DerivingKind) (a :: k)
(kinded :: DerivingKind -> k -> *).
DeriveKindedType cat kind a =>
kinded kind a -> TyContentM cat
deriveKindedContent (KindedProxy (KIND b) b
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy (KIND b) b)
case TyContent OUT
b of
Just (FieldArgs ArgumentsDefinition CONST
x) -> FieldContent TRUE OUT CONST -> TyContent OUT
forall a. a -> Maybe a
Just (FieldContent TRUE OUT CONST -> TyContent OUT)
-> (ArgumentsDefinition CONST -> FieldContent TRUE OUT CONST)
-> ArgumentsDefinition CONST
-> TyContent OUT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgumentsDefinition CONST -> FieldContent TRUE OUT CONST
forall (s :: Stage) (cat :: TypeCategory).
ArgumentsDefinition s -> FieldContent (OUT <=? cat) cat s
FieldArgs (ArgumentsDefinition CONST -> TyContent OUT)
-> SchemaT OUT (ArgumentsDefinition CONST) -> TyContentM OUT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArgumentsDefinition CONST
a ArgumentsDefinition CONST
-> ArgumentsDefinition CONST
-> SchemaT OUT (ArgumentsDefinition CONST)
forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> ArgumentsDefinition CONST
x)
TyContent OUT
Nothing -> TyContent OUT -> TyContentM OUT
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyContent OUT -> TyContentM OUT)
-> TyContent OUT -> TyContentM OUT
forall a b. (a -> b) -> a -> b
$ FieldContent TRUE OUT CONST -> TyContent OUT
forall a. a -> Maybe a
Just (ArgumentsDefinition CONST -> FieldContent (OUT <=? OUT) OUT CONST
forall (s :: Stage) (cat :: TypeCategory).
ArgumentsDefinition s -> FieldContent (OUT <=? cat) cat s
FieldArgs ArgumentsDefinition CONST
a)
deriveKindedType :: kinded CUSTOM (a -> b) -> SchemaT OUT ()
deriveKindedType kinded CUSTOM (a -> b)
_ = KindedType OUT b -> SchemaT OUT ()
forall (kind :: TypeCategory) a (f :: * -> *).
DeriveType kind a =>
f a -> SchemaT kind ()
deriveType (Proxy b -> KindedType OUT b
forall k (f :: k -> *) (a :: k). f a -> KindedType OUT a
outputType (Proxy b -> KindedType OUT b) -> Proxy b -> KindedType OUT b
forall a b. (a -> b) -> a -> b
$ Proxy b
forall k (t :: k). Proxy t
Proxy @b)
deriveScalarContent :: (DecodeScalar a) => f k a -> SchemaT cat (TypeContent TRUE LEAF CONST)
deriveScalarContent :: f k a -> SchemaT cat (TypeContent TRUE LEAF CONST)
deriveScalarContent = TypeContent TRUE LEAF CONST
-> SchemaT cat (TypeContent TRUE LEAF CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContent TRUE LEAF CONST
-> SchemaT cat (TypeContent TRUE LEAF CONST))
-> (f k a -> TypeContent TRUE LEAF CONST)
-> f k a
-> SchemaT cat (TypeContent TRUE LEAF CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScalarDefinition -> TypeContent TRUE LEAF CONST
forall (a :: TypeCategory) (s :: Stage).
ScalarDefinition -> TypeContent (LEAF <=? a) a s
DataScalar (ScalarDefinition -> TypeContent TRUE LEAF CONST)
-> (f k a -> ScalarDefinition)
-> f k a
-> TypeContent TRUE LEAF CONST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f k a -> ScalarDefinition
forall (f :: * -> *) a. DecodeScalar a => f a -> ScalarDefinition
scalarValidator
deriveInterfaceContent :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT (TypeContent TRUE OUT CONST)
deriveInterfaceContent :: f a -> SchemaT OUT (TypeContent TRUE OUT CONST)
deriveInterfaceContent = (FieldsDefinition OUT CONST -> TypeContent TRUE OUT CONST)
-> SchemaT OUT (FieldsDefinition OUT CONST)
-> SchemaT OUT (TypeContent TRUE OUT CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldsDefinition OUT CONST -> TypeContent TRUE OUT CONST
forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent (IMPLEMENTABLE <=? a) a s
DataInterface (SchemaT OUT (FieldsDefinition OUT CONST)
-> SchemaT OUT (TypeContent TRUE OUT CONST))
-> (f a -> SchemaT OUT (FieldsDefinition OUT CONST))
-> f a
-> SchemaT OUT (TypeContent TRUE OUT CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindedType OUT a -> SchemaT OUT (FieldsDefinition OUT CONST)
forall (kind :: TypeCategory) a.
DeriveTypeConstraint kind a =>
KindedType kind a -> SchemaT kind (FieldsDefinition kind CONST)
deriveFields (KindedType OUT a -> SchemaT OUT (FieldsDefinition OUT CONST))
-> (f a -> KindedType OUT a)
-> f a
-> SchemaT OUT (FieldsDefinition OUT CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> KindedType OUT a
forall k (f :: k -> *) (a :: k). f a -> KindedType OUT a
outputType
class DeriveArguments (k :: DerivingKind) a where
deriveArgumentsDefinition :: f k a -> SchemaT OUT (ArgumentsDefinition CONST)
instance DeriveTypeConstraint IN a => DeriveArguments TYPE a where
deriveArgumentsDefinition :: f TYPE a -> SchemaT OUT (ArgumentsDefinition CONST)
deriveArgumentsDefinition = SchemaT IN (ArgumentsDefinition CONST)
-> SchemaT OUT (ArgumentsDefinition CONST)
forall a. SchemaT IN a -> SchemaT OUT a
withInput (SchemaT IN (ArgumentsDefinition CONST)
-> SchemaT OUT (ArgumentsDefinition CONST))
-> (f TYPE a -> SchemaT IN (ArgumentsDefinition CONST))
-> f TYPE a
-> SchemaT OUT (ArgumentsDefinition CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldsDefinition IN CONST -> ArgumentsDefinition CONST)
-> SchemaT IN (FieldsDefinition IN CONST)
-> SchemaT IN (ArgumentsDefinition CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldsDefinition IN CONST -> ArgumentsDefinition CONST
forall (s :: Stage). FieldsDefinition IN s -> ArgumentsDefinition s
fieldsToArguments (SchemaT IN (FieldsDefinition IN CONST)
-> SchemaT IN (ArgumentsDefinition CONST))
-> (f TYPE a -> SchemaT IN (FieldsDefinition IN CONST))
-> f TYPE a
-> SchemaT IN (ArgumentsDefinition CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindedType IN a -> SchemaT IN (FieldsDefinition IN CONST)
forall (kind :: TypeCategory) a.
DeriveTypeConstraint kind a =>
KindedType kind a -> SchemaT kind (FieldsDefinition kind CONST)
deriveFields (KindedType IN a -> SchemaT IN (FieldsDefinition IN CONST))
-> (f TYPE a -> KindedType IN a)
-> f TYPE a
-> SchemaT IN (FieldsDefinition IN CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f TYPE a -> KindedType IN a
forall k (f :: k -> *) (a :: k). f a -> KindedType IN a
inputType
instance (KnownSymbol name, DeriveType IN a, GQLType a) => DeriveArguments CUSTOM (Arg name a) where
deriveArgumentsDefinition :: f CUSTOM (Arg name a) -> SchemaT OUT (ArgumentsDefinition CONST)
deriveArgumentsDefinition f CUSTOM (Arg name a)
_ = do
SchemaT IN () -> SchemaT OUT ()
forall a. SchemaT IN a -> SchemaT OUT a
withInput (KindedProxy IN a -> SchemaT IN ()
forall (kind :: TypeCategory) a (f :: * -> *).
DeriveType kind a =>
f a -> SchemaT kind ()
deriveType KindedProxy IN a
proxy)
ArgumentsDefinition CONST
-> SchemaT OUT (ArgumentsDefinition CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ArgumentsDefinition CONST
-> SchemaT OUT (ArgumentsDefinition CONST))
-> ArgumentsDefinition CONST
-> SchemaT OUT (ArgumentsDefinition CONST)
forall a b. (a -> b) -> a -> b
$ FieldsDefinition IN CONST -> ArgumentsDefinition CONST
forall (s :: Stage). FieldsDefinition IN s -> ArgumentsDefinition s
fieldsToArguments (FieldsDefinition IN CONST -> ArgumentsDefinition CONST)
-> FieldsDefinition IN CONST -> ArgumentsDefinition CONST
forall a b. (a -> b) -> a -> b
$ FieldName -> FieldDefinition IN CONST -> FieldsDefinition IN CONST
forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton FieldName
argName (FieldDefinition IN CONST -> FieldsDefinition IN CONST)
-> FieldDefinition IN CONST -> FieldsDefinition IN CONST
forall a b. (a -> b) -> a -> b
$ Maybe (FieldContent TRUE IN CONST)
-> FieldName -> TypeRef -> FieldDefinition IN CONST
forall (cat :: TypeCategory) (s :: Stage).
Maybe (FieldContent TRUE cat s)
-> FieldName -> TypeRef -> FieldDefinition cat s
mkField Maybe (FieldContent TRUE IN CONST)
forall a. Maybe a
Nothing FieldName
argName TypeRef
argTypeRef
where
proxy :: KindedProxy IN a
proxy :: KindedProxy IN a
proxy = KindedProxy IN a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy
argName :: FieldName
argName = Proxy name -> FieldName
forall (a :: Symbol) (f :: Symbol -> *).
KnownSymbol a =>
f a -> FieldName
symbolName (Proxy name
forall k (t :: k). Proxy t
Proxy @name)
argTypeRef :: TypeRef
argTypeRef = KindedProxy IN a -> TypeRef
forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeRef
deriveTypeRef KindedProxy IN a
proxy
deriveFields :: DeriveTypeConstraint kind a => KindedType kind a -> SchemaT kind (FieldsDefinition kind CONST)
deriveFields :: KindedType kind a -> SchemaT kind (FieldsDefinition kind CONST)
deriveFields KindedType kind a
kindedType = KindedType kind a -> SchemaT kind (TypeContent TRUE kind CONST)
forall (kind :: TypeCategory) a.
DeriveTypeConstraint kind a =>
KindedType kind a -> SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContent KindedType kind a
kindedType SchemaT kind (TypeContent TRUE kind CONST)
-> (TypeContent TRUE kind CONST
-> SchemaT kind (FieldsDefinition kind CONST))
-> SchemaT kind (FieldsDefinition kind CONST)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KindedType kind a
-> TypeContent TRUE kind CONST
-> SchemaT kind (FieldsDefinition kind CONST)
forall a (c :: TypeCategory) (any :: TypeCategory) (s :: Stage).
(GQLType a, CategoryValue c) =>
KindedType c a
-> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s)
withObject KindedType kind a
kindedType
deriveInputType :: DeriveTypeConstraint IN a => f a -> SchemaT IN ()
deriveInputType :: f a -> SchemaT IN ()
deriveInputType = (KindedType IN a -> SchemaT IN (TypeContent TRUE IN CONST))
-> KindedType IN a -> SchemaT IN ()
forall a (kind :: TypeCategory) (f :: TypeCategory -> * -> *)
(c :: TypeCategory).
(GQLType a, CategoryValue kind) =>
(f kind a -> SchemaT c (TypeContent TRUE kind CONST))
-> f kind a -> SchemaT c ()
updateByContent KindedType IN a -> SchemaT IN (TypeContent TRUE IN CONST)
forall (kind :: TypeCategory) a.
DeriveTypeConstraint kind a =>
KindedType kind a -> SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContent (KindedType IN a -> SchemaT IN ())
-> (f a -> KindedType IN a) -> f a -> SchemaT IN ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> KindedType IN a
forall k (f :: k -> *) (a :: k). f a -> KindedType IN a
inputType
deriveOutputType :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT ()
deriveOutputType :: f a -> SchemaT OUT ()
deriveOutputType = (KindedType OUT a -> SchemaT OUT (TypeContent TRUE OUT CONST))
-> KindedType OUT a -> SchemaT OUT ()
forall a (kind :: TypeCategory) (f :: TypeCategory -> * -> *)
(c :: TypeCategory).
(GQLType a, CategoryValue kind) =>
(f kind a -> SchemaT c (TypeContent TRUE kind CONST))
-> f kind a -> SchemaT c ()
updateByContent KindedType OUT a -> SchemaT OUT (TypeContent TRUE OUT CONST)
forall (kind :: TypeCategory) a.
DeriveTypeConstraint kind a =>
KindedType kind a -> SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContent (KindedType OUT a -> SchemaT OUT ())
-> (f a -> KindedType OUT a) -> f a -> SchemaT OUT ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> KindedType OUT a
forall k (f :: k -> *) (a :: k). f a -> KindedType OUT a
outputType
deriveObjectType :: DeriveTypeConstraint OUT a => f a -> SchemaT OUT (TypeDefinition OBJECT CONST)
deriveObjectType :: f a -> SchemaT OUT (TypeDefinition OBJECT CONST)
deriveObjectType = (f a -> SchemaT OUT (FieldsDefinition OUT CONST))
-> f a -> SchemaT OUT (TypeDefinition OBJECT CONST)
forall a (f :: * -> *) (kind :: TypeCategory).
GQLType a =>
(f a -> SchemaT kind (FieldsDefinition OUT CONST))
-> f a -> SchemaT kind (TypeDefinition OBJECT CONST)
asObjectType (KindedType OUT a -> SchemaT OUT (FieldsDefinition OUT CONST)
forall (kind :: TypeCategory) a.
DeriveTypeConstraint kind a =>
KindedType kind a -> SchemaT kind (FieldsDefinition kind CONST)
deriveFields (KindedType OUT a -> SchemaT OUT (FieldsDefinition OUT CONST))
-> (f a -> KindedType OUT a)
-> f a
-> SchemaT OUT (FieldsDefinition OUT CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> KindedType OUT a
forall k (f :: k -> *) (a :: k). f a -> KindedType OUT a
outputType)
fieldContentConstraint :: f kind a -> TypeConstraint (DeriveType kind) (TyContentM kind) Proxy
fieldContentConstraint :: f kind a
-> TypeConstraint (DeriveType kind) (TyContentM kind) Proxy
fieldContentConstraint f kind a
_ = (forall a. DeriveType kind a => Proxy a -> TyContentM kind)
-> TypeConstraint (DeriveType kind) (TyContentM kind) Proxy
forall (c :: * -> Constraint) v (f :: * -> *).
(forall a. c a => f a -> v) -> TypeConstraint c v f
TypeConstraint forall a. DeriveType kind a => Proxy a -> TyContentM kind
forall (f :: * -> *) (kind :: TypeCategory) a.
DeriveType kind a =>
f a -> TyContentM kind
deriveFieldContent
deriveFieldContent :: forall f kind a. (DeriveType kind a) => f a -> TyContentM kind
deriveFieldContent :: f a -> TyContentM kind
deriveFieldContent f a
_ = KindedProxy kind a -> SchemaT kind ()
forall (kind :: TypeCategory) a (f :: * -> *).
DeriveType kind a =>
f a -> SchemaT kind ()
deriveType KindedProxy kind a
kindedProxy SchemaT kind () -> TyContentM kind -> TyContentM kind
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> KindedProxy kind a -> TyContentM kind
forall (kind :: TypeCategory) a (f :: * -> *).
DeriveType kind a =>
f a -> TyContentM kind
deriveContent KindedProxy kind a
kindedProxy
where
kindedProxy :: KindedProxy kind a
kindedProxy :: KindedProxy kind a
kindedProxy = KindedProxy kind a
forall k k (k :: k) (a :: k). KindedProxy k a
KindedProxy
deriveTypeContent ::
forall kind a.
DeriveTypeConstraint kind a =>
KindedType kind a ->
SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContent :: KindedType kind a -> SchemaT kind (TypeContent TRUE kind CONST)
deriveTypeContent KindedType kind a
kindedProxy =
[ConsRep (SchemaT kind (TyContent kind))]
-> SchemaT kind [ConsRep (TyContent kind)]
forall (m :: * -> *) a. Monad m => [ConsRep (m a)] -> m [ConsRep a]
unpackMonad
(TypeConstraint
(DeriveType kind) (SchemaT kind (TyContent kind)) Proxy
-> KindedType kind a -> [ConsRep (SchemaT kind (TyContent kind))]
forall (kinded :: TypeCategory -> * -> *)
(constraint :: * -> Constraint) value a (kind :: TypeCategory).
(GQLType a, CategoryValue kind,
TypeRep constraint value (Rep a)) =>
TypeConstraint constraint value Proxy
-> kinded kind a -> [ConsRep value]
toRep (KindedType kind a
-> TypeConstraint
(DeriveType kind) (SchemaT kind (TyContent kind)) Proxy
forall k (f :: TypeCategory -> k -> *) (kind :: TypeCategory)
(a :: k).
f kind a
-> TypeConstraint (DeriveType kind) (TyContentM kind) Proxy
fieldContentConstraint KindedType kind a
kindedProxy) KindedType kind a
kindedProxy)
SchemaT kind [ConsRep (TyContent kind)]
-> ([ConsRep (TyContent kind)]
-> SchemaT kind (TypeContent TRUE kind CONST))
-> SchemaT kind (TypeContent TRUE kind CONST)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KindedType kind a
-> [ConsRep (TyContent kind)]
-> SchemaT kind (TypeContent TRUE kind CONST)
forall a (kind :: TypeCategory).
(GQLType a, CategoryValue kind) =>
KindedType kind a
-> [ConsRep (TyContent kind)]
-> SchemaT kind (TypeContent TRUE kind CONST)
buildTypeContent KindedType kind a
kindedProxy