{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Resolving.RootResolverValue
  ( runRootResolverValue,
    RootResolverValue (..),
  )
where

import Control.Monad.Except (throwError)
import Data.Aeson (FromJSON (..))
import Data.HashMap.Strict (adjust)
import Data.Morpheus.App.Internal.Resolving.Event
  ( EventHandler (..),
  )
import Data.Morpheus.App.Internal.Resolving.MonadResolver
import Data.Morpheus.App.Internal.Resolving.ResolveValue
import Data.Morpheus.App.Internal.Resolving.Resolver
  ( Resolver,
    ResponseStream,
  )
import Data.Morpheus.App.Internal.Resolving.ResolverState
  ( ResolverState,
    toResolverStateT,
  )
import Data.Morpheus.App.Internal.Resolving.SchemaAPI (schemaAPI)
import Data.Morpheus.App.Internal.Resolving.Types
import Data.Morpheus.App.Internal.Resolving.Utils
  ( lookupResJSON,
  )
import Data.Morpheus.Types.Internal.AST
  ( MUTATION,
    Operation (..),
    OperationType (..),
    QUERY,
    SUBSCRIPTION,
    Schema (..),
    Selection,
    SelectionSet,
    TypeDefinition (typeName),
    TypeName,
    VALID,
    ValidValue,
    Value (..),
  )
import Relude hiding
  ( Show,
    empty,
    show,
  )

data RootResolverValue e m
  = RootResolverValue
      { forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m)),
        forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver :: ResolverState (ObjectTypeResolver (Resolver MUTATION e m)),
        forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver :: ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)),
        forall e (m :: * -> *).
RootResolverValue e m
-> Maybe (Selection VALID -> ResolverState (Channel e))
channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
      }
  | NamedResolversValue
      {forall e (m :: * -> *).
RootResolverValue e m -> ResolverMap (Resolver QUERY e m)
queryResolverMap :: ResolverMap (Resolver QUERY e m)}

instance Monad m => FromJSON (RootResolverValue e m) where
  parseJSON :: Value -> Parser (RootResolverValue e m)
parseJSON Value
res =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      RootResolverValue
        { queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver = forall (f :: * -> *) (m :: * -> *).
(ResolverMonad f, MonadReader ResolverContext m) =>
FieldName -> Value -> f (ObjectTypeResolver m)
lookupResJSON FieldName
"query" Value
res,
          mutationResolver :: ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver = forall (f :: * -> *) (m :: * -> *).
(ResolverMonad f, MonadReader ResolverContext m) =>
FieldName -> Value -> f (ObjectTypeResolver m)
lookupResJSON FieldName
"mutation" Value
res,
          subscriptionResolver :: ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver = forall (f :: * -> *) (m :: * -> *).
(ResolverMonad f, MonadReader ResolverContext m) =>
FieldName -> Value -> f (ObjectTypeResolver m)
lookupResJSON FieldName
"subscription" Value
res,
          channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
channelMap = forall a. Maybe a
Nothing
        }

rootResolver :: (MonadResolver m) => ResolverState (ObjectTypeResolver m) -> SelectionSet VALID -> m ValidValue
rootResolver :: forall (m :: * -> *).
MonadResolver m =>
ResolverState (ObjectTypeResolver m)
-> SelectionSet VALID -> m ValidValue
rootResolver ResolverState (ObjectTypeResolver m)
res SelectionSet VALID
selection = do
  ObjectTypeResolver m
root <- forall (m :: * -> *) a. MonadResolver m => ResolverState a -> m a
liftState (forall (m :: * -> *) a e.
Applicative m =>
ResolverState a -> ResolverStateT e m a
toResolverStateT ResolverState (ObjectTypeResolver m)
res)
  forall (m :: * -> *).
MonadResolver m =>
ObjectTypeResolver m -> SelectionSet VALID -> m ValidValue
resolvePlainRoot ObjectTypeResolver m
root SelectionSet VALID
selection

