{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Resolving.Batching
  ( ResolverMapT (..),
    SelectionRef,
    runBatchedT,
    MonadBatching (..),
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.ByteString.Lazy.Char8 (unpack)
import Data.HashMap.Lazy (keys)
import Data.Morpheus.App.Internal.Resolving.Cache
  ( CacheKey (..),
    CacheT,
    CacheValue (..),
    cacheResolverValues,
    cacheValue,
    isCached,
    printSelectionKey,
    useCached,
    withDebug,
  )
import Data.Morpheus.App.Internal.Resolving.Refs (scanRefs)
import Data.Morpheus.App.Internal.Resolving.ResolverState (ResolverContext)
import Data.Morpheus.App.Internal.Resolving.Types
  ( NamedResolver (..),
    NamedResolverResult (..),
    ResolverMap,
  )
import Data.Morpheus.App.Internal.Resolving.Utils
  ( NamedResolverRef (..),
    ResolverMonad,
    ResolverValue (ResEnum, ResNull, ResObject, ResRef, ResScalar),
  )
import Data.Morpheus.Core (render)
import Data.Morpheus.Internal.Utils (Empty (empty), IsMap (..), selectOr)
import Data.Morpheus.Types.Internal.AST
  ( GQLError,
    Msg (..),
    SelectionContent,
    TypeName,
    VALID,
    ValidValue,
    internal,
  )
import GHC.Show (Show (show))
import Relude hiding (empty, show)

data BatchEntry = BatchEntry
  { BatchEntry -> SelectionContent VALID
batchedSelection :: SelectionContent VALID,
    BatchEntry -> TypeName
batchedType :: TypeName,
    BatchEntry -> [ValidValue]
batchedArguments :: [ValidValue]
  }

instance Show BatchEntry where
  show :: BatchEntry -> String
show BatchEntry {[ValidValue]
TypeName
SelectionContent VALID
batchedSelection :: BatchEntry -> SelectionContent VALID
batchedType :: BatchEntry -> TypeName
batchedArguments :: BatchEntry -> [ValidValue]
batchedSelection :: SelectionContent VALID
batchedType :: TypeName
batchedArguments :: [ValidValue]
..} =
    String
"\nBATCH("
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeName -> String
forall a. ToString a => a -> String
toString TypeName
batchedType
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"):"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n  sel:"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SelectionContent VALID -> String
forall a. RenderGQL a => a -> String
printSelectionKey SelectionContent VALID
batchedSelection
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n  dep:"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show ((ValidValue -> String) -> [ValidValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
unpack (ByteString -> String)
-> (ValidValue -> ByteString) -> ValidValue -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidValue -> ByteString
forall a. RenderGQL a => a -> ByteString
render) [ValidValue]
batchedArguments)

type SelectionRef = (SelectionContent VALID, NamedResolverRef)

