{-# 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
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 = forall (t :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
f b
i forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (k :: OpticKind) (v :: OpticKind). HashMap k v -> [v]
H.elems forall (b :: OpticKind) (c :: OpticKind) (a :: OpticKind).
(b -> c) -> (a -> b) -> a -> c
. forall (a :: OpticKind). BoundedStore a -> HashMap (Snowflake a) a
items

instance Default (BoundedStore a) where
  def :: BoundedStore a
def = forall (a :: OpticKind).
Deque (Snowflake a)
-> HashMap (Snowflake a) a -> Int -> Int -> BoundedStore a
BoundedStore forall (a :: OpticKind). Monoid a => a
mempty 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 = forall (a :: OpticKind).
Deque (Snowflake a)
-> HashMap (Snowflake a) a -> Int -> Int -> BoundedStore a
BoundedStore forall (a :: OpticKind). Monoid a => a
mempty 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 = forall (s :: OpticKind) (t :: OpticKind) (a :: OpticKind)
       (b :: OpticKind).
LensVL s t a b -> Lens s t a b
lensVL 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 = forall (a :: OpticKind). Snowflake a -> BoundedStore a -> Maybe a
getItem Index (BoundedStore a)
k BoundedStore a
m
     in Maybe (IxValue (BoundedStore a))
-> f (Maybe (IxValue (BoundedStore a)))
f Maybe a
mv forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
f a -> (a -> b) -> f b
<&> \case
          Maybe a
Nothing -> forall (b :: OpticKind) (a :: OpticKind).
b -> (a -> b) -> Maybe a -> b
maybe BoundedStore a
m (forall (a :: OpticKind) (b :: OpticKind). a -> b -> a
const (forall (a :: OpticKind).
Snowflake a -> BoundedStore a -> BoundedStore a
dropItem Index (BoundedStore a)
k BoundedStore a
m)) Maybe a
mv
          Just a
v -> 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 = forall (s :: OpticKind) (a :: OpticKind). State s a -> s -> s
execState forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
  forall (m :: OpticKind -> OpticKind).
Monad m =>
m Bool -> m () -> m ()
unlessM (forall (k :: OpticKind) (a :: OpticKind).
(Eq k, Hashable k) =>
k -> HashMap k a -> Bool
H.member (forall (b :: OpticKind) (a :: OpticKind).
HasID b a =>
a -> Snowflake b
getID a
m) forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> 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 forall (a :: OpticKind). IsLabel "items" a => a
#items) forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
    #itemQueue %= DQ.cons (getID m)
    #size %= succ

  Int
size <- 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 forall (a :: OpticKind). IsLabel "size" a => a
#size
  Int
limit <- 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 forall (a :: OpticKind). IsLabel "limit" a => a
#limit

  forall (f :: OpticKind -> OpticKind).
Applicative f =>
Bool -> f () -> f ()
when (Int
size forall (a :: OpticKind). Ord a => a -> a -> Bool
> Int
limit) forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
    Deque (Index (HashMap (Snowflake a) a))
q <- 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 forall (a :: OpticKind). IsLabel "itemQueue" a => a
#itemQueue
    let Just (Index (HashMap (Snowflake a) a)
rid, Deque (Index (HashMap (Snowflake a) a))
q') = 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 = forall (k :: OpticKind) (v :: OpticKind).
(Eq k, Hashable k) =>
k -> HashMap k v -> Maybe v
H.lookup Snowflake a
id (BoundedStore a
s forall (k :: OpticKind) (s :: OpticKind) (is :: IxList)
       (a :: OpticKind).
Is k A_Getter =>
s -> Optic' k is s a -> a
^. forall (a :: OpticKind). IsLabel "items" 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 = forall (s :: OpticKind) (a :: OpticKind). State s a -> s -> s
execState forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
  forall (m :: OpticKind -> OpticKind).
Monad m =>
m Bool -> m () -> m ()
whenM (forall (k :: OpticKind) (a :: OpticKind).
(Eq k, Hashable k) =>
k -> HashMap k a -> Bool
H.member Snowflake a
id forall (f :: OpticKind -> OpticKind) (a :: OpticKind)
       (b :: OpticKind).
Functor f =>
(a -> b) -> f a -> f b
<$> 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 forall (a :: OpticKind). IsLabel "items" a => a
#items) forall (a :: OpticKind) b. (a -> b) -> a -> b
$ do
    #size %= pred

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