{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Resolving.ResolveValue
  ( resolvePlainRoot,
    resolveNamedRoot,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Morpheus.App.Internal.Resolving.Batching
  ( MonadBatching (..),
    runBatchedT,
  )
import Data.Morpheus.App.Internal.Resolving.Cache (CacheValue (..))
import Data.Morpheus.App.Internal.Resolving.MonadResolver (MonadResolver)
import Data.Morpheus.App.Internal.Resolving.ResolverState
  ( ResolverContext (..),
    inSelectionField,
  )
import Data.Morpheus.App.Internal.Resolving.Types
  ( ResolverMap,
    mkEnum,
    mkNull,
    mkString,
    mkUnion,
  )
import Data.Morpheus.App.Internal.Resolving.Utils
import Data.Morpheus.Internal.Utils
  ( KeyOf (keyOf),
    empty,
    traverseCollection,
  )
import Data.Morpheus.Types.Internal.AST
  ( ObjectEntry (ObjectEntry),
    ScalarValue (..),
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    TypeDefinition (..),
    TypeName,
    VALID,
    ValidValue,
    Value (..),
    internal,
    unitFieldName,
    unitTypeName,
    unpackName,
  )
import Relude hiding (empty)

-- UNCACHED
resolvePlainRoot :: MonadResolver m => ObjectTypeResolver m -> SelectionSet VALID -> m ValidValue
resolvePlainRoot :: forall (m :: * -> *).
MonadResolver m =>
ObjectTypeResolver m -> SelectionSet VALID -> m ValidValue
resolvePlainRoot ObjectTypeResolver m
resolver SelectionSet VALID
selection = do
  TypeName
name <- (ResolverContext -> TypeName) -> m TypeName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TypeDefinition ANY VALID -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeDefinition ANY VALID -> TypeName)
-> (ResolverContext -> TypeDefinition ANY VALID)
-> ResolverContext
-> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> TypeDefinition ANY VALID
currentType)
  IdentityT m ValidValue -> m ValidValue
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (SelectionContent VALID -> ResolverValue m -> IdentityT m ValidValue
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection (SelectionSet VALID -> SelectionContent VALID
forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet SelectionSet VALID
selection) (Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
forall (m :: * -> *).
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
ResObject (TypeName -> Maybe TypeName
forall a. a -> Maybe a
Just TypeName
name) ObjectTypeResolver m
resolver))

-- CACHED
resolveNamedRoot :: MonadResolver m => TypeName -> ResolverMap m -> SelectionSet VALID -> m ValidValue
resolveNamedRoot :: forall (m :: * -> *).
MonadResolver m =>
TypeName -> ResolverMap m -> SelectionSet VALID -> m ValidValue
resolveNamedRoot TypeName
typeName ResolverMap m
resolvers SelectionSet VALID
selection =
  ResolverMapT m ValidValue -> ResolverMap m -> m ValidValue
forall (m :: * -> *) a.
Monad m =>
ResolverMapT m a -> ResolverMap m -> m a
runBatchedT
    (SelectionContent VALID
-> ResolverValue m -> ResolverMapT m ValidValue
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection (SelectionSet VALID -> SelectionContent VALID
forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet SelectionSet VALID
selection) (m NamedResolverRef -> ResolverValue m
forall (m :: * -> *). m NamedResolverRef -> ResolverValue m
ResRef (m NamedResolverRef -> ResolverValue m)
-> m NamedResolverRef -> ResolverValue m
forall a b. (a -> b) -> a -> b
$ NamedResolverRef -> m NamedResolverRef
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> NamedResolverArg -> NamedResolverRef
NamedResolverRef TypeName
typeName [ValidValue
"ROOT"])))
    ResolverMap m
resolvers

-- RESOLVING