uniq :: (Eq a, Hashable a) => [a] -> [a]
uniq :: forall a. (Eq a, Hashable a) => [a] -> [a]
uniq = HashMap a Bool -> [a]
forall k v. HashMap k v -> [k]
keys (HashMap a Bool -> [a]) -> ([a] -> HashMap a Bool) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, Bool)] -> HashMap a Bool
forall a. [(a, a)] -> HashMap a a
forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a
unsafeFromList ([(a, Bool)] -> HashMap a Bool)
-> ([a] -> [(a, Bool)]) -> [a] -> HashMap a Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (a, Bool)) -> [a] -> [(a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (,Bool
True)

buildBatches :: [SelectionRef] -> [BatchEntry]
buildBatches :: [SelectionRef] -> [BatchEntry]
buildBatches [SelectionRef]
inputs =
  let entityTypes :: [(SelectionContent VALID, TypeName)]
entityTypes = [(SelectionContent VALID, TypeName)]
-> [(SelectionContent VALID, TypeName)]
forall a. (Eq a, Hashable a) => [a] -> [a]
uniq ([(SelectionContent VALID, TypeName)]
 -> [(SelectionContent VALID, TypeName)])
-> [(SelectionContent VALID, TypeName)]
-> [(SelectionContent VALID, TypeName)]
forall a b. (a -> b) -> a -> b
$ (SelectionRef -> (SelectionContent VALID, TypeName))
-> [SelectionRef] -> [(SelectionContent VALID, TypeName)]
forall a b. (a -> b) -> [a] -> [b]
map ((NamedResolverRef -> TypeName)
-> SelectionRef -> (SelectionContent VALID, TypeName)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second NamedResolverRef -> TypeName
resolverTypeName) [SelectionRef]
inputs
   in ((SelectionContent VALID, TypeName) -> Maybe BatchEntry)
-> [(SelectionContent VALID, TypeName)] -> [BatchEntry]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([SelectionRef]
-> (SelectionContent VALID, TypeName) -> Maybe BatchEntry
selectByEntity [SelectionRef]
inputs) [(SelectionContent VALID, TypeName)]
entityTypes

selectByEntity :: [SelectionRef] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry
selectByEntity :: [SelectionRef]
-> (SelectionContent VALID, TypeName) -> Maybe BatchEntry
selectByEntity [SelectionRef]
inputs (SelectionContent VALID
tSel, TypeName
tName) = case [SelectionRef] -> [ValidValue]
forall {a}. [(a, NamedResolverRef)] -> [ValidValue]
gerArgs ((SelectionRef -> Bool) -> [SelectionRef] -> [SelectionRef]
forall a. (a -> Bool) -> [a] -> [a]
filter SelectionRef -> Bool
areEq [SelectionRef]
inputs) of
  [] -> Maybe BatchEntry
forall a. Maybe a
Nothing
  [ValidValue]
args -> BatchEntry -> Maybe BatchEntry
forall a. a -> Maybe a
Just (SelectionContent VALID -> TypeName -> [ValidValue] -> BatchEntry
BatchEntry SelectionContent VALID
tSel TypeName
tName [ValidValue]
args)
    where

  where
    gerArgs :: [(a, NamedResolverRef)] -> [ValidValue]
gerArgs = [ValidValue] -> [ValidValue]
forall a. (Eq a, Hashable a) => [a] -> [a]
uniq ([ValidValue] -> [ValidValue])
-> ([(a, NamedResolverRef)] -> [ValidValue])
-> [(a, NamedResolverRef)]
-> [ValidValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, NamedResolverRef) -> [ValidValue])
-> [(a, NamedResolverRef)] -> [ValidValue]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NamedResolverRef -> [ValidValue]
resolverArgument (NamedResolverRef -> [ValidValue])
-> ((a, NamedResolverRef) -> NamedResolverRef)
-> (a, NamedResolverRef)
-> [ValidValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, NamedResolverRef) -> NamedResolverRef
forall a b. (a, b) -> b
snd)
    areEq :: SelectionRef -> Bool
areEq (SelectionContent VALID
sel, NamedResolverRef
v) = SelectionContent VALID
sel SelectionContent VALID -> SelectionContent VALID -> Bool
forall a. Eq a => a -> a -> Bool
== SelectionContent VALID
tSel Bool -> Bool -> Bool
&& TypeName
tName TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== NamedResolverRef -> TypeName
resolverTypeName NamedResolverRef
v

