{-# LANGUAGE TemplateHaskell #-}

-- | A 'Cache' handler that operates in memory
module Calamity.Cache.InMemory (
  runCacheInMemory,
  runCacheInMemory',
  runCacheInMemoryNoMsg,
) where

import Calamity.Cache.Eff
import qualified Calamity.Internal.BoundedStore as BS
import qualified Calamity.Internal.SnowflakeMap as SM
import Calamity.Internal.Utils
import Calamity.Types.Model.Channel
import Calamity.Types.Model.Guild
import Calamity.Types.Model.User
import Calamity.Types.Snowflake
import Control.Applicative
import Data.Functor.Identity
import Control.Monad.State.Strict
import Data.Foldable
import qualified Data.HashMap.Strict as SH
import qualified Data.HashSet as HS
import Data.IORef
import Optics
import qualified Polysemy as P
import qualified Polysemy.AtomicState as P
import Optics.State.Operators ((?=), (%=))

data Cache f = Cache
  { forall (f :: * -> *). Cache f -> Maybe User
user :: Maybe User
  , forall (f :: * -> *). Cache f -> SnowflakeMap Guild
guilds :: !(SM.SnowflakeMap Guild)
  , forall (f :: * -> *). Cache f -> SnowflakeMap DMChannel
dms :: !(SM.SnowflakeMap DMChannel)
  , forall (f :: * -> *).
Cache f -> HashMap (Snowflake GuildChannel) Guild
guildChannels :: !(SH.HashMap (Snowflake GuildChannel) Guild)
  , forall (f :: * -> *). Cache f -> SnowflakeMap User
users :: !(SM.SnowflakeMap User)
  , forall (f :: * -> *). Cache f -> HashSet (Snowflake Guild)
unavailableGuilds :: !(HS.HashSet (Snowflake Guild))
  , forall (f :: * -> *). Cache f -> f (BoundedStore Message)
messages :: !(f (BS.BoundedStore Message))
  }

$(makeFieldLabelsNoPrefix ''Cache)

type CacheWithMsg = Cache Identity
type CacheNoMsg = Cache (Const ())

emptyCache :: CacheWithMsg
emptyCache :: CacheWithMsg
emptyCache = forall (f :: * -> *).
Maybe User
-> SnowflakeMap Guild
-> SnowflakeMap DMChannel
-> HashMap (Snowflake GuildChannel) Guild
-> SnowflakeMap User
-> HashSet (Snowflake Guild)
-> f (BoundedStore Message)
-> Cache f
Cache forall a. Maybe a
Nothing forall a. SnowflakeMap a
SM.empty forall a. SnowflakeMap a
SM.empty forall k v. HashMap k v
SH.empty forall a. SnowflakeMap a
SM.empty forall a. HashSet a
HS.empty (forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall a. Int -> BoundedStore a
BS.empty Int
1000)

emptyCacheNoMsg :: CacheNoMsg
emptyCacheNoMsg :: CacheNoMsg
emptyCacheNoMsg = forall (f :: * -> *).
Maybe User
-> SnowflakeMap Guild
-> SnowflakeMap DMChannel
-> HashMap (Snowflake GuildChannel) Guild
-> SnowflakeMap User
-> HashSet (Snowflake Guild)
-> f (BoundedStore Message)
-> Cache f
Cache forall a. Maybe a
Nothing forall a. SnowflakeMap a
SM.empty forall a. SnowflakeMap a
SM.empty forall k v. HashMap k v
SH.empty forall a. SnowflakeMap a
SM.empty forall a. HashSet a
HS.empty (forall {k} a (b :: k). a -> Const a b
Const ())

emptyCache' :: Int -> CacheWithMsg
emptyCache' :: Int -> CacheWithMsg
emptyCache' Int
msgLimit = forall (f :: * -> *).
Maybe User
-> SnowflakeMap Guild
-> SnowflakeMap DMChannel
-> HashMap (Snowflake GuildChannel) Guild
-> SnowflakeMap User
-> HashSet (Snowflake Guild)
-> f (BoundedStore Message)
-> Cache f
Cache forall a. Maybe a
Nothing forall a. SnowflakeMap a
SM.empty forall a. SnowflakeMap a
SM.empty forall k v. HashMap k v
SH.empty forall a. SnowflakeMap a
SM.empty forall a. HashSet a
HS.empty (forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$ forall a. Int -> BoundedStore a
BS.empty Int
msgLimit)

-- | Run the cache in memory with a default message cache size of 1000
runCacheInMemory :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a
runCacheInMemory :: forall (r :: EffectRow) a.
Member (Embed IO) r =>
Sem (CacheEff : r) a -> Sem r a
runCacheInMemory Sem (CacheEff : r) a
m = do
  IORef CacheWithMsg
var <- forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef CacheWithMsg
emptyCache
  forall s (r :: EffectRow) a.
Member (Embed IO) r =>
IORef s -> Sem (AtomicState s : r) a -> Sem r a
P.runAtomicStateIORef IORef CacheWithMsg
var forall a b. (a -> b) -> a -> b
$ forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpret forall {k} (t :: * -> *) (r :: EffectRow) (m :: k) a.
(MessageMod (Cache t), Member (AtomicState (Cache t)) r) =>
CacheEff m a -> Sem r a
runCache' Sem (CacheEff : r) a
m

-- | Run the cache in memory with no messages being cached
runCacheInMemoryNoMsg :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a
runCacheInMemoryNoMsg :: forall (r :: EffectRow) a.
Member (Embed IO) r =>
Sem (CacheEff : r) a -> Sem r a
runCacheInMemoryNoMsg Sem (CacheEff : r) a
m = do
  IORef CacheNoMsg
var <- forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef CacheNoMsg
emptyCacheNoMsg
  forall s (r :: EffectRow) a.
Member (Embed IO) r =>
IORef s -> Sem (AtomicState s : r) a -> Sem r a
P.runAtomicStateIORef IORef CacheNoMsg
var forall a b. (a -> b) -> a -> b
$ forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpret forall {k} (t :: * -> *) (r :: EffectRow) (m :: k) a.
(MessageMod (Cache t), Member (AtomicState (Cache t)) r) =>
CacheEff m a -> Sem r a
runCache' Sem (CacheEff : r) a
m

-- | Run the cache in memory with a configurable message cache limit
runCacheInMemory' :: P.Member (P.Embed IO) r => Int -> P.Sem (CacheEff ': r) a -> P.Sem r a
runCacheInMemory' :: forall (r :: EffectRow) a.
Member (Embed IO) r =>
Int -> Sem (CacheEff : r) a -> Sem r a
runCacheInMemory' Int
msgLimit Sem (CacheEff : r) a
m = do
  IORef CacheWithMsg