resolveSelection :: (ResolverMonad (t m), MonadBatching t, MonadResolver m) => SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection :: forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection SelectionContent VALID
selection (ResLazy m (ResolverValue m)
x) = m (ResolverValue m) -> t m (ResolverValue m)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (ResolverValue m)
x t m (ResolverValue m)
-> (ResolverValue m -> t m ValidValue) -> t m ValidValue
forall a b. t m a -> (a -> t m b) -> t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SelectionContent VALID -> ResolverValue m -> t m ValidValue
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection SelectionContent VALID
selection
resolveSelection SelectionContent VALID
selection (ResList [ResolverValue m]
xs) = NamedResolverArg -> ValidValue
forall (stage :: Stage). [Value stage] -> Value stage
List (NamedResolverArg -> ValidValue)
-> t m NamedResolverArg -> t m ValidValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ResolverValue m -> t m ValidValue)
-> [ResolverValue m] -> t m NamedResolverArg
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (SelectionContent VALID -> ResolverValue m -> t m ValidValue
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection SelectionContent VALID
selection) [ResolverValue m]
xs
resolveSelection SelectionContent VALID
SelectionField (ResEnum TypeName
name) = ValidValue -> t m ValidValue
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidValue -> t m ValidValue) -> ValidValue -> t m ValidValue
forall a b. (a -> b) -> a -> b
$ ScalarValue -> ValidValue
forall (stage :: Stage). ScalarValue -> Value stage
Scalar (ScalarValue -> ValidValue) -> ScalarValue -> ValidValue
forall a b. (a -> b) -> a -> b
$ Text -> ScalarValue
String (Text -> ScalarValue) -> Text -> ScalarValue
forall a b. (a -> b) -> a -> b
$ TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName TypeName
name
resolveSelection selection :: SelectionContent VALID
selection@UnionSelection {} (ResEnum TypeName
name) = SelectionContent VALID -> ResolverValue m -> t m ValidValue
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection SelectionContent VALID
selection (TypeName -> [ResolverEntry m] -> ResolverValue m
forall (m :: * -> *).
Monad m =>
TypeName -> [ResolverEntry m] -> ResolverValue m
mkUnion TypeName
name [(FieldName
unitFieldName, ResolverValue m -> m (ResolverValue m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolverValue m -> m (ResolverValue m))
-> ResolverValue m -> m (ResolverValue m)
forall a b. (a -> b) -> a -> b
$ TypeName -> ResolverValue m
forall (m :: * -> *). TypeName -> ResolverValue m
mkEnum TypeName
unitTypeName)])
resolveSelection SelectionContent VALID
_ ResEnum {} = GQLError -> t m ValidValue
forall a. GQLError -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"wrong selection on enum value")
resolveSelection SelectionContent VALID
_ ResolverValue m
ResNull = ValidValue -> t m ValidValue
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
forall (stage :: Stage). Value stage
Null
resolveSelection SelectionContent VALID
SelectionField (ResScalar ScalarValue
x) = ValidValue -> t m ValidValue
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValidValue -> t m ValidValue) -> ValidValue -> t m ValidValue
forall a b. (a -> b) -> a -> b
$ ScalarValue -> ValidValue
forall (stage :: Stage). ScalarValue -> Value stage
Scalar ScalarValue
x
resolveSelection SelectionContent VALID
_ ResScalar {} = GQLError -> t m ValidValue
forall a. GQLError -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal GQLError
"scalar resolver should only receive SelectionField")
resolveSelection SelectionContent VALID
selection (ResObject Maybe TypeName
typeName ObjectTypeResolver m
obj) = Maybe TypeName
-> (Maybe (SelectionSet VALID) -> t m ValidValue)
-> SelectionContent VALID
-> t m ValidValue
forall (m :: * -> *) value.
ResolverMonad m =>
Maybe TypeName
-> (Maybe (SelectionSet VALID) -> m value)
-> SelectionContent VALID
-> m value
withObject Maybe TypeName
typeName ((Selection VALID -> t m ValidValue)
-> Maybe (SelectionSet VALID) -> t m ValidValue
forall (m :: * -> *).
ResolverMonad m =>
(Selection VALID -> m ValidValue)
-> Maybe (SelectionSet VALID) -> m ValidValue
mapSelectionSet Selection VALID -> t m ValidValue
resolveField) SelectionContent VALID
selection
  where
    resolveField :: Selection VALID -> t m ValidValue
resolveField Selection VALID
s = m (ResolverValue m) -> t m (ResolverValue m)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ObjectTypeResolver m -> Selection VALID -> m (ResolverValue m)
forall (m :: * -> *).
MonadResolver m =>
ObjectTypeResolver m -> Selection VALID -> m (ResolverValue m)
toResolverValue ObjectTypeResolver m
obj Selection VALID
s) t m (ResolverValue m)
-> (ResolverValue m -> t m ValidValue) -> t m ValidValue
forall a b. t m a -> (a -> t m b) -> t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SelectionContent VALID -> ResolverValue m -> t m ValidValue
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection (Selection VALID -> SelectionContent VALID
forall (s :: Stage). Selection s -> SelectionContent s
selectionContent Selection VALID
s)
resolveSelection SelectionContent VALID
selection (ResRef m NamedResolverRef
mRef) = do
  (CacheKey
key, CacheValue m
value) <- SelectionContent VALID
-> NamedResolverRef -> t m (CacheKey, CacheValue m)
forall (m :: * -> *).
ResolverMonad m =>
SelectionContent VALID
-> NamedResolverRef -> t m (CacheKey, CacheValue m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadBatching t, ResolverMonad m) =>
SelectionContent VALID
-> NamedResolverRef -> t m (CacheKey, CacheValue m)
resolveRef SelectionContent VALID
selection (NamedResolverRef -> t m (CacheKey, CacheValue m))
-> t m NamedResolverRef -> t m (CacheKey, CacheValue m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m NamedResolverRef -> t m NamedResolverRef
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m NamedResolverRef
mRef
  case CacheValue m
value of
    (CachedValue ValidValue
v) -> ValidValue -> t m ValidValue
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
v
    (CachedResolver ResolverValue m
v) -> SelectionContent VALID -> ResolverValue m -> t m ValidValue
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection SelectionContent VALID
selection ResolverValue m
v t m ValidValue -> (ValidValue -> t m ValidValue) -> t m ValidValue
forall a b. t m a -> (a -> t m b) -> t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CacheKey -> ValidValue -> t m ValidValue
forall (m :: * -> *).
ResolverMonad m =>
CacheKey -> ValidValue -> t m ValidValue
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadBatching t, ResolverMonad m) =>
CacheKey -> ValidValue -> t m ValidValue
storeValue CacheKey
key

