{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Morpheus.Server.Deriving.Encode
( EncodeCon,
Encode (..),
ExploreResolvers (..),
deriveModel,
)
where
import Data.Map (Map)
import qualified Data.Map as M
( toList,
)
import Data.Morpheus.Kind
( ENUM,
GQL_KIND,
INTERFACE,
OUTPUT,
ResContext (..),
SCALAR,
VContext (..),
)
import Data.Morpheus.Server.Deriving.Channels (ChannelCon, getChannels)
import Data.Morpheus.Server.Deriving.Decode
( DecodeType,
decodeArguments,
)
import Data.Morpheus.Server.Deriving.Utils
( conNameProxy,
datatypeNameProxy,
isRecordProxy,
)
import Data.Morpheus.Server.Types.GQLType (GQLType (..))
import Data.Morpheus.Server.Types.Types
( MapKind,
Pair (..),
mapKindFromList,
)
import Data.Morpheus.Types
( RootResolver (..),
)
import Data.Morpheus.Types.GQLScalar (GQLScalar (..))
import Data.Morpheus.Types.Internal.AST
( FieldName,
FieldName (..),
InternalError,
MUTATION,
OperationType (..),
QUERY,
SUBSCRIPTION,
TypeName,
)
import Data.Morpheus.Types.Internal.Resolving
( FieldResModel,
LiftOperation,
ObjectResModel (..),
ResModel (..),
Resolver,
ResolverState,
RootResModel (..),
SubscriptionField (..),
failure,
getArguments,
liftResolverState,
)
import Data.Proxy (Proxy (..))
import Data.Semigroup ((<>))
import Data.Set (Set)
import qualified Data.Set as S
( toList,
)
import Data.Text (pack)
import GHC.Generics
class Encode resolver o e (m :: * -> *) where
encode :: resolver -> Resolver o e m (ResModel o e m)
instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m, LiftOperation o) => Encode a o e m where
encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a)
instance (Monad m, LiftOperation o, Encode a o e m) => Encode (Maybe a) o e m where
encode = maybe (pure ResNull) encode
instance (Monad m, Encode a o e m, LiftOperation o) => Encode [a] o e m where
encode = fmap ResList . traverse encode
instance Encode (Pair k v) o e m => Encode (k, v) o e m where
encode (key, value) = encode (Pair key value)
instance Encode [a] o e m => Encode (Set a) o e m where
encode = encode . S.toList
instance (Eq k, Monad m, LiftOperation o, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where
encode value =
encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o e m))
instance (Monad m, LiftOperation o, Encode a o e m) => Encode (SubscriptionField a) o e m where
encode (SubscriptionField _ res) = encode res
instance
( DecodeType a,
Generic a,
Monad m,
LiftOperation o,
Encode b o e m
) =>
Encode (a -> b) o e m
where
encode f =
getArguments
>>= liftResolverState . decodeArguments
>>= encode . f
instance
( Monad m,
Encode b o e m,
LiftOperation o
) =>
Encode (Resolver o e m b) o e m
where
encode x = x >>= encode
class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where
encodeKind :: LiftOperation o => VContext kind a -> Resolver o e m (ResModel o e m)
instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where
encodeKind = pure . ResScalar . serialize . unVContext
instance (Generic a, ExploreResolvers (CUSTOM a) a o e m, Monad m) => EncodeKind ENUM a o e m where
encodeKind (VContext value) = liftResolverState $ exploreResolvers (Proxy @(CUSTOM a)) value
instance (Monad m, Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where
encodeKind (VContext value) = liftResolverState $ exploreResolvers (Proxy @(CUSTOM a)) value
instance (Monad m, Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind INTERFACE a o e m where
encodeKind (VContext value) = liftResolverState $ exploreResolvers (Proxy @(CUSTOM a)) value
convertNode ::
(Monad m, LiftOperation o) =>
ResNode o e m ->
ResModel o e m
convertNode ResNode {resDatatypeName, resKind = REP_OBJECT, resFields} =
ResObject (ObjectResModel resDatatypeName $ map toFieldRes resFields)
convertNode ResNode {resDatatypeName, resKind = REP_UNION, resFields, resTypeName, isResRecord} =
encodeUnion resFields
where
encodeUnion [] = ResEnum resDatatypeName resTypeName
encodeUnion [FieldNode {fieldTypeName, fieldResolver, isFieldObject}]
| isFieldObject && resTypeName == resDatatypeName <> fieldTypeName =
ResUnion fieldTypeName fieldResolver
encodeUnion fields =
ResUnion
resTypeName
$ pure
$ ResObject
$ ObjectResModel
resTypeName
(map toFieldRes resolvers)
where
resolvers
| isResRecord = fields
| otherwise = setFieldNames fields
type GQL_RES a = (Generic a, GQLType a)
type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m)
class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where
exploreResolvers :: Proxy custom -> a -> ResolverState (ResModel o e m)
instance (Generic a, Monad m, LiftOperation o, TypeRep (Rep a) o e m) => ExploreResolvers 'False a o e m where
exploreResolvers _ value =
pure
$ convertNode
$ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value)
objectResolvers ::
forall a o e m.
( ExploreResolvers (CUSTOM a) a o e m,
Monad m,
LiftOperation o
) =>
a ->
ResolverState (ResModel o e m)
objectResolvers value =
exploreResolvers (Proxy @(CUSTOM a)) value
>>= constraintOnject
where
constraintOnject obj@ResObject {} =
pure obj
constraintOnject _ =
failure ("resolver must be an object" :: InternalError)
type Con o e m a =
ExploreResolvers
( CUSTOM
(a (Resolver o e m))
)
(a (Resolver o e m))
o
e
m
deriveModel ::
forall e m query mut sub.
( Con QUERY e m query,
Con MUTATION e m mut,
Con SUBSCRIPTION e m sub,
ChannelCon e m sub,
Applicative m,
Monad m
) =>
RootResolver m e query mut sub ->
RootResModel e m
deriveModel
RootResolver
{ queryResolver,
mutationResolver,
subscriptionResolver
} =
RootResModel
{ query = objectResolvers queryResolver,
mutation = objectResolvers mutationResolver,
subscription = objectResolvers subscriptionResolver,
channelMap = Just (getChannels subscriptionResolver)
}
toFieldRes :: FieldNode o e m -> FieldResModel o e m
toFieldRes FieldNode {fieldSelName, fieldResolver} =
(fieldSelName, fieldResolver)
data REP_KIND = REP_UNION | REP_OBJECT
data ResNode o e m = ResNode
{ resDatatypeName :: TypeName,
resTypeName :: TypeName,
resKind :: REP_KIND,
resFields :: [FieldNode o e m],
isResRecord :: Bool
}
data FieldNode o e m = FieldNode
{ fieldTypeName :: TypeName,
fieldSelName :: FieldName,
fieldResolver :: Resolver o e m (ResModel o e m),
isFieldObject :: Bool
}
setFieldNames :: [FieldNode o e m] -> [FieldNode o e m]
setFieldNames = zipWith setFieldName ([0 ..] :: [Int])
where
setFieldName i field = field {fieldSelName = FieldName $ "_" <> pack (show i)}
class TypeRep f o e (m :: * -> *) where
typeResolvers :: ResContext OUTPUT o e m value -> f a -> ResNode o e m
instance (Datatype d, TypeRep f o e m) => TypeRep (M1 D d f) o e m where
typeResolvers context (M1 src) =
(typeResolvers context src)
{ resDatatypeName = datatypeNameProxy (Proxy @d)
}
instance (TypeRep a o e m, TypeRep b o e m) => TypeRep (a :+: b) o e m where
typeResolvers context (L1 x) =
(typeResolvers context x) {resKind = REP_UNION}
typeResolvers context (R1 x) =
(typeResolvers context x) {resKind = REP_UNION}
instance (FieldRep f o e m, Constructor c) => TypeRep (M1 C c f) o e m where
typeResolvers context (M1 src) =
ResNode
{ resDatatypeName = "",
resTypeName = conNameProxy (Proxy @c),
resKind = REP_OBJECT,
resFields = fieldRep context src,
isResRecord = isRecordProxy (Proxy @c)
}
class FieldRep f o e (m :: * -> *) where
fieldRep :: ResContext OUTPUT o e m value -> f a -> [FieldNode o e m]
instance (FieldRep f o e m, FieldRep g o e m) => FieldRep (f :*: g) o e m where
fieldRep context (a :*: b) = fieldRep context a <> fieldRep context b
instance (Selector s, GQLType a, Encode a o e m) => FieldRep (M1 S s (K1 s2 a)) o e m where
fieldRep _ m@(M1 (K1 src)) =
[ FieldNode
{ fieldSelName = FieldName $ pack (selName m),
fieldTypeName = __typeName (Proxy @a),
fieldResolver = encode src,
isFieldObject = isObjectKind (Proxy @a)
}
]
instance FieldRep U1 o e m where
fieldRep _ _ = []