newtype ResolverMapT m a = ResolverMapT
  { forall (m :: * -> *) a.
ResolverMapT m a -> ReaderT (ResolverMap m) (CacheT m) a
_runResMapT :: ReaderT (ResolverMap m) (CacheT m) a
  }
  deriving
    ( (forall a b. (a -> b) -> ResolverMapT m a -> ResolverMapT m b)
-> (forall a b. a -> ResolverMapT m b -> ResolverMapT m a)
-> Functor (ResolverMapT m)
forall a b. a -> ResolverMapT m b -> ResolverMapT m a
forall a b. (a -> b) -> ResolverMapT m a -> ResolverMapT m b
forall (m :: * -> *) a b.
Functor m =>
a -> ResolverMapT m b -> ResolverMapT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ResolverMapT m a -> ResolverMapT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ResolverMapT m a -> ResolverMapT m b
fmap :: forall a b. (a -> b) -> ResolverMapT m a -> ResolverMapT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ResolverMapT m b -> ResolverMapT m a
<$ :: forall a b. a -> ResolverMapT m b -> ResolverMapT m a
Functor,
      Functor (ResolverMapT m)
Functor (ResolverMapT m) =>
(forall a. a -> ResolverMapT m a)
-> (forall a b.
    ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b)
-> (forall a b c.
    (a -> b -> c)
    -> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c)
-> (forall a b.
    ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b)
-> (forall a b.
    ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a)
-> Applicative (ResolverMapT m)
forall a. a -> ResolverMapT m a
forall a b.
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a
forall a b.
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
forall a b.
ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b
forall a b c.
(a -> b -> c)
-> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c
forall (m :: * -> *). Monad m => Functor (ResolverMapT m)
forall (m :: * -> *) a. Monad m => a -> ResolverMapT m a
forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a
forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> ResolverMapT m a
pure :: forall a. a -> ResolverMapT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b
<*> :: forall a b.
ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c
liftA2 :: forall a b c.
(a -> b -> c)
-> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
*> :: forall a b.
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a
<* :: forall a b.
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a
Applicative,
      Applicative (ResolverMapT m)
Applicative (ResolverMapT m) =>
(forall a b.
 ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b)
-> (forall a b.
    ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b)
-> (forall a. a -> ResolverMapT m a)
-> Monad (ResolverMapT m)
forall a. a -> ResolverMapT m a
forall a b.
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
forall a b.
ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b
forall (m :: * -> *). Monad m => Applicative (ResolverMapT m)
forall (m :: * -> *) a. Monad m => a -> ResolverMapT m a
forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b
>>= :: forall a b.
ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
>> :: forall a b.
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> ResolverMapT m a
return :: forall a. a -> ResolverMapT m a
Monad
    )

instance (MonadReader ResolverContext m) => MonadReader ResolverContext (ResolverMapT m) where
  ask :: ResolverMapT m ResolverContext
ask = ReaderT (ResolverMap m) (CacheT m) ResolverContext
-> ResolverMapT m ResolverContext
forall (m :: * -> *) a.
ReaderT (ResolverMap m) (CacheT m) a -> ResolverMapT m a
ResolverMapT (CacheT m ResolverContext
-> ReaderT (ResolverMap m) (CacheT m) ResolverContext
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (ResolverMap m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift CacheT m ResolverContext
forall r (m :: * -> *). MonadReader r m => m r
ask)
  local :: forall a.
(ResolverContext -> ResolverContext)
-> ResolverMapT m a -> ResolverMapT m a
local ResolverContext -> ResolverContext
f (ResolverMapT ReaderT (ResolverMap m) (CacheT m) a
m) = ReaderT (ResolverMap m) (CacheT m) a -> ResolverMapT m a
forall (m :: * -> *) a.
ReaderT (ResolverMap m) (CacheT m) a -> ResolverMapT m a
ResolverMapT ((ResolverMap m -> CacheT m a)
-> ReaderT (ResolverMap m) (CacheT m) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((ResolverContext -> ResolverContext) -> CacheT m a -> CacheT m a
forall a.
(ResolverContext -> ResolverContext)
-> StateT (CacheStore m) m a -> StateT (CacheStore m) m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ResolverContext -> ResolverContext
f (CacheT m a -> CacheT m a)
-> (ResolverMap m -> CacheT m a) -> ResolverMap m -> CacheT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT (ResolverMap m) (CacheT m) a -> ResolverMap m -> CacheT m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ResolverMap m) (CacheT m) a
m))

