module Database.Muesli.Cache
( DynValue (..)
, LRUCache (..)
, empty
, insert
, lookup
, delete
, trim
) where
import Data.Dynamic (Dynamic, fromDynamic, toDyn)
import Data.IntPSQ (IntPSQ)
import qualified Data.IntPSQ as PQ
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
import Data.Typeable (Typeable)
import Prelude hiding (lookup)
data DynValue = DynValue
{ dynValue :: !Dynamic
, dynSize :: !Int
} deriving (Show)
data LRUCache = LRUCache
{ minCapacity :: !Int
, maxCapacity :: !Int
, maxAge :: !NominalDiffTime
, size :: !Int
, queue :: !(IntPSQ UTCTime DynValue)
}
empty :: Int
-> Int
-> NominalDiffTime
-> LRUCache
empty minc maxc age = LRUCache { minCapacity = minc
, maxCapacity = maxc
, maxAge = age
, size = 0
, queue = PQ.empty
}
trim :: UTCTime
-> LRUCache
-> LRUCache
trim now c =
if size c < minCapacity c then c
else case PQ.findMin (queue c) of
Nothing -> c
Just (_, p, v) ->
if (size c < maxCapacity c) && (diffUTCTime now p < maxAge c)
then c
else trim now $! c { size = size c dynSize v
, queue = PQ.deleteMin (queue c)
}
insert :: Typeable a
=> UTCTime
-> Int
-> a
-> Int
-> LRUCache
-> LRUCache
insert now k a sz c = trim now $! c { size = size c + sz
maybe 0 (dynSize . snd) mbv
, queue = q
}
where (mbv, q) = PQ.insertView k now v (queue c)
v = DynValue { dynValue = toDyn a
, dynSize = sz
}
lookup :: Typeable a
=> UTCTime
-> Int
-> LRUCache
-> Maybe (a, Int, LRUCache)
lookup now k c =
case PQ.alter f k (queue c) of
(Nothing, _) -> Nothing
(Just v, q) -> (, dynSize v, c') <$> fromDynamic (dynValue v)
where !c' = trim now $ c { queue = q }
where f = maybe (Nothing, Nothing) (\(_, v) -> (Just v, Just (now, v)))
delete :: Int
-> LRUCache
-> LRUCache
delete k c = maybe c
(\(_, v) -> c { size = size c dynSize v
, queue = PQ.delete k (queue c)
}) $
PQ.lookup k (queue c)