{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Resolving.Cache
  ( CacheKey (..),
    CacheStore (..),
    printSelectionKey,
    useCached,
    isCached,
    withDebug,
    cacheResolverValues,
    cacheValue,
    CacheValue (..),
    CacheT,
  )
where

import Control.Monad.Except
import Data.ByteString.Lazy.Char8 (unpack)
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.App.Internal.Resolving.ResolverState
import Data.Morpheus.App.Internal.Resolving.Types (ResolverValue)
import Data.Morpheus.App.Internal.Resolving.Utils (ResolverMonad)
import Data.Morpheus.Core (Config (debug), RenderGQL, render)
import Data.Morpheus.Internal.Utils
  ( Empty (..),
    IsMap (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( Msg (msg),
    SelectionContent,
    TypeName,
    VALID,
    ValidValue,
    internal,
  )
import Debug.Trace (trace)
import Relude hiding (Show, empty, show, trace)
import Prelude (Show (show))

type CacheT m = (StateT (CacheStore m) m)

printSelectionKey :: RenderGQL a => a -> String
printSelectionKey :: forall a. RenderGQL a => a -> String
printSelectionKey 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 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)

data CacheValue m
  = CachedValue ValidValue
  | CachedResolver (ResolverValue m)

instance Show (CacheValue m) where
  show :: CacheValue m -> String
show (CachedValue ValidValue
v) = ByteString -> String
unpack (forall a. RenderGQL a => a -> ByteString
render ValidValue
v)
  show (CachedResolver ResolverValue m
v) = forall a. Show a => a -> String
show ResolverValue m
v

instance Show CacheKey where
  show :: CacheKey -> String
show (CacheKey SelectionContent VALID
sel TypeName
typename ValidValue
dep) = forall a. RenderGQL a => a -> String
printSelectionKey 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)

newtype CacheStore m = CacheStore {forall (m :: * -> *).
CacheStore m -> HashMap CacheKey (CacheValue m)
_unpackStore :: HashMap CacheKey (CacheValue m)}

instance Show (CacheStore m) where
  show :: CacheStore m -> String
show (CacheStore HashMap CacheKey (CacheValue m)
cache) = 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, Show a) => (a, a) -> String
printKeyValue forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)]
toAssoc HashMap CacheKey (CacheValue m)
cache) forall a. Semigroup a => a -> a -> a
<> String
"\n"
    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
<> forall a. Show a => a -> String
show a
v

instance Empty (CacheStore m) where
  empty :: CacheStore m
empty = forall (m :: * -> *).
HashMap CacheKey (CacheValue m) -> CacheStore m
CacheStore forall coll. Empty coll => coll
empty

cacheResolverValues :: ResolverMonad m => [(CacheKey, ResolverValue m)] -> CacheT m ()
cacheResolverValues :: forall (m :: * -> *).
ResolverMonad m =>
[(CacheKey, ResolverValue m)] -> CacheT m ()
cacheResolverValues [(CacheKey, ResolverValue m)]
pres = do
  CacheStore HashMap CacheKey (CacheValue m)
oldCache <- forall s (m :: * -> *). MonadState s m => m s
get
  let updates :: HashMap CacheKey (CacheValue m)
updates = forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a
unsafeFromList (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall (m :: * -> *). ResolverValue m -> CacheValue m
CachedResolver) [(CacheKey, ResolverValue m)]
pres)
  CacheStore m
cache <- forall a (m :: * -> *).
(Show a, MonadReader ResolverContext m) =>
String -> a -> m a
labeledDebug String
"\nUPDATE|>" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
HashMap CacheKey (CacheValue m) -> CacheStore m
CacheStore forall a b. (a -> b) -> a -> b
$ HashMap CacheKey (CacheValue m)
updates forall a. Semigroup a => a -> a -> a
<> HashMap CacheKey (CacheValue m)
oldCache
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a b. a -> b -> a
const CacheStore m
cache)

useCached :: ResolverMonad m => CacheKey -> CacheT m (CacheValue m)
useCached :: forall (m :: * -> *).
ResolverMonad m =>
CacheKey -> CacheT m (CacheValue m)
useCached CacheKey
v = do
  CacheStore m
cache <- forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a (m :: * -> *).
(Show a, MonadReader ResolverContext m) =>
String -> a -> m a
labeledDebug String
"\nUSE|>"
  case forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
lookup CacheKey
v (forall (m :: * -> *).
CacheStore m -> HashMap CacheKey (CacheValue m)
_unpackStore CacheStore m
cache) of
    Just CacheValue m
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CacheValue m
x
    Maybe (CacheValue m)
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 CacheKey
v :: String))

isCached :: Monad m => CacheKey -> CacheT m Bool
isCached :: forall (m :: * -> *). Monad m => CacheKey -> CacheT m Bool
isCached CacheKey
key = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
lookup CacheKey
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
CacheStore m -> HashMap CacheKey (CacheValue m)
_unpackStore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get

setValue :: (CacheKey, ValidValue) -> CacheStore m -> CacheStore m
setValue :: forall (m :: * -> *).
(CacheKey, ValidValue) -> CacheStore m -> CacheStore m
setValue (CacheKey
key, ValidValue
value) = forall (m :: * -> *).
HashMap CacheKey (CacheValue m) -> CacheStore m
CacheStore forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert CacheKey
key (forall (m :: * -> *). ValidValue -> CacheValue m
CachedValue ValidValue
value) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
CacheStore m -> HashMap CacheKey (CacheValue m)
_unpackStore

labeledDebug :: (Show a, MonadReader ResolverContext m) => String -> a -> m a
labeledDebug :: forall a (m :: * -> *).
(Show a, MonadReader ResolverContext m) =>
String -> a -> m a
labeledDebug String
label a
v = Bool -> a
showValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Config -> Bool
debug forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> Config
config)
  where
    showValue :: Bool -> a
showValue Bool
enabled
      | Bool
enabled = forall a. String -> a -> a
trace (String
label forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
v) a
v
      | Bool
otherwise = a
v

withDebug :: (Show a, MonadReader ResolverContext m) => a -> m a
withDebug :: forall a (m :: * -> *).
(Show a, MonadReader ResolverContext m) =>
a -> m a
withDebug = forall a (m :: * -> *).
(Show a, MonadReader ResolverContext m) =>
String -> a -> m a
labeledDebug String
""

cacheValue :: Monad m => CacheKey -> ValidValue -> CacheT m ValidValue
cacheValue :: forall (m :: * -> *).
Monad m =>
CacheKey -> ValidValue -> CacheT m ValidValue
cacheValue CacheKey
key ValidValue
value = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (m :: * -> *).
(CacheKey, ValidValue) -> CacheStore m -> CacheStore m
setValue (CacheKey
key, ValidValue
value)) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ValidValue
value