{-# 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 <- 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
. ResolverContext -> TypeDefinition ANY VALID
currentType)
  forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection (forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet SelectionSet VALID
selection) (forall (m :: * -> *).
Maybe TypeName -> ObjectTypeResolver m -> ResolverValue m
ResObject (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 =
  forall (m :: * -> *) a.
Monad m =>
ResolverMapT m a -> ResolverMap m -> m a
runBatchedT
    (forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection (forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet SelectionSet VALID
selection) (forall (m :: * -> *). m NamedResolverRef -> ResolverValue m
ResRef forall a b. (a -> b) -> a -> b
$ 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) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (ResolverValue m)
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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) = forall (stage :: Stage). [Value stage] -> Value stage
List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (stage :: Stage). ScalarValue -> Value stage
Scalar forall a b. (a -> b) -> a -> b
$ Text -> ScalarValue
String forall a b. (a -> b) -> a -> b
$ forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
name
resolveSelection selection :: SelectionContent VALID
selection@UnionSelection {} (ResEnum TypeName
name) = forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection SelectionContent VALID
selection (forall (m :: * -> *).
Monad m =>
TypeName -> [ResolverEntry m] -> ResolverValue m
mkUnion TypeName
name [(FieldName
unitFieldName, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). TypeName -> ResolverValue m
mkEnum TypeName
unitTypeName)])
resolveSelection SelectionContent VALID
_ ResEnum {} = 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (stage :: Stage). Value stage
Null
resolveSelection SelectionContent VALID
SelectionField (ResScalar ScalarValue
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (stage :: Stage). ScalarValue -> Value stage
Scalar ScalarValue
x
resolveSelection SelectionContent VALID
_ ResScalar {} = 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) = forall (m :: * -> *) value.
ResolverMonad m =>
Maybe TypeName
-> (Maybe (SelectionSet VALID) -> m value)
-> SelectionContent VALID
-> m value
withObject Maybe TypeName
typeName (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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *).
MonadResolver m =>
ObjectTypeResolver m -> Selection VALID -> m (ResolverValue m)
toResolverValue ObjectTypeResolver m
obj Selection VALID
s) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection (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) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadBatching t, ResolverMonad m) =>
SelectionContent VALID
-> NamedResolverRef -> t m (CacheKey, CacheValue m)
resolveRef SelectionContent VALID
selection forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
v
    (CachedResolver ResolverValue m
v) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(ResolverMonad (t m), MonadBatching t, MonadResolver m) =>
SelectionContent VALID -> ResolverValue m -> t m ValidValue
resolveSelection SelectionContent VALID
selection ResolverValue m
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 :: forall (s :: Stage). Selection s -> FieldName
selectionName :: FieldName
selectionName}
  | FieldName
selectionName forall a. Eq a => a -> a -> Bool
== FieldName
"__typename" = forall (m :: * -> *). Text -> ResolverValue m
mkString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
. ResolverContext -> TypeDefinition ANY VALID
currentType)
  | Bool
otherwise = forall (m' :: * -> *) a (m :: * -> *).
Monad m' =>
a
-> (m (ResolverValue m) -> m' a)
-> FieldName
-> ObjectTypeResolver m
-> m' a
withField forall (m :: * -> *). ResolverValue m
mkNull 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (stage :: Stage). Object stage -> Value stage
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall coll. Empty coll => coll
empty) (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 -> forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry (forall k a. KeyOf k a => a -> k
keyOf Selection VALID
sel) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)))