{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Deriving.Channels
( channelResolver,
ChannelsConstraint,
)
where
import Control.Monad.Except (throwError)
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.App.Internal.Resolving
( Channel,
Resolver,
ResolverState,
SubscriptionField (..),
)
import Data.Morpheus.Internal.Utils
( selectBy,
)
import Data.Morpheus.Server.Deriving.Decode
( Decode,
decodeArguments,
)
import Data.Morpheus.Server.Deriving.Schema.Directive (toFieldRes)
import Data.Morpheus.Server.Deriving.Utils
( ConsRep (..),
DataType (..),
)
import Data.Morpheus.Server.Deriving.Utils.DeriveGType
( DeriveValueOptions (..),
DeriveWith,
deriveValue,
)
import Data.Morpheus.Server.Deriving.Utils.Kinded (KindedProxy (..), kinded)
import Data.Morpheus.Server.Types.GQLType (GQLType, deriveTypename, __typeData)
import Data.Morpheus.Server.Types.Types (Undefined)
import Data.Morpheus.Types.Internal.AST
( FieldName,
OUT,
SUBSCRIPTION,
Selection (..),
SelectionContent (..),
VALID,
internal,
)
import GHC.Generics
import Relude hiding (Undefined)
newtype DerivedChannel e = DerivedChannel
{ forall e. DerivedChannel e -> Channel e
_unpackChannel :: Channel e
}
type ChannelRes (e :: Type) = Selection VALID -> ResolverState (DerivedChannel e)
type ChannelsConstraint e m (subs :: (Type -> Type) -> Type) =
ExploreChannels (IsUndefined (subs (Resolver SUBSCRIPTION e m))) e (subs (Resolver SUBSCRIPTION e m))
channelResolver ::
forall e m subs.
ChannelsConstraint e m subs =>
subs (Resolver SUBSCRIPTION e m) ->
Selection VALID ->
ResolverState (Channel e)
channelResolver :: forall e (m :: * -> *) (subs :: (* -> *) -> *).
ChannelsConstraint e m subs =>
subs (Resolver SUBSCRIPTION e m)
-> Selection VALID -> ResolverState (Channel e)
channelResolver subs (Resolver SUBSCRIPTION e m)
value = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. DerivedChannel e -> Channel e
_unpackChannel forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection VALID -> ResolverState (DerivedChannel e)
channelSelector
where
channelSelector ::
Selection VALID ->
ResolverState (DerivedChannel e)
channelSelector :: Selection VALID -> ResolverState (DerivedChannel e)
channelSelector =
forall e. HashMap FieldName (ChannelRes e) -> ChannelRes e
selectBySelection
( forall (t :: Bool) e a (f :: Bool -> *).
ExploreChannels t e a =>
f t -> a -> HashMap FieldName (ChannelRes e)
exploreChannels
(forall {k} (t :: k). Proxy t
Proxy @(IsUndefined (subs (Resolver SUBSCRIPTION e m))))
subs (Resolver SUBSCRIPTION e m)
value
)
selectBySelection ::
HashMap FieldName (ChannelRes e) ->
Selection VALID ->
ResolverState (DerivedChannel e)
selectBySelection :: forall e. HashMap FieldName (ChannelRes e) -> ChannelRes e
selectBySelection HashMap FieldName (ChannelRes e)
channels = Selection VALID -> ResolverState (Selection VALID)
withSubscriptionSelection forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall e. HashMap FieldName (ChannelRes e) -> ChannelRes e
selectSubscription HashMap FieldName (ChannelRes e)
channels
selectSubscription ::
HashMap FieldName (ChannelRes e) ->
Selection VALID ->
ResolverState (DerivedChannel e)
selectSubscription :: forall e. HashMap FieldName (ChannelRes e) -> ChannelRes e
selectSubscription HashMap FieldName (ChannelRes e)
channels sel :: Selection VALID
sel@Selection {FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName :: FieldName
selectionName} =
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy
(GQLError -> GQLError
internal GQLError
"invalid subscription: no channel is selected.")
FieldName
selectionName
HashMap FieldName (ChannelRes e)
channels
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Selection VALID
sel forall a b. a -> (a -> b) -> b
&)
withSubscriptionSelection :: Selection VALID -> ResolverState (Selection VALID)
withSubscriptionSelection :: Selection VALID -> ResolverState (Selection VALID)
withSubscriptionSelection Selection {selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent = SelectionSet SelectionSet VALID
selSet} =
case forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet VALID
selSet of
[Selection VALID
sel] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Selection VALID
sel
[Selection VALID]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"invalid subscription: there can be only one top level selection")
withSubscriptionSelection Selection VALID
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"invalid subscription: expected selectionSet")
class GetChannel e a | a -> e where
getChannel :: a -> ChannelRes e
instance GetChannel e (SubscriptionField (Resolver SUBSCRIPTION e m a)) where
getChannel :: SubscriptionField (Resolver SUBSCRIPTION e m a) -> ChannelRes e
getChannel SubscriptionField (Resolver SUBSCRIPTION e m a)
x = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e. Channel e -> DerivedChannel e
DerivedChannel forall a b. (a -> b) -> a -> b
$ forall a.
SubscriptionField a
-> forall e (m :: * -> *) v.
(a ~ Resolver SUBSCRIPTION e m v) =>
Channel e
channel SubscriptionField (Resolver SUBSCRIPTION e m a)
x
instance
Decode arg =>
GetChannel e (arg -> SubscriptionField (Resolver SUBSCRIPTION e m a))
where
getChannel :: (arg -> SubscriptionField (Resolver SUBSCRIPTION e m a))
-> ChannelRes e
getChannel arg -> SubscriptionField (Resolver SUBSCRIPTION e m a)
f sel :: Selection VALID
sel@Selection {Arguments VALID
selectionArguments :: forall (s :: Stage). Selection s -> Arguments s
selectionArguments :: Arguments VALID
selectionArguments} =
forall a. Decode a => Arguments VALID -> ResolverState a
decodeArguments Arguments VALID
selectionArguments
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall e a. GetChannel e a => a -> ChannelRes e
`getChannel` Selection VALID
sel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. arg -> SubscriptionField (Resolver SUBSCRIPTION e m a)
f
type family IsUndefined a :: Bool where
IsUndefined (Undefined m) = 'True
IsUndefined a = 'False
class ExploreChannels (t :: Bool) e a where
exploreChannels :: f t -> a -> HashMap FieldName (ChannelRes e)
class (GQLType a, GetChannel e a) => ChannelConstraint e a
instance (GetChannel e a, GQLType a) => ChannelConstraint e a
instance (GQLType a, Generic a, DeriveWith (ChannelConstraint e) (ChannelRes e) (Rep a)) => ExploreChannels 'False e a where
exploreChannels :: forall (f :: Bool -> *).
f 'False -> a -> HashMap FieldName (ChannelRes e)
exploreChannels f 'False
_ =
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a (f :: * -> *) v.
GQLType a =>
f a -> FieldRep v -> (FieldName, v)
toFieldRes (forall {k} (t :: k). Proxy t
Proxy @a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. ConsRep v -> [FieldRep v]
consFields
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. DataType v -> ConsRep v
tyCons
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kind :: TypeCategory) a (constraint :: * -> Constraint)
value.
(CategoryValue kind, Generic a,
DeriveWith constraint value (Rep a)) =>
DeriveValueOptions kind constraint value -> a -> DataType value
deriveValue
( DeriveValueOptions
{ __valueApply :: forall a. ChannelConstraint e a => a -> ChannelRes e
__valueApply = forall e a. GetChannel e a => a -> ChannelRes e
getChannel,
__valueTypeName :: TypeName
__valueTypeName = forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *).
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeName
deriveTypename (forall {k} {k} (k :: k) (a :: k). KindedProxy k a
KindedProxy :: KindedProxy OUT a),
__valueGetType :: forall (f :: * -> *) a. ChannelConstraint e a => f a -> TypeData
__valueGetType = forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a.
(GQLType a, CategoryValue kind) =>
kinded kind a -> TypeData
__typeData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (f :: k1 -> *) (k3 :: k1) (f' :: k2 -> *)
(a :: k2).
f k3 -> f' a -> KindedProxy k3 a
kinded (forall {k} (t :: k). Proxy t
Proxy @OUT)
} ::
DeriveValueOptions OUT (ChannelConstraint e) (ChannelRes e)
)
instance ExploreChannels 'True e (Undefined m) where
exploreChannels :: forall (f :: Bool -> *).
f 'True -> Undefined m -> HashMap FieldName (ChannelRes e)
exploreChannels f 'True
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k v. HashMap k v
HM.empty