{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.Deriving.Kinded.Channels
( resolverChannels,
CHANNELS,
)
where
import Control.Monad.Except (throwError)
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.App.Internal.Resolving
( Channel,
MonadResolver (..),
ResolverState,
SubscriptionField (..),
)
import Data.Morpheus.Internal.Utils
( selectBy,
)
import Data.Morpheus.Server.Deriving.Internal.Decode.Utils (useDecodeArguments)
import Data.Morpheus.Server.Deriving.Internal.Schema.Directive (UseDeriving (..), toFieldRes)
import Data.Morpheus.Server.Deriving.Utils.GRep
( ConsRep (..),
GRep,
RepContext (..),
TypeRep (..),
deriveValue,
)
import Data.Morpheus.Server.Deriving.Utils.Kinded (outputType)
import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (useTypeData))
import Data.Morpheus.Server.Types.Types (Undefined)
import Data.Morpheus.Types.Internal.AST
( FALSE,
FieldName,
SUBSCRIPTION,
Selection (..),
SelectionContent (..),
TRUE,
VALID,
internal,
)
import GHC.Generics (Rep)
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 CHANNELS gql val (subs :: (Type -> Type) -> Type) m =
( MonadResolver m,
MonadOperation m ~ SUBSCRIPTION,
ExploreChannels gql val (IsUndefined (subs m)) (MonadEvent m) (subs m)
)
resolverChannels ::
forall m subs gql val.
CHANNELS gql val subs m =>
UseDeriving gql val ->
subs m ->
Selection VALID ->
ResolverState (Channel (MonadEvent m))
resolverChannels :: forall (m :: * -> *) (subs :: (* -> *) -> *)
(gql :: * -> Constraint) (val :: * -> Constraint).
CHANNELS gql val subs m =>
UseDeriving gql val
-> subs m
-> Selection VALID
-> ResolverState (Channel (MonadEvent m))
resolverChannels UseDeriving gql val
drv subs 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 (MonadEvent m))
channelSelector
where
channelSelector :: Selection VALID -> ResolverState (DerivedChannel (MonadEvent m))
channelSelector :: Selection VALID -> ResolverState (DerivedChannel (MonadEvent m))
channelSelector = forall e. HashMap FieldName (ChannelRes e) -> ChannelRes e
selectBySelection (forall (gql :: * -> Constraint) (val :: * -> Constraint)
(t :: Bool) e a (f :: Bool -> *).
ExploreChannels gql val t e a =>
UseDeriving gql val -> f t -> a -> HashMap FieldName (ChannelRes e)
exploreChannels UseDeriving gql val
drv (forall {k} (t :: k). Proxy t
Proxy @(IsUndefined (subs m))) subs 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 val e a where
getChannel :: UseDeriving gql val -> a -> ChannelRes e
instance (MonadResolver m, MonadOperation m ~ SUBSCRIPTION, MonadEvent m ~ e) => GetChannel val e (SubscriptionField (m a)) where
getChannel :: forall (gql :: * -> Constraint).
UseDeriving gql val -> SubscriptionField (m a) -> ChannelRes e
getChannel UseDeriving gql val
_ SubscriptionField (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 (m :: * -> *) v.
(a ~ m v, MonadResolver m, MonadOperation m ~ SUBSCRIPTION) =>
Channel (MonadEvent m)
channel SubscriptionField (m a)
x
instance (MonadResolver m, MonadOperation m ~ SUBSCRIPTION, MonadEvent m ~ e, val arg) => GetChannel val e (arg -> SubscriptionField (m a)) where
getChannel :: forall (gql :: * -> Constraint).
UseDeriving gql val
-> (arg -> SubscriptionField (m a)) -> ChannelRes e
getChannel UseDeriving gql val
drv arg -> SubscriptionField (m a)
f sel :: Selection VALID
sel@Selection {Arguments VALID
selectionArguments :: forall (s :: Stage). Selection s -> Arguments s
selectionArguments :: Arguments VALID
selectionArguments} =
forall (val :: * -> Constraint) a (gql :: * -> Constraint).
val a =>
UseDeriving gql val -> Arguments VALID -> ResolverState a
useDecodeArguments UseDeriving gql val
drv Arguments VALID
selectionArguments
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (val :: * -> Constraint) e a (gql :: * -> Constraint).
GetChannel val e a =>
UseDeriving gql val -> a -> ChannelRes e
getChannel UseDeriving gql val
drv) Selection VALID
sel forall b c a. (b -> c) -> (a -> b) -> a -> c
. arg -> SubscriptionField (m a)
f
type family IsUndefined a :: Bool where
IsUndefined (Undefined m) = TRUE
IsUndefined a = FALSE
class ExploreChannels gql val (t :: Bool) e a where
exploreChannels :: UseDeriving gql val -> f t -> a -> HashMap FieldName (ChannelRes e)
instance (gql a, Generic a, GRep gql (GetChannel val e) (ChannelRes e) (Rep a)) => ExploreChannels gql val FALSE e a where
exploreChannels :: forall (f :: Bool -> *).
UseDeriving gql val
-> f 'False -> a -> HashMap FieldName (ChannelRes e)
exploreChannels UseDeriving gql val
drv 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 (gql :: * -> Constraint) a (args :: * -> Constraint)
(f :: * -> *) v.
gql a =>
UseDeriving gql args -> f a -> FieldRep v -> (FieldName, v)
toFieldRes UseDeriving gql val
drv (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. TypeRep v -> ConsRep v
tyCons
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (gql :: * -> Constraint) (constraint :: * -> Constraint)
value.
(Generic a, GRep gql constraint value (Rep a), gql a) =>
RepContext gql constraint Identity value -> a -> TypeRep value
deriveValue
( RepContext
{ optApply :: forall a. GetChannel val e a => Identity a -> ChannelRes e
optApply = forall (val :: * -> Constraint) e a (gql :: * -> Constraint).
GetChannel val e a =>
UseDeriving gql val -> a -> ChannelRes e
getChannel UseDeriving gql val
drv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity,
optTypeData :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeData
optTypeData = forall (gql :: * -> Constraint).
UseGQLType gql
-> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeData
useTypeData (forall (gql :: * -> Constraint) (val :: * -> Constraint).
UseDeriving gql val -> UseGQLType gql
dirGQL UseDeriving gql val
drv) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType
} ::
RepContext gql (GetChannel val e) Identity (ChannelRes e)
)
instance ExploreChannels drv val TRUE e (Undefined m) where
exploreChannels :: forall (f :: Bool -> *).
UseDeriving drv val
-> f TRUE -> Undefined m -> HashMap FieldName (ChannelRes e)
exploreChannels UseDeriving drv val
_ f TRUE
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k v. HashMap k v
HM.empty