runRootResolverValue :: Monad m => RootResolverValue e m -> ResolverContext -> ResponseStream e m (Value VALID)
runRootResolverValue :: forall (m :: * -> *) e.
Monad m =>
RootResolverValue e m
-> ResolverContext -> ResponseStream e m ValidValue
runRootResolverValue
  RootResolverValue
    { ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver :: forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver,
      ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver :: ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver :: forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver,
      ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver :: ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver :: forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver,
      Maybe (Selection VALID -> ResolverState (Channel e))
channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
channelMap :: forall e (m :: * -> *).
RootResolverValue e m
-> Maybe (Selection VALID -> ResolverState (Channel e))
channelMap
    }
  ctx :: ResolverContext
ctx@ResolverContext {operation :: ResolverContext -> Operation VALID
operation = Operation {Maybe FieldName
SelectionSet VALID
OperationType
Position
Directives VALID
VariableDefinitions VALID
operationPosition :: forall (s :: Stage). Operation s -> Position
operationType :: forall (s :: Stage). Operation s -> OperationType
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationArguments :: forall (s :: Stage). Operation s -> VariableDefinitions s
operationDirectives :: forall (s :: Stage). Operation s -> Directives s
operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s
operationSelection :: SelectionSet VALID
operationDirectives :: Directives VALID
operationArguments :: VariableDefinitions VALID
operationName :: Maybe FieldName
operationType :: OperationType
operationPosition :: Position
..}} =
    OperationType
-> ResponseStream
     (MonadEvent (Resolver QUERY e m))
     (MonadParam (Resolver QUERY e m))
     ValidValue
selectByOperation OperationType
operationType
    where
      selectByOperation :: OperationType
-> ResponseStream
     (MonadEvent (Resolver QUERY e m))
     (MonadParam (Resolver QUERY e m))
     ValidValue
selectByOperation OperationType
OPERATION_QUERY =
        forall (m :: * -> *).
MonadResolver m =>
Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m)))
-> m ValidValue
-> ResolverContext
-> ResponseStream (MonadEvent m) (MonadParam m) ValidValue
runResolver Maybe (Selection VALID -> ResolverState (Channel e))
channelMap (forall (m :: * -> *).
MonadResolver m =>
ResolverState (ObjectTypeResolver m)
-> SelectionSet VALID -> m ValidValue
rootResolver (forall (m :: * -> *).
(MonadResolver m, MonadOperation m ~ QUERY) =>
ObjectTypeResolver m -> ObjectTypeResolver m
withIntroFields forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver) SelectionSet VALID
operationSelection) ResolverContext
ctx
      selectByOperation OperationType
OPERATION_MUTATION =
        forall (m :: * -> *).
MonadResolver m =>
Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m)))
-> m ValidValue
-> ResolverContext
-> ResponseStream (MonadEvent m) (MonadParam m) ValidValue
runResolver Maybe (Selection VALID -> ResolverState (Channel e))
channelMap (forall (m :: * -> *).
MonadResolver m =>
ResolverState (ObjectTypeResolver m)
-> SelectionSet VALID -> m ValidValue
rootResolver ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver SelectionSet VALID
operationSelection) ResolverContext
ctx
      selectByOperation OperationType
OPERATION_SUBSCRIPTION =
        forall (m :: * -> *).
MonadResolver m =>
Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m)))
-> m ValidValue
-> ResolverContext
-> ResponseStream (MonadEvent m) (MonadParam m) ValidValue
runResolver Maybe (Selection VALID -> ResolverState (Channel e))
channelMap (forall (m :: * -> *).
MonadResolver m =>
ResolverState (ObjectTypeResolver m)
-> SelectionSet VALID -> m ValidValue
rootResolver ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver SelectionSet VALID
operationSelection) ResolverContext
ctx
runRootResolverValue
  NamedResolversValue {ResolverMap (Resolver QUERY e m)
queryResolverMap :: ResolverMap (Resolver QUERY e m)
queryResolverMap :: forall e (m :: * -> *).
RootResolverValue e m -> ResolverMap (Resolver QUERY e m)
queryResolverMap}
  ctx :: ResolverContext
ctx@ResolverContext {operation :: ResolverContext -> Operation VALID
operation = Operation {Maybe FieldName
SelectionSet VALID
OperationType
Position
Directives VALID
VariableDefinitions VALID
operationSelection :: SelectionSet VALID
operationDirectives :: Directives VALID
operationArguments :: VariableDefinitions VALID
operationName :: Maybe FieldName
operationType :: OperationType
operationPosition :: Position
operationPosition :: forall (s :: Stage). Operation s -> Position
operationType :: forall (s :: Stage). Operation s -> OperationType
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationArguments :: forall (s :: Stage). Operation s -> VariableDefinitions s
operationDirectives :: forall (s :: Stage). Operation s -> Directives s
operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s
..}} =
    OperationType