instance MonadTrans ResolverMapT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ResolverMapT m a
lift = ReaderT (ResolverMap m) (CacheT m) a -> ResolverMapT m a
forall (m :: * -> *) a.
ReaderT (ResolverMap m) (CacheT m) a -> ResolverMapT m a
ResolverMapT (ReaderT (ResolverMap m) (CacheT m) a -> ResolverMapT m a)
-> (m a -> ReaderT (ResolverMap m) (CacheT m) a)
-> m a
-> ResolverMapT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheT m a -> ReaderT (ResolverMap m) (CacheT m) a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (ResolverMap m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (CacheT m a -> ReaderT (ResolverMap m) (CacheT m) a)
-> (m a -> CacheT m a)
-> m a
-> ReaderT (ResolverMap m) (CacheT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> CacheT m a
forall (m :: * -> *) a. Monad m => m a -> StateT (CacheStore m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

deriving instance MonadError GQLError m => MonadError GQLError (ResolverMapT m)

runBatchedT :: Monad m => ResolverMapT m a -> ResolverMap m -> m a
runBatchedT :: forall (m :: * -> *) a.
Monad m =>
ResolverMapT m a -> ResolverMap m -> m a
runBatchedT (ResolverMapT ReaderT (ResolverMap m) (CacheT m) a
m) ResolverMap m
rmap = (a, CacheStore m) -> a
forall a b. (a, b) -> a
fst ((a, CacheStore m) -> a) -> m (a, CacheStore m) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (CacheStore m) m a -> CacheStore m -> m (a, CacheStore m)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT (ResolverMap m) (CacheT m) a
-> ResolverMap m -> StateT (CacheStore m) m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ResolverMap m) (CacheT m) a
m ResolverMap m
rmap) CacheStore m
forall coll. Empty coll => coll
empty

toKeys :: BatchEntry -> [CacheKey]
toKeys :: BatchEntry -> [CacheKey]
toKeys (BatchEntry SelectionContent VALID
sel TypeName
name [ValidValue]
deps) = (ValidValue -> CacheKey) -> [ValidValue] -> [CacheKey]
forall a b. (a -> b) -> [a] -> [b]
map (SelectionContent VALID -> TypeName -> ValidValue -> CacheKey
CacheKey SelectionContent VALID
sel TypeName
name) [ValidValue]
deps

inCache :: Monad m => CacheT m a -> ResolverMapT m a
inCache :: forall (m :: * -> *) a. Monad m => CacheT m a -> ResolverMapT m a
inCache = ReaderT (ResolverMap m) (StateT (CacheStore m) m) a
-> ResolverMapT m a
forall (m :: * -> *) a.
ReaderT (ResolverMap m) (CacheT m) a -> ResolverMapT m a
ResolverMapT (ReaderT (ResolverMap m) (StateT (CacheStore m) m) a
 -> ResolverMapT m a)
-> (CacheT m a
    -> ReaderT (ResolverMap m) (StateT (CacheStore m) m) a)
-> CacheT m a
-> ResolverMapT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheT m a -> ReaderT (ResolverMap m) (StateT (CacheStore m) m) a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (ResolverMap m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

class MonadTrans t => MonadBatching t where
  resolveRef :: ResolverMonad m => SelectionContent VALID -> NamedResolverRef -> t m (CacheKey, CacheValue m)
  storeValue :: ResolverMonad m => CacheKey -> ValidValue -> t m ValidValue

instance MonadBatching IdentityT where
  resolveRef :: forall (m :: * -> *).
ResolverMonad m =>
SelectionContent VALID
-> NamedResolverRef -> IdentityT m (CacheKey, CacheValue m)
resolveRef SelectionContent VALID
_ NamedResolverRef
_ = GQLError -> IdentityT m (CacheKey, CacheValue m)
forall a. GQLError -> IdentityT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> IdentityT m (CacheKey, CacheValue m))
-> GQLError -> IdentityT m (CacheKey, CacheValue m)
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
internal GQLError
"batching is only allowed with named resolvers"
  storeValue :: forall (m :: * -> *).
ResolverMonad m =>
CacheKey -> ValidValue -> IdentityT m ValidValue
storeValue CacheKey
_ ValidValue
_ = GQLError -> IdentityT m ValidValue
forall a. GQLError -> IdentityT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> IdentityT m ValidValue)
-> GQLError -> IdentityT m ValidValue
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
internal GQLError
"batching is only allowed with named resolvers"

instance MonadBatching ResolverMapT where
  resolveRef :: forall (m :: * -> *).