toResolverValue ::
  (MonadResolver m) =>
  ObjectTypeResolver m ->
  Selection VALID ->
  m (ResolverValue m)
toResolverValue :: forall (m :: * -> *).
MonadResolver m =>
ObjectTypeResolver m -> Selection VALID -> m (ResolverValue m)
toResolverValue ObjectTypeResolver m
obj Selection {FieldName
selectionName :: FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName}
  | FieldName
selectionName FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
"__typename" = Text -> ResolverValue m
forall (m :: * -> *). Text -> ResolverValue m
mkString (Text -> ResolverValue m)
-> (TypeName -> Text) -> TypeName -> ResolverValue m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName (TypeName -> ResolverValue m) -> m TypeName -> m (ResolverValue m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ResolverContext -> TypeName) -> m TypeName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TypeDefinition ANY VALID -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeDefinition ANY VALID -> TypeName)
-> (ResolverContext -> TypeDefinition ANY VALID)
-> ResolverContext
-> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> TypeDefinition ANY VALID
currentType)
  | Bool
otherwise = ResolverValue m
-> (m (ResolverValue m) -> m (ResolverValue m))
-> FieldName
-> ObjectTypeResolver m
-> m (ResolverValue m)
forall (m' :: * -> *) a (m :: * -> *).
Monad m' =>
a
-> (m (ResolverValue m) -> m' a)
-> FieldName
-> ObjectTypeResolver m
-> m' a
withField ResolverValue m
forall (m :: * -> *). ResolverValue m
mkNull m (ResolverValue m) -> m (ResolverValue m)
forall a. a -> a
id FieldName
selectionName ObjectTypeResolver m
obj

mapSelectionSet :: (ResolverMonad m) => (Selection VALID -> m ValidValue) -> Maybe (SelectionSet VALID) -> m ValidValue
mapSelectionSet :: forall (m :: * -> *).
ResolverMonad m =>
(Selection VALID -> m ValidValue)
-> Maybe (SelectionSet VALID) -> m ValidValue
mapSelectionSet Selection VALID -> m ValidValue
f = (Object VALID -> ValidValue) -> m (Object VALID) -> m ValidValue
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object (m (Object VALID) -> m ValidValue)
-> (Maybe (MergeMap 'False FieldName (Selection VALID))
    -> m (Object VALID))
-> Maybe (MergeMap 'False FieldName (Selection VALID))
-> m ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Object VALID)
-> (MergeMap 'False FieldName (Selection VALID)
    -> m (Object VALID))
-> Maybe (MergeMap 'False FieldName (Selection VALID))
-> m (Object VALID)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Object VALID -> m (Object VALID)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object VALID
forall coll. Empty coll => coll
empty) ((Selection VALID -> m (ObjectEntry VALID))
-> MergeMap 'False FieldName (Selection VALID) -> m (Object VALID)
forall (m :: * -> *) k b (map :: * -> * -> *) (t :: * -> *) a.
(Monad m, MonadError GQLError m, KeyOf k b, FromList m map k b,
 Foldable t) =>
(a -> m b) -> t a -> m (map k b)
traverseCollection (\Selection VALID
sel -> FieldName -> ValidValue -> ObjectEntry VALID
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry (Selection VALID -> FieldName
forall k a. KeyOf k a => a -> k
keyOf Selection VALID
sel) (ValidValue -> ObjectEntry VALID)
-> m ValidValue -> m (ObjectEntry VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Selection VALID -> m ValidValue -> m ValidValue
forall (m :: * -> *) b.
(MonadReader ResolverContext m, MonadError GQLError m) =>
Selection VALID -> m b -> m b
inSelectionField Selection VALID
sel (Selection VALID -> m ValidValue
f Selection VALID
sel)))