{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Cache.LRU
( LRUCache
, Strategy(..)
) where
import Control.Monad.Ref
import Data.Cache.Trace
import Data.Cache.Type
import Data.Hashable
import qualified Data.HashPSQ as PSQ
import qualified Data.DList as DList
newtype LRUCache m (s::Strategy) p k t v = LRUCache (Ref m (LRUCache' s p k t v))
data Strategy
= FIFO
| LRU
| LFU
data LRUCache' (s::Strategy) p k t v
= LRUCache1'
{ lcCapacity :: !p
, lcSize :: !p
, lcGen :: !p
, lcPSQueue :: !(PSQ.HashPSQ k p (t, v))
}
| LRUCache2'
{ lcCapacity :: !p
, lcSize :: !p
, lcGen :: !p
, lcPSQueue :: !(PSQ.HashPSQ k p (t, v))
, lcPSQueueOverflow :: !(PSQ.HashPSQ k p (t, v))
}
deriving (Eq, Show)
shrinkQueue :: forall k p t v . (Hashable k, Ord k, Enum p, Num p, Ord p)
=> p -> p -> PSQ.HashPSQ k p (t, v) -> (p, [CacheEvent k t v], PSQ.HashPSQ k p (t, v))
shrinkQueue c s' q' =
go s' 0 [] q'
where
go :: p -> p -> [CacheEvent k t v] -> PSQ.HashPSQ k p (t, v) -> (p, [CacheEvent k t v], PSQ.HashPSQ k p (t, v))
go s cnt trc q | s <= c = (cnt, trc, q)
go s cnt trc q =
case PSQ.minView q of
Nothing -> (cnt, trc, q)
Just (k, p, (t, v), q') -> go (pred s) (cnt+1) ((CacheEvict k t v) : trc) q
trim :: forall s k p t v (trc::Bool) m
. (Hashable k, Ord k, Enum p, Num p, Ord p, MonadTrace trc, Applicative m, Monad (Tracable trc (CacheTrace k t v) m))
=> LRUCache' s p k t v -> Tracable trc (CacheTrace k t v) m (LRUCache' s p k t v)
trim (c@(LRUCache1' {lcCapacity=cap, lcSize=sz})) | cap >= sz = pure c
trim (c@(LRUCache2' {lcCapacity=cap, lcSize=sz})) | cap >= sz = pure c
trim (c@(LRUCache1' {lcCapacity=cap, lcSize=sz, lcPSQueue=q})) = do
let (removed, trc, nq) = shrinkQueue cap sz q
trace $ DList.fromList trc
pure (c {lcSize=sz-removed, lcPSQueue=nq})
trim (c@(LRUCache2' {lcCapacity=cap, lcSize=sz, lcPSQueue=q, lcPSQueueOverflow=qo})) = do
let (removedo, trco, nqo) = shrinkQueue cap sz qo
trace $ DList.fromList trco
let newsz = sz-removedo
if cap >= newsz
then pure $ reconstructCache newsz q nqo
else do
let (removed, trc, nq) = shrinkQueue cap newsz q
trace $ DList.fromList trc
pure $ reconstructCache (newsz-removed) nq nqo
where
reconstructCache :: p -> PSQ.HashPSQ k p (t, v) -> PSQ.HashPSQ k p (t, v) -> LRUCache' s p k t v
reconstructCache resSz resQ resQO | PSQ.null resQO =
LRUCache1' { lcCapacity=cap
, lcSize = resSz
, lcPSQueue = resQ
, lcGen = lcGen c
}
reconstructCache resSz resQ resQO =
LRUCache2' { lcCapacity=cap
, lcSize = resSz
, lcPSQueue = resQ
, lcPSQueueOverflow = resQO
, lcGen = lcGen c
}