{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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
  ( CacheKey (..),
    LocalCache,
    useCached,
    buildCacheWith,
    ResolverMapContext (..),
    ResolverMapT (..),
    runResMapT,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.ByteString.Lazy.Char8 (unpack)
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.App.Internal.Resolving.Types (NamedResolverRef (..), ResolverMap)
import Data.Morpheus.Core (RenderGQL, render)
import Data.Morpheus.Types.Internal.AST
  ( GQLError,
    Msg (..),
    SelectionContent,
    TypeName,
    VALID,
    ValidValue,
    internal,
  )
import GHC.Show (Show (show))
import Relude hiding (show)

type LocalCache = HashMap CacheKey ValidValue

useCached :: (Eq k, Show k, Hashable k, MonadError GQLError f) => HashMap k a -> k -> f a
useCached :: forall k (f :: * -> *) a.
(Eq k, Show k, Hashable k, MonadError GQLError f) =>
HashMap k a -> k -> f a
useCached HashMap k a
mp k
v = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup k
v HashMap k a
mp of
  Just a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  Maybe a
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal forall a b. (a -> b) -> a -> b
$ GQLError
"cache value could not found for key" forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (forall a. Show a => a -> String
show k
v :: String))

dumpCache :: Bool -> LocalCache -> a -> a
dumpCache :: forall a. Bool -> LocalCache -> a -> a
dumpCache Bool
enabled LocalCache
xs a
a
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null LocalCache
xs Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
enabled = a
a
  | Bool
otherwise = forall a. String -> a -> a
trace (String
"\nCACHE:\n" forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (Show a, RenderGQL a) => (a, a) -> String
printKeyValue forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
HM.toList LocalCache
xs) forall a. Semigroup a => a -> a -> a
<> String
"\n") a
a
  where
    printKeyValue :: (a, a) -> String
printKeyValue (a
key, a
v) = String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
key forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> ByteString -> String
unpack (forall a. RenderGQL a => a -> ByteString
render a
v)

printSel :: RenderGQL a => a -> [Char]
printSel :: forall a. RenderGQL a => a -> String
printSel a
sel = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
ignoreSpaces forall a b. (a -> b) -> a -> b
$ ByteString -> String
unpack (forall a. RenderGQL a => a -> ByteString
render a
sel)
  where
    ignoreSpaces :: Char -> Bool
ignoreSpaces Char
x = Char
x forall a. Eq a => a -> a -> Bool
/= Char
' '
    replace :: Char -> Char
replace Char
'\n' = Char
' '
    replace Char
x = Char
x

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]
SelectionContent VALID
TypeName
batchedArguments :: [ValidValue]
batchedType :: TypeName
batchedSelection :: SelectionContent VALID
batchedArguments :: BatchEntry -> [ValidValue]
batchedType :: BatchEntry -> TypeName
batchedSelection :: BatchEntry -> SelectionContent VALID
..} = forall a. RenderGQL a => a -> String
printSel SelectionContent VALID
batchedSelection forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> forall a. ToString a => a -> String
toString TypeName
batchedType forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RenderGQL a => a -> ByteString
render) [ValidValue]
batchedArguments)

data CacheKey = CacheKey
  { CacheKey -> SelectionContent VALID
cachedSel :: SelectionContent VALID,
    CacheKey -> TypeName
cachedTypeName :: TypeName,
    CacheKey -> ValidValue
cachedArg :: ValidValue
  }
  deriving (CacheKey -> CacheKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CacheKey -> CacheKey -> Bool
$c/= :: CacheKey -> CacheKey -> Bool
== :: CacheKey -> CacheKey -> Bool
$c== :: CacheKey -> CacheKey -> Bool
Eq, forall x. Rep CacheKey x -> CacheKey
forall x. CacheKey -> Rep CacheKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CacheKey x -> CacheKey
$cfrom :: forall x. CacheKey -> Rep CacheKey x
Generic)

instance Show CacheKey where
  show :: CacheKey -> String
show (CacheKey SelectionContent VALID
sel TypeName
typename ValidValue
dep) = forall a. RenderGQL a => a -> String
printSel SelectionContent VALID
sel forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> forall a. ToString a => a -> String
toString TypeName
typename forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> ByteString -> String
unpack (forall a. RenderGQL a => a -> ByteString
render ValidValue
dep)

instance Hashable CacheKey where
  hashWithSalt :: Int -> CacheKey -> Int
hashWithSalt Int
s (CacheKey SelectionContent VALID
sel TypeName
tyName ValidValue
arg) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (SelectionContent VALID
sel, TypeName
tyName, forall a. RenderGQL a => a -> ByteString
render ValidValue
arg)

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

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

selectByEntity :: [(SelectionContent VALID, NamedResolverRef)] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry
selectByEntity :: [(SelectionContent VALID, NamedResolverRef)]
-> (SelectionContent VALID, TypeName) -> Maybe BatchEntry
selectByEntity [(SelectionContent VALID, NamedResolverRef)]
inputs (SelectionContent VALID
tSel, TypeName
tName) = case forall a. (a -> Bool) -> [a] -> [a]
filter (SelectionContent VALID, NamedResolverRef) -> Bool
areEq [(SelectionContent VALID, NamedResolverRef)]
inputs of
  [] -> forall a. Maybe a
Nothing
  [(SelectionContent VALID, NamedResolverRef)]
