{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | A thing for storing the last N things with IDs
module Calamity.Internal.BoundedStore (
  BoundedStore,
  empty,
  addItem,
  getItem,
  dropItem,
) where

import Calamity.Internal.Utils (unlessM, whenM)
import Calamity.Types.Snowflake (HasID (getID), HasID', Snowflake)
import Control.Monad.State.Lazy (execState, when)
import Data.Default.Class (Default (..))
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as H
import Deque.Lazy (Deque)
import Deque.Lazy qualified as DQ
import Optics
import Optics.State.Operators ((%=), (.=))

data BoundedStore a = BoundedStore
  { forall a. BoundedStore a -> Deque (Snowflake a)
itemQueue :: Deque (Snowflake a)
  , forall a. BoundedStore a -> HashMap (Snowflake a) a
items :: HashMap (Snowflake a) a
  , forall a. BoundedStore a -> Int
limit :: Int
  , forall a. BoundedStore a -> Int
size :: Int
  }
  deriving (Int -> BoundedStore a -> ShowS
[BoundedStore a] -> ShowS
BoundedStore a -> String
(Int -> BoundedStore a -> ShowS)
-> (BoundedStore a -> String)
-> ([BoundedStore a] -> ShowS)
-> Show (BoundedStore a)
forall a. Show a => Int -> BoundedStore a -> ShowS
forall a. Show a => [BoundedStore a] -> ShowS
forall a. Show a => BoundedStore a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> BoundedStore a -> ShowS
showsPrec :: Int -> BoundedStore a -> ShowS
$cshow :: forall a. Show a => BoundedStore a -> String
show :: BoundedStore a -> String
$cshowList :: forall a. Show a => [BoundedStore a] -> ShowS
showList :: [BoundedStore a] -> ShowS
Show)

$(makeFieldLabelsNoPrefix ''BoundedStore)

instance Foldable BoundedStore where
  foldr :: forall a b. (a -> b -> b) -> b -> BoundedStore a -> b
foldr a -> b -> b
f b
i = (a -> b -> b) -> b -> [a] -> b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
f b
i ([a] -> b) -> (BoundedStore a -> [a]) -> BoundedStore a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap (Snowflake a) a -> [a]
forall k v. HashMap k v -> [v]
H.elems (HashMap (Snowflake a) a -> [a])
-> (BoundedStore a -> HashMap (Snowflake a) a)
-> BoundedStore a
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundedStore a -> HashMap (Snowflake a) a
forall a. BoundedStore a -> HashMap (Snowflake a) a
items

instance Default (BoundedStore a) where
  def :: BoundedStore a
def = Deque (Snowflake a)
-> HashMap (Snowflake a) a -> Int -> Int -> BoundedStore a
forall a.
Deque (Snowflake a)
-> HashMap (Snowflake a) a -> Int -> Int -> BoundedStore a
BoundedStore Deque (Snowflake a)
forall a. Monoid a => a
mempty HashMap (Snowflake a) a
forall a. Monoid a => a
mempty Int
1000 Int
0

empty :: Int -> BoundedStore a
empty :: forall a. Int -> BoundedStore a
empty Int
limit = Deque (Snowflake a)
-> HashMap (Snowflake a) a -> Int -> Int -> BoundedStore a
forall a.
Deque (Snowflake a)
-> HashMap (Snowflake a) a -> Int -> Int -> BoundedStore a
BoundedStore Deque (Snowflake a)
forall a. Monoid a => a
mempty HashMap (Snowflake a) a
forall a. Monoid a => a
mempty Int
limit Int
0

type instance Index (BoundedStore a) = Snowflake a

type instance IxValue (BoundedStore a) = a

instance HasID' a => Ixed (BoundedStore a)

instance HasID' a => At (BoundedStore a) where
  at :: Index (BoundedStore a)
-> Lens' (BoundedStore a) (Maybe (IxValue (BoundedStore a)))
at Index (BoundedStore a)
k = LensVL
  (BoundedStore a)
  (BoundedStore a)
  (Maybe (IxValue (BoundedStore a)))
  (Maybe (IxValue (BoundedStore a)))
-> Lens' (BoundedStore a) (Maybe (IxValue (BoundedStore a)))
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL (LensVL
   (BoundedStore a)
   (BoundedStore a)
   (Maybe (IxValue (BoundedStore a)))
   (Maybe (IxValue (BoundedStore a)))
 -> Lens' (BoundedStore a) (Maybe (IxValue (BoundedStore a))))
-> LensVL
     (BoundedStore a)
     (BoundedStore a)
     (Maybe (IxValue (BoundedStore a)))
     (Maybe (IxValue (BoundedStore a)))
-> Lens' (BoundedStore a) (Maybe (IxValue (BoundedStore a)))
forall a b. (a -> b) -> a -> b
$ \Maybe (IxValue (BoundedStore a))
-> f (Maybe (IxValue (BoundedStore a)))
f BoundedStore a
m ->
    let mv :: Maybe a
mv = Snowflake a -> BoundedStore a -> Maybe a
forall a. Snowflake a -> BoundedStore a -> Maybe a
getItem Index (BoundedStore a)
Snowflake a
k BoundedStore a
m
     in Maybe (IxValue (BoundedStore a))
-> f (Maybe (IxValue (BoundedStore a)))
f Maybe a
Maybe (IxValue (BoundedStore a))
mv f (Maybe a) -> (Maybe a -> BoundedStore a) -> f (BoundedStore a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          Maybe a
Nothing -> BoundedStore a
-> (a -> BoundedStore a) -> Maybe a -> BoundedStore a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BoundedStore a
m (BoundedStore a -> a -> BoundedStore a
forall a b. a -> b -> a
const (Snowflake a -> BoundedStore a -> BoundedStore a
forall a. Snowflake a -> BoundedStore a -> BoundedStore a
dropItem Index (BoundedStore a)
Snowflake a
k BoundedStore a
m)) Maybe a
mv
          Just a
v -> a -> BoundedStore a -> BoundedStore a
forall a. HasID' a => a -> BoundedStore a -> BoundedStore a
addItem a
v BoundedStore a
m
  {-# INLINE at #-}

addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a
addItem :: forall a. HasID' a => a -> BoundedStore a -> BoundedStore a
addItem a
m = State (BoundedStore a) () -> BoundedStore a -> BoundedStore a
forall s a. State s a -> s -> s
execState (State (BoundedStore a) () -> BoundedStore a -> BoundedStore a)
-> State (BoundedStore a) () -> BoundedStore a -> BoundedStore a
forall a b. (a -> b) -> a -> b
$ do
  StateT (BoundedStore a) Identity Bool
-> State (BoundedStore a) () -> State (BoundedStore a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Snowflake a -> HashMap (Snowflake a) a -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
H.member (a -> Snowflake a
forall b a. HasID b a => a -> Snowflake b
getID a
m) (HashMap (Snowflake a) a -> Bool)
-> StateT (BoundedStore a) Identity (HashMap (Snowflake a) a)
-> StateT (BoundedStore a) Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Optic' A_Lens NoIx (BoundedStore a) (HashMap (Snowflake a) a)
-> StateT (BoundedStore a) Identity (HashMap (Snowflake a) a)
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use Optic' A_Lens NoIx (BoundedStore a) (HashMap (Snowflake a) a)
#items) (State (BoundedStore a) () -> State (BoundedStore a) ())
-> State (BoundedStore a) () -> State (BoundedStore a) ()
forall a b. (a -> b) -> a -> b
$ do
    #itemQueue %= DQ.cons (getID m)
    #size %= succ

  Int
size <- Optic A_Lens NoIx (BoundedStore a) (BoundedStore a) Int Int
-> StateT (BoundedStore a) Identity Int
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use Optic A_Lens NoIx (BoundedStore a) (BoundedStore a) Int Int
#size
  Int
limit <- Optic A_Lens NoIx (BoundedStore a) (BoundedStore a) Int Int
-> StateT (BoundedStore a) Identity Int
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use Optic A_Lens NoIx (BoundedStore a) (BoundedStore a) Int Int
#limit

  Bool -> State (BoundedStore a) () -> State (BoundedStore a) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit) (State (BoundedStore a) () -> State (BoundedStore a) ())
-> State (BoundedStore a) () -> State (BoundedStore a) ()
forall a b. (a -> b) -> a -> b
$ do
    Deque (Index (HashMap (Snowflake a) a))
q <- Optic'
  A_Lens
  NoIx
  (BoundedStore a)
  (Deque (Index (HashMap (Snowflake a) a)))
-> StateT
     (BoundedStore a) Identity (Deque (Index (HashMap (Snowflake a) a)))
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use Optic'
  A_Lens
  NoIx
  (BoundedStore a)
  (Deque (Index (HashMap (Snowflake a) a)))
#itemQueue
    let Just (Index (HashMap (Snowflake a) a)
rid, Deque (Index (HashMap (Snowflake a) a))
q') = Deque (Index (HashMap (Snowflake a) a))
-> Maybe
     (Index (HashMap (Snowflake a) a),
      Deque (Index (HashMap (Snowflake a) a)))
forall a. Deque a -> Maybe (a, Deque a)
DQ.unsnoc Deque (Index (HashMap (Snowflake a) a))
q
    #itemQueue .= q'
    #items %= sans rid
    #size %= pred

  #items %= H.insert (getID m) m
{-# INLINE addItem #-}

getItem :: Snowflake a -> BoundedStore a -> Maybe a
getItem :: forall a. Snowflake a -> BoundedStore a -> Maybe a
getItem Snowflake a
id BoundedStore a
s = Snowflake a -> HashMap (Snowflake a) a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Snowflake a
id (BoundedStore a
s BoundedStore a
-> Optic' A_Lens NoIx (BoundedStore a) (HashMap (Snowflake a) a)
-> HashMap (Snowflake a) a
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (BoundedStore a) (HashMap (Snowflake a) a)
#items)
{-# INLINE getItem #-}

dropItem :: Snowflake a -> BoundedStore a -> BoundedStore a
dropItem :: forall a. Snowflake a -> BoundedStore a -> BoundedStore a
dropItem Snowflake a
id = State (BoundedStore a) () -> BoundedStore a -> BoundedStore a
forall s a. State s a -> s -> s
execState (State (BoundedStore a) () -> BoundedStore a -> BoundedStore a)
-> State (BoundedStore a) () -> BoundedStore a -> BoundedStore a
forall a b. (a -> b) -> a -> b
$ do
  StateT (BoundedStore a) Identity Bool
-> State (BoundedStore a) () -> State (BoundedStore a) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Snowflake a -> HashMap (Snowflake a) a -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
H.member Snowflake a
id (HashMap (Snowflake a) a -> Bool)
-> StateT (BoundedStore a) Identity (HashMap (Snowflake a) a)
-> StateT (BoundedStore a) Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Optic' A_Lens NoIx (BoundedStore a) (HashMap (Snowflake a) a)
-> StateT (BoundedStore a) Identity (HashMap (Snowflake a) a)
forall k s (m :: * -> *) (is :: IxList) a.
(Is k A_Getter, MonadState s m) =>
Optic' k is s a -> m a
use Optic' A_Lens NoIx (BoundedStore a) (HashMap (Snowflake a) a)
#items) (State (BoundedStore a) () -> State (BoundedStore a) ())
-> State (BoundedStore a) () -> State (BoundedStore a) ()
forall a b. (a -> b) -> a -> b
$ do
    #size %= pred

  #itemQueue %= DQ.filter (/= id)
  #items %= H.delete id
{-# INLINE dropItem #-}