ResolverMonad m =>
SelectionContent VALID
-> NamedResolverRef -> ResolverMapT m (CacheKey, CacheValue m)
resolveRef SelectionContent VALID
sel (NamedResolverRef TypeName
typename [ValidValue
arg]) = do
    let key :: CacheKey
key = SelectionContent VALID -> TypeName -> ValidValue -> CacheKey
CacheKey SelectionContent VALID
sel TypeName
typename ValidValue
arg
    Bool
alreadyCached <- CacheT m Bool -> ResolverMapT m Bool
forall (m :: * -> *) a. Monad m => CacheT m a -> ResolverMapT m a
inCache (CacheKey -> CacheT m Bool
forall (m :: * -> *). Monad m => CacheKey -> CacheT m Bool
isCached CacheKey
key)
    if Bool
alreadyCached
      then () -> ResolverMapT m ()
forall a. a -> ResolverMapT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      else BatchEntry -> ResolverMapT m ()
forall (m :: * -> *).
ResolverMonad m =>
BatchEntry -> ResolverMapT m ()
prefetch (SelectionContent VALID -> TypeName -> [ValidValue] -> BatchEntry
BatchEntry SelectionContent VALID
sel TypeName
typename [ValidValue
arg])
    CacheT m (CacheKey, CacheValue m)
-> ResolverMapT m (CacheKey, CacheValue m)
forall (m :: * -> *) a. Monad m => CacheT m a -> ResolverMapT m a
inCache (CacheT m (CacheKey, CacheValue m)
 -> ResolverMapT m (CacheKey, CacheValue m))
-> CacheT m (CacheKey, CacheValue m)
-> ResolverMapT m (CacheKey, CacheValue m)
forall a b. (a -> b) -> a -> b
$ do
      CacheValue m
value <- CacheKey -> CacheT m (CacheValue m)
forall (m :: * -> *).
ResolverMonad m =>
CacheKey -> CacheT m (CacheValue m)
useCached CacheKey
key
      (CacheKey, CacheValue m) -> CacheT m (CacheKey, CacheValue m)
forall a. a -> StateT (CacheStore m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CacheKey
key, CacheValue m
value)
  resolveRef SelectionContent VALID
_ NamedResolverRef
ref = GQLError -> ResolverMapT m (CacheKey, CacheValue m)
forall a. GQLError -> ResolverMapT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal (GQLError
"expected only one resolved value for " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> String -> GQLError
forall a. Msg a => a -> GQLError
msg (NamedResolverRef -> String
forall a. Show a => a -> String
show NamedResolverRef
ref :: String)))
  storeValue :: forall (m :: * -> *).
ResolverMonad m =>
CacheKey -> ValidValue -> ResolverMapT m ValidValue
storeValue CacheKey
key = CacheT m ValidValue -> ResolverMapT m ValidValue
forall (m :: * -> *) a. Monad m => CacheT m a -> ResolverMapT m a
inCache (CacheT m ValidValue -> ResolverMapT m ValidValue)
-> (ValidValue -> CacheT m ValidValue)
-> ValidValue
-> ResolverMapT m ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheKey -> ValidValue -> CacheT m ValidValue
forall (m :: * -> *).
Monad m =>
CacheKey -> ValidValue -> CacheT m ValidValue
cacheValue CacheKey
key

prefetch :: ResolverMonad m => BatchEntry -> ResolverMapT m ()
prefetch :: forall (m :: * -> *).
ResolverMonad m =>
BatchEntry -> ResolverMapT m ()
prefetch BatchEntry
batch = do
  [ResolverValue m]
value <- BatchEntry -> ResolverMapT m [ResolverValue m]
run BatchEntry
batch
  [BatchEntry]
