{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Kinded.Channels
  ( resolverChannels,
    CHANNELS,
  )
where

import Control.Monad.Except (throwError)
import Data.Morpheus.App.Internal.Resolving
  ( Channel,
    MonadResolver (..),
    ResolverState,
    SubscriptionField (..),
  )
import Data.Morpheus.Generic
  ( GRep,
    GRepField,
    GRepFun (..),
    GRepValue (..),
    deriveValue,
  )
import Data.Morpheus.Internal.Utils
  ( selectBy,
  )
import Data.Morpheus.Server.Deriving.Internal.Directive (UseDeriving (..), toFieldRes)
import Data.Morpheus.Server.Deriving.Utils.Kinded (outputType)
import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..), useDecodeArguments)
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 (UseDeriving 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 = (DerivedChannel (MonadEvent m) -> Channel (MonadEvent m))
-> ResolverStateT () Identity (DerivedChannel (MonadEvent m))
-> ResolverStateT () Identity (Channel (MonadEvent m))
forall a b.
(a -> b)
-> ResolverStateT () Identity a -> ResolverStateT () Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DerivedChannel (MonadEvent m) -> Channel (MonadEvent m)
forall e. DerivedChannel e -> Channel e
_unpackChannel (ResolverStateT () Identity (DerivedChannel (MonadEvent m))
 -> ResolverStateT () Identity (Channel (MonadEvent m)))
-> (Selection VALID
    -> ResolverStateT () Identity (DerivedChannel (MonadEvent m)))
-> Selection VALID
-> ResolverStateT () Identity (Channel (MonadEvent m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection VALID
-> ResolverStateT () Identity (DerivedChannel (MonadEvent m))
channelSelector
  where
    channelSelector :: Selection VALID -> ResolverState (DerivedChannel (MonadEvent m))
    channelSelector :: Selection VALID
-> ResolverStateT () Identity (DerivedChannel (MonadEvent m))
channelSelector = HashMap
  FieldName
  (Selection VALID
   -> ResolverStateT () Identity (DerivedChannel (MonadEvent m)))
-> Selection VALID
-> ResolverStateT () Identity (DerivedChannel (MonadEvent m))
forall e. HashMap FieldName (ChannelRes e) -> ChannelRes e
selectBySelection (UseDeriving gql val
-> Proxy (IsUndefined (subs m))
-> subs m
-> HashMap
     FieldName
     (Selection VALID
      -> ResolverStateT () Identity (DerivedChannel (MonadEvent m)))
forall ctx (t :: Bool) e a (gql :: * -> Constraint)
       (val :: * -> Constraint) (f :: Bool -> *).
(ExploreChannels ctx t e a, UseDeriving gql val ~ ctx) =>
ctx -> f t -> a -> HashMap FieldName (ChannelRes e)
forall (gql :: * -> Constraint) (val :: * -> Constraint)
       (f :: Bool -> *).
(UseDeriving gql val ~ UseDeriving gql val) =>
UseDeriving gql val
-> f (IsUndefined (subs m))
-> subs m
-> HashMap
     FieldName
     (Selection VALID
      -> ResolverStateT () Identity (DerivedChannel (MonadEvent m)))
exploreChannels UseDeriving gql val
drv (forall (t :: Bool). Proxy t
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 (Selection VALID -> ResolverState (Selection VALID))
-> ChannelRes e -> ChannelRes e
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> HashMap FieldName (ChannelRes e) -> ChannelRes e
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 :: FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName} =
  GQLError
-> FieldName
-> HashMap FieldName (ChannelRes e)
-> ResolverStateT () Identity (ChannelRes e)
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
    ResolverStateT () Identity (ChannelRes e)
-> (ChannelRes e -> ResolverStateT () Identity (DerivedChannel e))
-> ResolverStateT () Identity (DerivedChannel e)
forall a b.
ResolverStateT () Identity a
-> (a -> ResolverStateT () Identity b)
-> ResolverStateT () Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Selection VALID
sel Selection VALID
-> ChannelRes e -> ResolverStateT () Identity (DerivedChannel e)
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 MergeMap 'False FieldName (Selection VALID) -> [Selection VALID]
forall a. MergeMap 'False FieldName a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
selSet of
    [Selection VALID
sel] -> Selection VALID -> ResolverState (Selection VALID)
forall a. a -> ResolverStateT () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Selection VALID
sel
    [Selection VALID]
_ -> GQLError -> ResolverState (Selection VALID)
forall a. GQLError -> ResolverStateT () Identity a
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
_ = GQLError -> ResolverState (Selection VALID)
forall a. GQLError -> ResolverStateT () Identity a
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 = ResolverState (DerivedChannel e) -> ChannelRes e
forall a b. a -> b -> a
const (ResolverState (DerivedChannel e) -> ChannelRes e)
-> ResolverState (DerivedChannel e) -> ChannelRes e
forall a b. (a -> b) -> a -> b
$ DerivedChannel e -> ResolverState (DerivedChannel e)
forall a. a -> ResolverStateT () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivedChannel e -> ResolverState (DerivedChannel e))
-> DerivedChannel e -> ResolverState (DerivedChannel e)
forall a b. (a -> b) -> a -> b
$ Channel e -> DerivedChannel e
forall e. Channel e -> DerivedChannel e
DerivedChannel (Channel e -> DerivedChannel e) -> Channel e -> DerivedChannel e
forall a b. (a -> b) -> a -> b
$ SubscriptionField (m a)
-> forall (m :: * -> *) v.
   (m a ~ m v, MonadResolver m, MonadOperation m ~ SUBSCRIPTION) =>
   Channel (MonadEvent m)
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 :: Arguments VALID
selectionArguments :: forall (s :: Stage). Selection s -> Arguments s
selectionArguments} =
    UseDeriving gql val -> Arguments VALID -> ResolverState arg
forall (val :: * -> Constraint) a (gql :: * -> Constraint).
val a =>
UseDeriving gql val -> Arguments VALID -> ResolverState a
useDecodeArguments UseDeriving gql val
drv Arguments VALID
selectionArguments
      ResolverState arg
-> (arg -> ResolverStateT () Identity (DerivedChannel e))
-> ResolverStateT () Identity (DerivedChannel e)
forall a b.
ResolverStateT () Identity a
-> (a -> ResolverStateT () Identity b)
-> ResolverStateT () Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SubscriptionField (m a) -> ChannelRes e)
-> Selection VALID
-> SubscriptionField (m a)
-> ResolverStateT () Identity (DerivedChannel e)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (UseDeriving gql val -> SubscriptionField (m a) -> ChannelRes e
forall (gql :: * -> Constraint).
UseDeriving gql val -> SubscriptionField (m a) -> ChannelRes e
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 (SubscriptionField (m a)
 -> ResolverStateT () Identity (DerivedChannel e))
-> (arg -> SubscriptionField (m a))
-> arg
-> ResolverStateT () Identity (DerivedChannel e)
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 ctx (t :: Bool) e a where
  exploreChannels :: (UseDeriving gql val ~ ctx) => ctx -> f t -> a -> HashMap FieldName (ChannelRes e)

instance (UseDeriving gql val ~ ctx, gql a, Generic a, GRep gql (GetChannel val e) (ChannelRes e) (Rep a)) => ExploreChannels ctx FALSE e a where
  exploreChannels :: forall (gql :: * -> Constraint) (val :: * -> Constraint)
       (f :: Bool -> *).
(UseDeriving gql val ~ ctx) =>
ctx -> f 'False -> a -> HashMap FieldName (ChannelRes e)
exploreChannels ctx
ctx f 'False
_ =
    [(FieldName, ChannelRes e)] -> HashMap FieldName (ChannelRes e)
[Item (HashMap FieldName (ChannelRes e))]
-> HashMap FieldName (ChannelRes e)
forall l. IsList l => [Item l] -> l
fromList
      ([(FieldName, ChannelRes e)] -> HashMap FieldName (ChannelRes e))
-> (a -> [(FieldName, ChannelRes e)])
-> a
-> HashMap FieldName (ChannelRes e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GRepField (ChannelRes e) -> (FieldName, ChannelRes e))
-> [GRepField (ChannelRes e)] -> [(FieldName, ChannelRes e)]
forall a b. (a -> b) -> [a] -> [b]
map (UseDeriving gql val
-> Proxy a -> GRepField (ChannelRes e) -> (FieldName, ChannelRes e)
forall (gql :: * -> Constraint) a (args :: * -> Constraint)
       (f :: * -> *) v.
gql a =>
UseDeriving gql args -> f a -> GRepField v -> (FieldName, v)
toFieldRes ctx
UseDeriving gql val
ctx (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))
      ([GRepField (ChannelRes e)] -> [(FieldName, ChannelRes e)])
-> (a -> [GRepField (ChannelRes e)])
-> a
-> [(FieldName, ChannelRes e)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRepValue (ChannelRes e) -> [GRepField (ChannelRes e)]
forall e. GRepValue (ChannelRes e) -> [GRepField (ChannelRes e)]
toFields
      (GRepValue (ChannelRes e) -> [GRepField (ChannelRes e)])
-> (a -> GRepValue (ChannelRes e))
-> a
-> [GRepField (ChannelRes e)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GRepFun gql (GetChannel val e) Identity (ChannelRes e)
-> a -> GRepValue (ChannelRes e)
forall a (gql :: * -> Constraint) (constraint :: * -> Constraint)
       value.
(Generic a, GRep gql constraint value (Rep a), gql a) =>
GRepFun gql constraint Identity value -> a -> GRepValue value
deriveValue
        ( GRepFun
            { grepFun :: forall a. GetChannel val e a => Identity a -> ChannelRes e
grepFun = UseDeriving gql val -> a -> ChannelRes e
forall (gql :: * -> Constraint).
UseDeriving gql val -> a -> ChannelRes e
forall (val :: * -> Constraint) e a (gql :: * -> Constraint).
GetChannel val e a =>
UseDeriving gql val -> a -> ChannelRes e
getChannel ctx
UseDeriving gql val
ctx (a -> ChannelRes e)
-> (Identity a -> a) -> Identity a -> ChannelRes e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity a -> a
forall a. Identity a -> a
runIdentity,
              grepTypename :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeName
grepTypename = ctx -> CatType OUT a -> TypeName
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> TypeName
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeName
useTypename ctx
ctx (CatType OUT a -> TypeName)
-> (proxy a -> CatType OUT a) -> proxy a -> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy a -> CatType OUT a
forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType,
              grepWrappers :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeWrapper
grepWrappers = ctx -> CatType OUT a -> TypeWrapper
forall a (c :: TypeCategory).
gql a =>
ctx -> CatType c a -> TypeWrapper
forall ctx (con :: * -> Constraint) a (c :: TypeCategory).
(UseGQLType ctx con, con a) =>
ctx -> CatType c a -> TypeWrapper
useWrappers ctx
ctx (CatType OUT a -> TypeWrapper)
-> (proxy a -> CatType OUT a) -> proxy a -> TypeWrapper
forall b c a. (b -> c) -> (a -> b) -> a -> c
. proxy a -> CatType OUT a
forall {k} (f :: k -> *) (a :: k). f a -> CatType OUT a
outputType
            } ::
            GRepFun gql (GetChannel val e) Identity (ChannelRes e)
        )

toFields :: GRepValue (ChannelRes e) -> [GRepField (ChannelRes e)]
toFields :: forall e. GRepValue (ChannelRes e) -> [GRepField (ChannelRes e)]
toFields GRepValueObject {[GRepField (ChannelRes e)]
TypeName
objectTypeName :: TypeName
objectFields :: [GRepField (ChannelRes e)]
objectTypeName :: forall v. GRepValue v -> TypeName
objectFields :: forall v. GRepValue v -> [GRepField v]
..} = [GRepField (ChannelRes e)]
objectFields
toFields GRepValue (ChannelRes e)
_ = []

instance ExploreChannels ctx TRUE e (Undefined m) where
  exploreChannels :: forall (gql :: * -> Constraint) (val :: * -> Constraint)
       (f :: Bool -> *).
(UseDeriving gql val ~ ctx) =>
ctx -> f TRUE -> Undefined m -> HashMap FieldName (ChannelRes e)
exploreChannels ctx
_ f TRUE
_ = HashMap FieldName (ChannelRes e)
-> Undefined m -> HashMap FieldName (ChannelRes e)
forall a. a -> Undefined m -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap FieldName (ChannelRes e)
forall a. Monoid a => a
mempty