xs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SelectionContent VALID -> TypeName -> [ValidValue] -> BatchEntry
BatchEntry SelectionContent VALID
tSel TypeName
tName (forall a. (Eq a, Hashable a) => [a] -> [a]
uniq forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NamedResolverRef -> [ValidValue]
resolverArgument forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(SelectionContent VALID, NamedResolverRef)]
xs)
  where
    areEq :: (SelectionContent VALID, NamedResolverRef) -> Bool
areEq (SelectionContent VALID
sel, NamedResolverRef
v) = SelectionContent VALID
sel forall a. Eq a => a -> a -> Bool
== SelectionContent VALID
tSel Bool -> Bool -> Bool
&& TypeName
tName forall a. Eq a => a -> a -> Bool
== NamedResolverRef -> TypeName
resolverTypeName NamedResolverRef
v

type ResolverFun m = NamedResolverRef -> SelectionContent VALID -> m [ValidValue]

resolveBatched :: Monad m => ResolverFun m -> BatchEntry -> m LocalCache
resolveBatched :: forall (m :: * -> *).
Monad m =>
ResolverFun m -> BatchEntry -> m LocalCache
resolveBatched ResolverFun m
f (BatchEntry SelectionContent VALID
sel TypeName
name [ValidValue]
deps) = do
  [ValidValue]
res <- ResolverFun m
f (TypeName -> [ValidValue] -> NamedResolverRef
NamedResolverRef TypeName
name [ValidValue]
deps) SelectionContent VALID
sel
  let keys :: [CacheKey]
keys = forall a b. (a -> b) -> [a] -> [b]
map (SelectionContent VALID -> TypeName -> ValidValue -> CacheKey
CacheKey SelectionContent VALID
sel TypeName
name) [ValidValue]
deps
  let entries :: [(CacheKey, ValidValue)]
entries = forall a b. [a] -> [b] -> [(a, b)]
zip [CacheKey]
keys [ValidValue]
res
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(CacheKey, ValidValue)]
entries

updateCache :: (Monad m, Traversable t) => ResolverFun m -> LocalCache -> t BatchEntry -> m LocalCache
updateCache :: forall (m :: * -> *) (t :: * -> *).
(Monad m, Traversable t) =>
ResolverFun m -> LocalCache -> t BatchEntry -> m LocalCache
updateCache ResolverFun m
f LocalCache
cache t BatchEntry
entries = do
  t LocalCache
caches <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
Monad m =>
ResolverFun m -> BatchEntry -> m LocalCache
resolveBatched ResolverFun m
f) t BatchEntry
entries
  let newCache :: LocalCache
newCache = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Semigroup a => a -> a -> a
(<>) LocalCache
cache t LocalCache
caches
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Bool -> LocalCache -> a -> a
dumpCache Bool
False LocalCache
newCache LocalCache
newCache

buildCacheWith :: Monad m => ResolverFun m -> LocalCache -> [(SelectionContent VALID, NamedResolverRef)] -> m LocalCache
buildCacheWith :: forall (m :: * -> *).
Monad m =>
ResolverFun m
-> LocalCache
-> [(SelectionContent VALID, NamedResolverRef)]
-> m LocalCache
buildCacheWith ResolverFun m
f LocalCache
cache [(SelectionContent VALID, NamedResolverRef)]
entries = forall (m :: * -> *) (t :: * -> *).
(Monad m, Traversable t) =>
ResolverFun m -> LocalCache -> t BatchEntry -> m LocalCache
updateCache ResolverFun m
f LocalCache
cache ([(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry]
buildBatches [(SelectionContent VALID, NamedResolverRef)]
entries)

data ResolverMapContext m = ResolverMapContext
  { forall (m :: * -> *). ResolverMapContext m -> LocalCache
localCache :: LocalCache,
    forall (m :: * -> *). ResolverMapContext m -> ResolverMap m
resolverMap :: ResolverMap m
  }

newtype ResolverMapT m a = ResolverMapT
  { forall (m :: * -> *) a.
ResolverMapT m a -> ReaderT (ResolverMapContext m) m a
_runResMapT :: ReaderT (ResolverMapContext m) m a
  }
  deriving
    ( 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
<$ :: forall a b. a -> ResolverMapT m b -> ResolverMapT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ResolverMapT m b -> ResolverMapT m a
fmap :: forall a b. (a -> b) -> ResolverMapT m a -> ResolverMapT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ResolverMapT m a -> ResolverMapT m b
Functor,
      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 (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
forall {m :: * -> *}. Applicative m => Functor (ResolverMapT m)
forall (m :: * -> *) a. Applicative m => a -> ResolverMapT m a
forall (m :: * -> *) a b.
Applicative m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a
forall (m :: * -> *) a b.
Applicative m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
forall (m :: * -> *) a b.
Applicative m =>
ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c
<* :: forall a b.
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a
*> :: forall a b.
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b
liftA2 :: forall a b c.
(a -> b -> c)
-> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c
<*> :: forall a b.
ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b
pure :: forall a. a -> ResolverMapT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> ResolverMapT m a
Applicative,
      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
return :: forall a. a -> ResolverMapT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> ResolverMapT m a
>> :: 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 b
>>= :: forall a b.
ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b
Monad,
      MonadReader (ResolverMapContext m)
    )

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

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

runResMapT :: ResolverMapT m a -> ResolverMapContext m -> m a
runResMapT :: forall (m :: * -> *) a.
ResolverMapT m a -> ResolverMapContext m -> m a
runResMapT (ResolverMapT ReaderT (ResolverMapContext m) m a
x) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ResolverMapContext m) m a
x