batches <- [SelectionRef] -> [BatchEntry]
buildBatches ([SelectionRef] -> [BatchEntry])
-> ([[SelectionRef]] -> [SelectionRef])
-> [[SelectionRef]]
-> [BatchEntry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[SelectionRef]] -> [SelectionRef]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[SelectionRef]] -> [BatchEntry])
-> ResolverMapT m [[SelectionRef]] -> ResolverMapT m [BatchEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ResolverValue m -> ResolverMapT m [SelectionRef])
-> [ResolverValue m] -> ResolverMapT m [[SelectionRef]]
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 (m [SelectionRef] -> ResolverMapT m [SelectionRef]
forall (m :: * -> *) a. Monad m => m a -> ResolverMapT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [SelectionRef] -> ResolverMapT m [SelectionRef])
-> (ResolverValue m -> m [SelectionRef])
-> ResolverValue m
-> ResolverMapT m [SelectionRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SelectionContent VALID -> ResolverValue m -> m [SelectionRef]
forall (m :: * -> *).
ResolverMonad m =>
SelectionContent VALID -> ResolverValue m -> m [SelectionRef]
scanRefs (BatchEntry -> SelectionContent VALID
batchedSelection BatchEntry
batch)) [ResolverValue m]
value
  [(BatchEntry, [ResolverValue m])]
resolvedEntries <- (BatchEntry -> ResolverMapT m (BatchEntry, [ResolverValue m]))
-> [BatchEntry] -> ResolverMapT m [(BatchEntry, [ResolverValue m])]
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 (\BatchEntry
b -> (BatchEntry
b,) ([ResolverValue m] -> (BatchEntry, [ResolverValue m]))
-> ResolverMapT m [ResolverValue m]
-> ResolverMapT m (BatchEntry, [ResolverValue m])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BatchEntry -> ResolverMapT m [ResolverValue m]
run BatchEntry
b) [BatchEntry]
batches
  let caches :: [(CacheKey, ResolverValue m)]
caches = ((BatchEntry, [ResolverValue m]) -> [(CacheKey, ResolverValue m)])
-> [(BatchEntry, [ResolverValue m])]
-> [(CacheKey, ResolverValue m)]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (BatchEntry, [ResolverValue m]) -> [(CacheKey, ResolverValue m)]
forall {b}. (BatchEntry, [b]) -> [(CacheKey, b)]
zipCaches ([(BatchEntry, [ResolverValue m])]
 -> [(CacheKey, ResolverValue m)])
-> [(BatchEntry, [ResolverValue m])]
-> [(CacheKey, ResolverValue m)]
forall a b. (a -> b) -> a -> b
$ (BatchEntry
batch, [ResolverValue m]
value) (BatchEntry, [ResolverValue m])
-> [(BatchEntry, [ResolverValue m])]
-> [(BatchEntry, [ResolverValue m])]
forall a. a -> [a] -> [a]
: [(BatchEntry, [ResolverValue m])]
resolvedEntries
  CacheT m () -> ResolverMapT m ()
forall (m :: * -> *) a. Monad m => CacheT m a -> ResolverMapT m a
inCache (CacheT m () -> ResolverMapT m ())
-> CacheT m () -> ResolverMapT m ()
forall a b. (a -> b) -> a -> b
$ [(CacheKey, ResolverValue m)] -> CacheT m ()
forall (m :: * -> *).
ResolverMonad m =>
[(CacheKey, ResolverValue m)] -> CacheT m ()
cacheResolverValues [(CacheKey, ResolverValue m)]
caches
  where
    zipCaches :: (BatchEntry, [b]) -> [(CacheKey, b)]
