{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.Deriving.Channels
  ( channelResolver,
    ChannelsConstraint,
  )
where

import Data.Morpheus.Internal.Utils
  ( Failure (..),
    elems,
    selectBy,
  )
import Data.Morpheus.Server.Deriving.Decode
  ( DecodeConstraint,
    decodeArguments,
  )
import Data.Morpheus.Server.Deriving.Utils
  ( ConsRep (..),
    DataType (..),
    FieldRep (..),
    TypeConstraint (..),
    TypeRep (..),
    toValue,
  )
import Data.Morpheus.Server.Types.GQLType (GQLType)
import Data.Morpheus.Types.Internal.AST
  ( FieldName (..),
    InternalError,
    SUBSCRIPTION,
    Selection (..),
    SelectionContent (..),
    VALID,
  )
import Data.Morpheus.Types.Internal.Resolving
  ( Channel,
    Resolver,
    ResolverState,
    SubscriptionField (..),
  )
import GHC.Generics
import Relude

newtype DerivedChannel e = DerivedChannel
  { DerivedChannel e -> Channel e
_unpackChannel :: Channel e
  }

type ChannelRes (e :: *) = Selection VALID -> ResolverState (DerivedChannel e)

type ChannelsConstraint e m (subs :: (* -> *) -> *) =
  ExploreConstraint 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 :: subs (Resolver SUBSCRIPTION e m)
-> Selection VALID -> ResolverState (Channel e)
channelResolver subs (Resolver SUBSCRIPTION e m)
value = (DerivedChannel e -> Channel e)
-> ResolverStateT () Identity (DerivedChannel e)
-> ResolverState (Channel e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DerivedChannel e -> Channel e
forall e. DerivedChannel e -> Channel e
_unpackChannel (ResolverStateT () Identity (DerivedChannel e)
 -> ResolverState (Channel e))
-> (Selection VALID
    -> ResolverStateT () Identity (DerivedChannel e))
-> Selection VALID
-> ResolverState (Channel e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection VALID -> ResolverStateT () Identity (DerivedChannel e)
channelSelector
  where
    channelSelector ::
      Selection VALID ->
      ResolverState (DerivedChannel e)
    channelSelector :: Selection VALID -> ResolverStateT () Identity (DerivedChannel e)
channelSelector = [(FieldName,
  Selection VALID -> ResolverStateT () Identity (DerivedChannel e))]
-> Selection VALID -> ResolverStateT () Identity (DerivedChannel e)
forall e. [(FieldName, ChannelRes e)] -> ChannelRes e
selectBySelection (subs (Resolver SUBSCRIPTION e m)
-> [(FieldName,
     Selection VALID -> ResolverStateT () Identity (DerivedChannel e))]
forall e a.
ExploreConstraint e a =>
a -> [(FieldName, ChannelRes e)]
exploreChannels subs (Resolver SUBSCRIPTION e m)
value)

selectBySelection ::
  [(FieldName, ChannelRes e)] ->
  Selection VALID ->
  ResolverState (DerivedChannel e)
selectBySelection :: [(FieldName, ChannelRes e)] -> ChannelRes e
selectBySelection [(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
>=> [(FieldName, ChannelRes e)] -> ChannelRes e
forall e. [(FieldName, ChannelRes e)] -> ChannelRes e
selectSubscription [(FieldName, ChannelRes e)]
channels

selectSubscription ::
  [(FieldName, ChannelRes e)] ->
  Selection VALID ->
  ResolverState (DerivedChannel e)
selectSubscription :: [(FieldName, ChannelRes e)] -> ChannelRes e
selectSubscription [(FieldName, ChannelRes e)]
channels sel :: Selection VALID
sel@Selection {FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName :: FieldName
selectionName} =
  InternalError
-> FieldName
-> [(FieldName, ChannelRes e)]
-> ResolverStateT () Identity (FieldName, ChannelRes e)
forall e (m :: * -> *) k a c.
(Failure e m, Selectable k a c, Monad m) =>
e -> k -> c -> m a
selectBy
    InternalError
onFail
    FieldName
selectionName
    [(FieldName, ChannelRes e)]
channels
    ResolverStateT () Identity (FieldName, ChannelRes e)
-> ((FieldName, ChannelRes e)
    -> ResolverStateT () Identity (DerivedChannel e))
-> ResolverStateT () Identity (DerivedChannel e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FieldName, ChannelRes e)
-> ResolverStateT () Identity (DerivedChannel e)
forall a t. (a, Selection VALID -> t) -> t
onSucc
  where
    onFail :: InternalError
onFail = InternalError
"invalid subscription: no channel is selected." :: InternalError
    onSucc :: (a, Selection VALID -> t) -> t
onSucc (a
_, Selection VALID -> t
f) = Selection VALID -> t
f Selection VALID
sel

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 SelectionSet VALID -> [Selection VALID]
forall a coll. Elems a coll => coll -> [a]
elems SelectionSet VALID
selSet of
    [Selection VALID
sel] -> Selection VALID -> ResolverState (Selection VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Selection VALID
sel
    [Selection VALID]
_ -> InternalError -> ResolverState (Selection VALID)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (InternalError
"invalid subscription: there can be only one top level selection" :: InternalError)
withSubscriptionSelection Selection VALID
_ = InternalError -> ResolverState (Selection VALID)
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (InternalError
"invalid subscription: expected selectionSet" :: InternalError)

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 = ResolverStateT () Identity (DerivedChannel e) -> ChannelRes e
forall a b. a -> b -> a
const (ResolverStateT () Identity (DerivedChannel e) -> ChannelRes e)
-> (SubscriptionField (Resolver SUBSCRIPTION e m a)
    -> ResolverStateT () Identity (DerivedChannel e))
-> SubscriptionField (Resolver SUBSCRIPTION e m a)
-> ChannelRes e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivedChannel e -> ResolverStateT () Identity (DerivedChannel e)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DerivedChannel e -> ResolverStateT () Identity (DerivedChannel e))
-> (SubscriptionField (Resolver SUBSCRIPTION e m a)
    -> DerivedChannel e)
-> SubscriptionField (Resolver SUBSCRIPTION e m a)
-> ResolverStateT () Identity (DerivedChannel e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel e -> DerivedChannel e
forall e. Channel e -> DerivedChannel e
DerivedChannel (Channel e -> DerivedChannel e)
-> (SubscriptionField (Resolver SUBSCRIPTION e m a) -> Channel e)
-> SubscriptionField (Resolver SUBSCRIPTION e m a)
-> DerivedChannel e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SubscriptionField (Resolver SUBSCRIPTION e m a) -> Channel e
forall a.
SubscriptionField a
-> forall e (m :: * -> *) v.
   (a ~ Resolver SUBSCRIPTION e m v) =>
   Channel e
channel

instance
  DecodeConstraint 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} =
    Arguments VALID -> ResolverState arg
forall a. DecodeConstraint a => Arguments VALID -> ResolverState a
decodeArguments Arguments VALID
selectionArguments ResolverState arg
-> (arg -> ResolverStateT () Identity (DerivedChannel e))
-> ResolverStateT () Identity (DerivedChannel e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SubscriptionField (Resolver SUBSCRIPTION e m a) -> ChannelRes e
forall e a. GetChannel e a => a -> ChannelRes e
`getChannel` Selection VALID
sel)
      (SubscriptionField (Resolver SUBSCRIPTION e m a)
 -> ResolverStateT () Identity (DerivedChannel e))
-> (arg -> SubscriptionField (Resolver SUBSCRIPTION e m a))
-> arg
-> ResolverStateT () Identity (DerivedChannel e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. arg -> SubscriptionField (Resolver SUBSCRIPTION e m a)
f

------------------------------------------------------

type ExploreConstraint e a =
  ( GQLType a,
    Generic a,
    TypeRep (GetChannel e) (ChannelRes e) (Rep a)
  )

exploreChannels :: forall e a. ExploreConstraint e a => a -> [(FieldName, ChannelRes e)]
exploreChannels :: a -> [(FieldName, ChannelRes e)]
exploreChannels =
  DataType (ChannelRes e) -> [(FieldName, ChannelRes e)]
forall e. DataType (ChannelRes e) -> [(FieldName, ChannelRes e)]
convertNode
    (DataType (ChannelRes e) -> [(FieldName, ChannelRes e)])
-> (a -> DataType (ChannelRes e))
-> a
-> [(FieldName, ChannelRes e)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeConstraint (GetChannel e) (ChannelRes e) Identity
-> a -> DataType (ChannelRes e)
forall (constraint :: * -> Constraint) value a.
(GQLType a, Generic a, TypeRep constraint value (Rep a)) =>
TypeConstraint constraint value Identity -> a -> DataType value
toValue
      ( (forall a. GetChannel e a => Identity a -> ChannelRes e)
-> TypeConstraint (GetChannel e) (ChannelRes e) Identity
forall (c :: * -> Constraint) v (f :: * -> *).
(forall a. c a => f a -> v) -> TypeConstraint c v f
TypeConstraint (a -> ChannelRes e
forall e a. GetChannel e a => a -> ChannelRes e
getChannel (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) :: TypeConstraint (GetChannel e) (ChannelRes e) Identity
      )

convertNode :: DataType (ChannelRes e) -> [(FieldName, ChannelRes e)]
convertNode :: DataType (ChannelRes e) -> [(FieldName, ChannelRes e)]
convertNode DataType {tyCons :: forall v. DataType v -> ConsRep v
tyCons = ConsRep {[FieldRep (ChannelRes e)]
consFields :: forall v. ConsRep v -> [FieldRep v]
consFields :: [FieldRep (ChannelRes e)]
consFields}} = (FieldRep (ChannelRes e) -> (FieldName, ChannelRes e))
-> [FieldRep (ChannelRes e)] -> [(FieldName, ChannelRes e)]
forall a b. (a -> b) -> [a] -> [b]
map FieldRep (ChannelRes e) -> (FieldName, ChannelRes e)
forall b. FieldRep b -> (FieldName, b)
toChannels [FieldRep (ChannelRes e)]
consFields
  where
    toChannels :: FieldRep b -> (FieldName, b)
toChannels FieldRep {FieldName
fieldSelector :: forall a. FieldRep a -> FieldName
fieldSelector :: FieldName
fieldSelector, b
fieldValue :: forall a. FieldRep a -> a
fieldValue :: b
fieldValue} = (FieldName
fieldSelector, b
fieldValue)