{-# LANGUAGE TemplateHaskell #-}

-- | 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), Snowflake, HasID' )
import Control.Monad.State.Lazy ( when, execState )
import Data.Default.Class ( Default(..) )
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as H
import Deque.Lazy (Deque)
import qualified Deque.Lazy as DQ
import Optics
import Optics.State.Operators ((%=), (.=))

data BoundedStore a = BoundedStore
  { forall (a :: OpticKind). BoundedStore a -> Deque (Snowflake a)
itemQueue :: Deque (Snowflake a)
  , forall (a :: OpticKind). BoundedStore a -> HashMap (Snowflake a) a
items :: HashMap (Snowflake a) a
  , forall (a :: OpticKind). BoundedStore a -> Int
limit :: Int
  , forall (a :: OpticKind). 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 :: OpticKind). Show a => Int -> BoundedStore a -> ShowS
forall (a :: OpticKind). Show a => [BoundedStore a] -> ShowS
forall (a :: OpticKind). Show a => BoundedStore a -> String
forall (a :: OpticKind).
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoundedStore a] -> ShowS
$cshowList :: forall (a :: OpticKind). Show a => [BoundedStore a] -> ShowS
show :: BoundedStore a -> String
$cshow :: forall (a :: OpticKind). Show a => BoundedStore a -> String
showsPrec :: Int -> BoundedStore a -> ShowS
$cshowsPrec :: forall (a :: OpticKind). Show a => Int -> BoundedStore a -> ShowS
Show)

$(makeFieldLabelsNoPrefix ''BoundedStore)

instance Foldable BoundedStore where
  foldr :: forall (a :: OpticKind) (b :: OpticKind).
(a -> b -> b) -> b -> BoundedStore a -> b
foldr a -> b -> b
f b
i = (a -> b -> b) -> b -> [a] -> b
forall (t :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
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 :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. HashMap (Snowflake a) a -> [a]
forall (k :: OpticKind) (v :: OpticKind). HashMap k v -> [v]
H.elems (HashMap (Snowflake a) a -> [a])
-> (BoundedStore a -> HashMap (Snowflake a) a)
-> BoundedStore a
-> [a]
forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. BoundedStore a -> HashMap (Snowflake a) a
forall (a :: OpticKind). 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 :: OpticKind).
Deque (Snowflake a)
-> HashMap (Snowflake a) a -> Int -> Int -> BoundedStore a
BoundedStore Deque (Snowflake a)
forall (a :: OpticKind). Monoid a => a
mempty HashMap (Snowflake a) a
forall (a :: OpticKind). Monoid a => a
mempty Int
1000 Int
0

empty :: Int -> BoundedStore a
empty :: forall (a :: OpticKind). Int -> BoundedStore a
empty Int
limit = Deque (Snowflake a)
-> HashMap (Snowflake a) a -> Int -> Int -> BoundedStore a
forall (a :: OpticKind).
Deque (Snowflake a)
-> HashMap (Snowflake a) a -> Int -> Int -> BoundedStore a
BoundedStore Deque (Snowflake a)
forall (a :: OpticKind). Monoid a => a
mempty HashMap (Snowflake a) a
forall (a :: OpticKind). 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 :: OpticKind) (t :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
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 :: OpticKind) 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 :: OpticKind). 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 :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
f a -> (a -> b) -> f b
<&> \case
          Maybe a
Nothing -> BoundedStore a
-> (a -> BoundedStore a) -> Maybe a -> BoundedStore a
forall (b :: OpticKind) (a :: OpticKind).
b -> (a -> b) -> Maybe a -> b
maybe BoundedStore a
m (BoundedStore a -> a -> BoundedStore a
forall (a :: OpticKind) (b :: OpticKind). a -> b -> a
const (Snowflake a -> BoundedStore a -> BoundedStore a
forall (a :: OpticKind).
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 :: OpticKind).
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 :: OpticKind).
HasID' a =>
a -> BoundedStore a -> BoundedStore a
addItem a
m = State (BoundedStore a) () -> BoundedStore a -> BoundedStore a
forall (s :: OpticKind) (a :: OpticKind). State s a -> s -> s
execState (State (BoundedStore a) () -> BoundedStore a -> BoundedStore a)
-> State (BoundedStore a) () -> BoundedStore a -> BoundedStore a
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
  StateT (BoundedStore a) Identity Bool
-> State (BoundedStore a) () -> State (BoundedStore a) ()
forall (m :: OpticKind -> OpticKind).
Monad m =>
m Bool -> m () -> m ()
unlessM (Snowflake a -> HashMap (Snowflake a) a -> Bool
forall (k :: OpticKind) (a :: OpticKind).
(Eq k, Hashable k) =>
k -> HashMap k a -> Bool
H.member (a -> Snowflake a
forall (b :: OpticKind) (a :: OpticKind).
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 :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
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 :: OpticKind) (s :: OpticKind)
       (m :: OpticKind -> OpticKind) (is :: IxList) (a :: OpticKind).
(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 :: OpticKind) 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 :: OpticKind) (s :: OpticKind)
       (m :: OpticKind -> OpticKind) (is :: IxList) (a :: OpticKind).
(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 :: OpticKind) (s :: OpticKind)
       (m :: OpticKind -> OpticKind) (is :: IxList) (a :: OpticKind).
(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 :: OpticKind -> OpticKind).
Applicative f =>
Bool -> f () -> f ()
when (Int
size Int -> Int -> Bool
forall (a :: OpticKind). Ord a => a -> a -> Bool
> Int
limit) (State (BoundedStore a) () -> State (BoundedStore a) ())
-> State (BoundedStore a) () -> State (BoundedStore a) ()
forall (a :: OpticKind) 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 :: OpticKind) (s :: OpticKind)
       (m :: OpticKind -> OpticKind) (is :: IxList) (a :: OpticKind).
(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 :: OpticKind). 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 :: OpticKind). Snowflake a -> BoundedStore a -> Maybe a
getItem Snowflake a
id BoundedStore a
s = Snowflake a -> HashMap (Snowflake a) a -> Maybe a
forall (k :: OpticKind) (v :: OpticKind).
(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 :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
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 :: OpticKind).
Snowflake a -> BoundedStore a -> BoundedStore a
dropItem Snowflake a
id = State (BoundedStore a) () -> BoundedStore a -> BoundedStore a
forall (s :: OpticKind) (a :: OpticKind). State s a -> s -> s
execState (State (BoundedStore a) () -> BoundedStore a -> BoundedStore a)
-> State (BoundedStore a) () -> BoundedStore a -> BoundedStore a
forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
  StateT (BoundedStore a) Identity Bool
-> State (BoundedStore a) () -> State (BoundedStore a) ()
forall (m :: OpticKind -> OpticKind).
Monad m =>
m Bool -> m () -> m ()
whenM (Snowflake a -> HashMap (Snowflake a) a -> Bool
forall (k :: OpticKind) (a :: OpticKind).
(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 :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
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 :: OpticKind) (s :: OpticKind)
       (m :: OpticKind -> OpticKind) (is :: IxList) (a :: OpticKind).
(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 :: OpticKind) b. (a -> b) -> a -> b
$ do
    #size %= pred

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