zipCaches (BatchEntry
b, [b]
res) = [CacheKey] -> [b] -> [(CacheKey, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip (BatchEntry -> [CacheKey]
toKeys BatchEntry
b) [b]
res
    run :: BatchEntry -> ResolverMapT m [ResolverValue m]
run = BatchEntry -> ResolverMapT m BatchEntry
forall a (m :: * -> *).
(Show a, MonadReader ResolverContext m) =>
a -> m a
withDebug (BatchEntry -> ResolverMapT m BatchEntry)
-> (BatchEntry -> ResolverMapT m [ResolverValue m])
-> BatchEntry
-> ResolverMapT m [ResolverValue m]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BatchEntry -> ResolverMapT m [ResolverValue m]
forall (m :: * -> *).
(MonadError GQLError m, MonadReader ResolverContext m) =>
BatchEntry -> ResolverMapT m [ResolverValue m]
runBatch

runBatch :: (MonadError GQLError m, MonadReader ResolverContext m) => BatchEntry -> ResolverMapT m [ResolverValue m]
runBatch :: forall (m :: * -> *).
(MonadError GQLError m, MonadReader ResolverContext m) =>
BatchEntry -> ResolverMapT m [ResolverValue m]
runBatch (BatchEntry SelectionContent VALID
_ TypeName
name [ValidValue]
deps)
  | [ValidValue] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ValidValue]
deps = [ResolverValue m] -> ResolverMapT m [ResolverValue m]
forall a. a -> ResolverMapT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  | Bool
otherwise = do
      HashMap TypeName (NamedResolver m)
resolvers <- ReaderT
  (HashMap TypeName (NamedResolver m))
  (CacheT m)
  (HashMap TypeName (NamedResolver m))
-> ResolverMapT m (HashMap TypeName (NamedResolver m))
forall (m :: * -> *) a.
ReaderT (ResolverMap m) (CacheT m) a -> ResolverMapT m a
ResolverMapT ReaderT
  (HashMap TypeName (NamedResolver m))
  (CacheT m)
  (HashMap TypeName (NamedResolver m))
forall r (m :: * -> *). MonadReader r m => m r
ask
      NamedResolver {NamedResolverFun m
resolverFun :: NamedResolverFun m
resolverFun :: forall (m :: * -> *). NamedResolver m -> NamedResolverFun m
resolverFun} <- m (NamedResolver m) -> ResolverMapT m (NamedResolver m)
forall (m :: * -> *) a. Monad m => m a -> ResolverMapT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (NamedResolver m)
-> (NamedResolver m -> m (NamedResolver m))
-> TypeName
-> HashMap TypeName (NamedResolver m)
-> m (NamedResolver m)
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr m (NamedResolver m)
notFound NamedResolver m -> m (NamedResolver m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeName
name HashMap TypeName (NamedResolver m)
resolvers)
      (NamedResolverResult m -> ResolverValue m)
-> [NamedResolverResult m] -> [ResolverValue m]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName -> NamedResolverResult m -> ResolverValue m
forall (m :: * -> *).
Monad m =>
TypeName -> NamedResolverResult m -> ResolverValue m
toResolverValue TypeName
name) ([NamedResolverResult m] -> [ResolverValue m])
-> ResolverMapT m [NamedResolverResult m]
-> ResolverMapT m [ResolverValue m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [NamedResolverResult m] -> ResolverMapT m [NamedResolverResult m]
forall (m :: * -> *) a. Monad m => m a -> ResolverMapT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (NamedResolverFun m
resolverFun [ValidValue]
deps)
  where
    notFound :: m (NamedResolver m)
notFound = GQLError -> m (NamedResolver m)
forall a. GQLError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError
"resolver type " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> GQLError
forall a. Msg a => a -> GQLError
msg TypeName
name GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"can't found")

toResolverValue :: (Monad m) => TypeName -> NamedResolverResult m -> ResolverValue m
toResolverValue :: forall (m :: * -> *).
Monad m =>
TypeName -> NamedResolverResult m -> ResolverValue m
toResolverValue TypeName
typeName (NamedObjectResolver ObjectTypeResolver m
res) = 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
typeName) ObjectTypeResolver m
res
toResolverValue TypeName
_ (NamedUnionResolver NamedResolverRef
unionRef) = 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 NamedResolverRef
unionRef
toResolverValue TypeName
_ (NamedEnumResolver TypeName
value) = TypeName -> ResolverValue m
forall (m :: * -> *). TypeName -> ResolverValue m
ResEnum TypeName
value
toResolverValue TypeName
_ NamedResolverResult m
NamedNullResolver = ResolverValue m
forall (m :: * -> *). ResolverValue m
ResNull
toResolverValue TypeName
_ (NamedScalarResolver ScalarValue
v) = ScalarValue -> ResolverValue m
forall (m :: * -> *). ScalarValue -> ResolverValue m
ResScalar ScalarValue
v