var <- forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
P.embed forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef (Int -> CacheWithMsg
emptyCache' Int
msgLimit)
  forall s (r :: EffectRow) a.
Member (Embed IO) r =>
IORef s -> Sem (AtomicState s : r) a -> Sem r a
P.runAtomicStateIORef IORef CacheWithMsg
var forall a b. (a -> b) -> a -> b
$ forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpret forall {k} (t :: * -> *) (r :: EffectRow) (m :: k) a.
(MessageMod (Cache t), Member (AtomicState (Cache t)) r) =>
CacheEff m a -> Sem r a
runCache' Sem (CacheEff : r) a
m

runCache' :: (MessageMod (Cache t), P.Member (P.AtomicState (Cache t)) r) => CacheEff m a -> P.Sem r a
runCache' :: forall {k} (t :: * -> *) (r :: EffectRow) (m :: k) a.
(MessageMod (Cache t), Member (AtomicState (Cache t)) r) =>
CacheEff m a -> Sem r a
runCache' CacheEff m a
act = forall s a (r :: EffectRow).
Member (AtomicState s) r =>
(s -> (s, a)) -> Sem r a
P.atomicState' ((forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. State s a -> s -> (a, s)
runState forall a b. (a -> b) -> a -> b
$ forall {k} (t :: * -> *) (m :: k) a.
MessageMod (Cache t) =>
CacheEff m a -> State (Cache t) a
runCache CacheEff m a
act)

class MessageMod t where
  setMessage' :: Message -> State t ()
  getMessage' :: Snowflake Message -> State t (Maybe Message)
  getMessages' :: State t [Message]
  delMessage' :: Snowflake Message -> State t ()

instance MessageMod CacheWithMsg where
  setMessage' :: Message -> State CacheWithMsg ()
setMessage' Message
m = forall a. IsLabel "messages" a => a
#messages forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s t a b. Field1 s t a b => Lens s t a b
_1 forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> (a -> b) -> m ()
%= forall a. HasID' a => a -> BoundedStore a -> BoundedStore a
BS.addItem Message
m
  getMessage' :: Snowflake Message -> State CacheWithMsg (Maybe Message)
getMessage' Snowflake Message
mid = forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (forall a. IsLabel "messages" a => a
#messages forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s t a b. Field1 s t a b => Lens s t a b
_1 forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at' Snowflake Message
mid)
  getMessages' :: State CacheWithMsg [Message]
getMessages' = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (forall a. IsLabel "messages" a => a
#messages forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s t a b. Field1 s t a b => Lens s t a b
_1)
  delMessage' :: Snowflake Message -> State CacheWithMsg ()
delMessage' Snowflake Message
mid = forall a. IsLabel "messages" a => a
#messages forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall s t a b. Field1 s t a b => Lens s t a b
_1 forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> (a -> b) -> m ()
%= forall m. At m => Index m -> m -> m
sans Snowflake Message
mid

instance MessageMod CacheNoMsg where
  setMessage' :: Message -> State CacheNoMsg ()