-> ResponseStream
     (MonadEvent (Resolver QUERY e m))
     (MonadParam (Resolver QUERY e m))
     ValidValue
selectByOperation OperationType
operationType
    where
      selectByOperation :: OperationType
-> ResponseStream
     (MonadEvent (Resolver QUERY e m))
     (MonadParam (Resolver QUERY e m))
     ValidValue
selectByOperation OperationType
OPERATION_QUERY = forall (m :: * -> *).
MonadResolver m =>
Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m)))
-> m ValidValue
-> ResolverContext
-> ResponseStream (MonadEvent m) (MonadParam m) ValidValue
runResolver forall a. Maybe a
Nothing Resolver QUERY e m ValidValue
queryResolver ResolverContext
ctx
        where
          queryResolver :: Resolver QUERY e m ValidValue
queryResolver = do
            TypeName
name <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> Schema VALID
schema)
            forall (m :: * -> *).
MonadResolver m =>
TypeName -> ResolverMap m -> SelectionSet VALID -> m ValidValue
resolveNamedRoot TypeName
name (forall (m :: * -> *).
(MonadResolver m, MonadOperation m ~ QUERY) =>
TypeName -> ResolverMap m -> ResolverMap m
withNamedIntroFields TypeName
name ResolverMap (Resolver QUERY e m)
queryResolverMap) SelectionSet VALID
operationSelection
      selectByOperation OperationType
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
"mutation and subscription is not supported for namedResolvers"

withNamedIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => TypeName -> ResolverMap m -> ResolverMap m
withNamedIntroFields :: forall (m :: * -> *).
(MonadResolver m, MonadOperation m ~ QUERY) =>
TypeName -> ResolverMap m -> ResolverMap m
withNamedIntroFields = forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
adjust forall {m :: * -> *}.
(MonadOperation m ~ QUERY, MonadResolver m) =>
NamedResolver m -> NamedResolver m
updateNamed
  where
    updateNamed :: NamedResolver m -> NamedResolver m
updateNamed NamedResolver {TypeName
NamedResolverFun m
resolverFun :: forall (m :: * -> *). NamedResolver m -> NamedResolverFun m
resolverName :: forall (m :: * -> *). NamedResolver m -> TypeName
resolverFun :: NamedResolverFun m
resolverName :: TypeName
..} = NamedResolver {resolverFun :: NamedResolverFun m
resolverFun = forall a b. a -> b -> a
const (forall {m :: * -> *}.
(MonadOperation m ~ QUERY, MonadResolver m) =>
[NamedResolverResult m] -> [NamedResolverResult m]
updateResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamedResolverFun m
resolverFun [ValidValue
"ROOT"]), TypeName
resolverName :: TypeName
resolverName :: TypeName
..}
      where
        updateResult :: [NamedResolverResult m] -> [NamedResolverResult m]
updateResult [NamedObjectResolver ObjectTypeResolver m
obj] = [forall (m :: * -> *). ObjectTypeResolver m -> NamedResolverResult m
NamedObjectResolver (forall (m :: * -> *).
(MonadResolver m, MonadOperation m ~ QUERY) =>
ObjectTypeResolver m -> ObjectTypeResolver m
withIntroFields ObjectTypeResolver m
obj)]
        updateResult [NamedResolverResult m]
value = [NamedResolverResult m]
value

withIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => ObjectTypeResolver m -> ObjectTypeResolver m
withIntroFields :: forall (m :: * -> *).
(MonadResolver m, MonadOperation m ~ QUERY) =>
ObjectTypeResolver m -> ObjectTypeResolver m
withIntroFields (ObjectTypeResolver HashMap FieldName (m (ResolverValue m))
fields) = forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver (HashMap FieldName (m (ResolverValue m))
fields forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *).
ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m))
objectFields forall (m :: * -> *).
(MonadOperation m ~ QUERY, MonadResolver m) =>
ObjectTypeResolver m
schemaAPI)