setMessage' !Message
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  getMessage' :: Snowflake Message -> State CacheNoMsg (Maybe Message)
getMessage' !Snowflake Message
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  getMessages' :: State CacheNoMsg [Message]
getMessages' = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  delMessage' :: Snowflake Message -> State CacheNoMsg ()
delMessage' !Snowflake Message
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

runCache :: MessageMod (Cache t) => CacheEff m a -> State (Cache t) a
runCache :: forall {k} (t :: * -> *) (m :: k) a.
MessageMod (Cache t) =>
CacheEff m a -> State (Cache t) a
runCache (SetBotUser User
u) = forall a. IsLabel "user" a => a
#user forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s (Maybe a) (Maybe b) -> b -> m ()
?= User
u
runCache CacheEff m a
GetBotUser = forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use forall a. IsLabel "user" a => a
#user
runCache (SetGuild Guild
g) = do
  #guilds %= SM.insert g
  #guildChannels %= SH.filter (\v -> getID @Guild v /= getID @Guild g)
  #guildChannels %= SH.union (SH.fromList $ map (, g) (SM.keys (g ^. #channels)))
runCache (GetGuild Snowflake Guild
gid) = forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (forall a. IsLabel "guilds" a => a
#guilds forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at' Snowflake Guild
gid)
runCache (GetGuildChannel Snowflake GuildChannel
cid) = forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (forall a. IsLabel "guildChannels" a => a
#guildChannels forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at' Snowflake GuildChannel
cid) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall a. IsLabel "channels" a => a
#channels forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at' Snowflake GuildChannel
cid))
runCache CacheEff m a
GetGuilds = forall a. SnowflakeMap a -> [a]
SM.elems forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use forall a. IsLabel "guilds" a => a
#guilds
runCache (DelGuild Snowflake Guild
gid) = do
  #guilds %= sans gid
  #guildChannels %= SH.filter (\v -> getID @Guild v /= gid)
runCache (SetDM DMChannel
dm) = forall a. IsLabel "dms" a => a
#dms forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> (a -> b) -> m ()
%= forall a. HasID' a => a -> SnowflakeMap a -> SnowflakeMap a
SM.insert DMChannel
dm
runCache (GetDM Snowflake DMChannel
did) = forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (forall a. IsLabel "dms" a => a
#dms forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at' Snowflake DMChannel
did)
runCache CacheEff m a
GetDMs = forall a. SnowflakeMap a -> [a]
SM.elems forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use forall a. IsLabel "dms" a => a
#dms
runCache (DelDM Snowflake DMChannel
did) = forall a. IsLabel "dms" a => a
#dms forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> (a -> b) -> m ()
%= forall m. At m => Index m -> m -> m
sans Snowflake DMChannel
did
runCache (SetUser User
u) = forall a. IsLabel "users" a => a
#users forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> (a -> b) -> m ()
%= forall a. HasID' a => a -> SnowflakeMap a -> SnowflakeMap a
SM.insert User
u
runCache (GetUser Snowflake User
uid) = forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (forall a. IsLabel "users" a => a
#users forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at' Snowflake User
uid)
runCache CacheEff m a
GetUsers = forall a. SnowflakeMap a -> [a]
SM.elems forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use forall a. IsLabel "users" a => a
#users
runCache (DelUser Snowflake User
uid) = forall a. IsLabel "users" a => a
#users forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> (a -> b) -> m ()
%= forall m. At m => Index m -> m -> m
sans Snowflake User
uid
runCache (SetUnavailableGuild Snowflake Guild
gid) = forall a. IsLabel "unavailableGuilds" a => a
#unavailableGuilds forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> (a -> b) -> m ()
%= forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert Snowflake Guild
gid
runCache (IsUnavailableGuild Snowflake Guild
gid) = forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use (forall a. IsLabel "unavailableGuilds" a => a
#unavailableGuilds forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall m. Contains m => Index m -> Lens' m Bool
contains Snowflake Guild
gid)
runCache CacheEff m a
GetUnavailableGuilds = forall a. HashSet a -> [a]
HS.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use forall a. IsLabel "unavailableGuilds" a => a
#unavailableGuilds
runCache (DelUnavailableGuild Snowflake Guild
gid) = forall a. IsLabel "unavailableGuilds" a => a
#unavailableGuilds forall k s (m :: * -> *) (is :: IxList) a b.
(Is k A_Setter, MonadState s m) =>
Optic k is s s a b -> (a -> b) -> m ()
%= forall m. At m => Index m -> m -> m
sans Snowflake Guild
gid
runCache (SetMessage Message
m) = forall t. MessageMod t => Message -> State t ()
setMessage' Message
m
runCache (GetMessage Snowflake Message
mid) = forall t.
MessageMod t =>
Snowflake Message -> State t (Maybe Message)
getMessage' Snowflake Message
mid
runCache CacheEff m a
GetMessages = forall t. MessageMod t => State t [Message]
getMessages'
runCache (DelMessage Snowflake Message
mid) = forall t. MessageMod t => Snowflake Message -> State t ()
delMessage' Snowflake Message
mid