-- from https://jaspervdj.be/posts/2015-02-24-lru-cache.html
module Network.Wai.Middleware.Push.Referer.LRU (
    Cache(..)
  , Priority
  , empty
  , insert
  , lookup
  ) where

import Data.OrdPSQ (OrdPSQ)
import qualified Data.OrdPSQ as PSQ
import Data.Int (Int64)
import Prelude hiding (lookup)

import Network.Wai.Middleware.Push.Referer.Multi (Multi)
import qualified Network.Wai.Middleware.Push.Referer.Multi as M

type Priority = Int64

data Cache k v = Cache {
    forall k v. Cache k v -> Int
cCapacity :: Int       -- ^ The maximum number of elements in the queue
  , forall k v. Cache k v -> Int
cSize     :: Int       -- ^ The current number of elements in the queue
  , forall k v. Cache k v -> Int
cValLimit :: Int
  , forall k v. Cache k v -> Priority
cTick     :: Priority  -- ^ The next logical time
  , forall k v. Cache k v -> OrdPSQ k Priority (Multi v)
cQueue    :: OrdPSQ k Priority (Multi v)
  } deriving (Cache k v -> Cache k v -> Bool
(Cache k v -> Cache k v -> Bool)
-> (Cache k v -> Cache k v -> Bool) -> Eq (Cache k v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k v. (Ord k, Eq v) => Cache k v -> Cache k v -> Bool
$c== :: forall k v. (Ord k, Eq v) => Cache k v -> Cache k v -> Bool
== :: Cache k v -> Cache k v -> Bool
$c/= :: forall k v. (Ord k, Eq v) => Cache k v -> Cache k v -> Bool
/= :: Cache k v -> Cache k v -> Bool
Eq, Int -> Cache k v -> ShowS
[Cache k v] -> ShowS
Cache k v -> String
(Int -> Cache k v -> ShowS)
-> (Cache k v -> String)
-> ([Cache k v] -> ShowS)
-> Show (Cache k v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k v. (Show v, Show k) => Int -> Cache k v -> ShowS
forall k v. (Show v, Show k) => [Cache k v] -> ShowS
forall k v. (Show v, Show k) => Cache k v -> String
$cshowsPrec :: forall k v. (Show v, Show k) => Int -> Cache k v -> ShowS
showsPrec :: Int -> Cache k v -> ShowS
$cshow :: forall k v. (Show v, Show k) => Cache k v -> String
show :: Cache k v -> String
$cshowList :: forall k v. (Show v, Show k) => [Cache k v] -> ShowS
showList :: [Cache k v] -> ShowS
Show)

empty :: Int -> Int -> Cache k v
empty :: forall k v. Int -> Int -> Cache k v
empty Int
capacity Int
valLimit
  | Int
capacity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = String -> Cache k v
forall a. HasCallStack => String -> a
error String
"Cache.empty: capacity < 1"
  | Bool
otherwise    = Cache {
        cCapacity :: Int
cCapacity = Int
capacity
      , cSize :: Int
cSize     = Int
0
      , cValLimit :: Int
cValLimit = Int
valLimit
      , cTick :: Priority
cTick     = Priority
0
      , cQueue :: OrdPSQ k Priority (Multi v)
cQueue    = OrdPSQ k Priority (Multi v)
forall k p v. OrdPSQ k p v
PSQ.empty
      }

trim :: Ord k => Cache k v -> Cache k v
trim :: forall k v. Ord k => Cache k v -> Cache k v
trim Cache k v
c
  | Cache k v -> Priority
forall k v. Cache k v -> Priority
cTick Cache k v
c Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
== Priority
forall a. Bounded a => a
maxBound  = Int -> Int -> Cache k v
forall k v. Int -> Int -> Cache k v
empty (Cache k v -> Int
forall k v. Cache k v -> Int
cCapacity Cache k v
c) (Cache k v -> Int
forall k v. Cache k v -> Int
cValLimit Cache k v
c)
  | Cache k v -> Int
forall k v. Cache k v -> Int
cSize Cache k v
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Cache k v -> Int
forall k v. Cache k v -> Int
cCapacity Cache k v
c = Cache k v
c {
        cSize  = cSize c - 1
      , cQueue = PSQ.deleteMin (cQueue c)
      }
  | Bool
otherwise             = Cache k v
c

insert :: (Ord k, Ord v) => k -> v -> Cache k v -> Cache k v
insert :: forall k v. (Ord k, Ord v) => k -> v -> Cache k v -> Cache k v
insert k
k v
v Cache k v
c = case (Maybe (Priority, Multi v) -> (Bool, Maybe (Priority, Multi v)))
-> k
-> OrdPSQ k Priority (Multi v)
-> (Bool, OrdPSQ k Priority (Multi v))
forall k p v b.
(Ord k, Ord p) =>
(Maybe (p, v) -> (b, Maybe (p, v)))
-> k -> OrdPSQ k p v -> (b, OrdPSQ k p v)
PSQ.alter Maybe (Priority, Multi v) -> (Bool, Maybe (Priority, Multi v))
forall {a}. Maybe (a, Multi v) -> (Bool, Maybe (Priority, Multi v))
lookupAndBump k
k (Cache k v -> OrdPSQ k Priority (Multi v)
forall k v. Cache k v -> OrdPSQ k Priority (Multi v)
cQueue Cache k v
c) of
    (Bool
True,  OrdPSQ k Priority (Multi v)
q) -> Cache k v -> Cache k v
forall k v. Ord k => Cache k v -> Cache k v
trim (Cache k v -> Cache k v) -> Cache k v -> Cache k v
forall a b. (a -> b) -> a -> b
$ Cache k v
c { cTick = cTick c + 1, cQueue = q, cSize = cSize c + 1}
    (Bool
False, OrdPSQ k Priority (Multi v)
q) -> Cache k v -> Cache k v
forall k v. Ord k => Cache k v -> Cache k v
trim (Cache k v -> Cache k v) -> Cache k v -> Cache k v
forall a b. (a -> b) -> a -> b
$ Cache k v
c { cTick = cTick c + 1, cQueue = q }
  where
    lookupAndBump :: Maybe (a, Multi v) -> (Bool, Maybe (Priority, Multi v))
lookupAndBump Maybe (a, Multi v)
Nothing       = (Bool
True,  (Priority, Multi v) -> Maybe (Priority, Multi v)
forall a. a -> Maybe a
Just (Cache k v -> Priority
forall k v. Cache k v -> Priority
cTick Cache k v
c, Int -> v -> Multi v
forall a. Int -> a -> Multi a
M.singleton (Cache k v -> Int
forall k v. Cache k v -> Int
cValLimit Cache k v
c) v
v))
    lookupAndBump (Just (a
_, Multi v
x)) = (Bool
False, (Priority, Multi v) -> Maybe (Priority, Multi v)
forall a. a -> Maybe a
Just (Cache k v -> Priority
forall k v. Cache k v -> Priority
cTick Cache k v
c, v -> Multi v -> Multi v
forall a. Ord a => a -> Multi a -> Multi a
M.insert v
v Multi v
x))

lookup :: Ord k => k -> Cache k v -> (Cache k v, [v])
lookup :: forall k v. Ord k => k -> Cache k v -> (Cache k v, [v])
lookup k
k Cache k v
c = case (Maybe (Priority, Multi v)
 -> (Maybe (Multi v), Maybe (Priority, Multi v)))
-> k
-> OrdPSQ k Priority (Multi v)
-> (Maybe (Multi v), OrdPSQ k Priority (Multi v))
forall k p v b.
(Ord k, Ord p) =>
(Maybe (p, v) -> (b, Maybe (p, v)))
-> k -> OrdPSQ k p v -> (b, OrdPSQ k p v)
PSQ.alter Maybe (Priority, Multi v)
-> (Maybe (Multi v), Maybe (Priority, Multi v))
forall {a} {b}. Maybe (a, b) -> (Maybe b, Maybe (Priority, b))
lookupAndBump k
k (Cache k v -> OrdPSQ k Priority (Multi v)
forall k v. Cache k v -> OrdPSQ k Priority (Multi v)
cQueue Cache k v
c) of
    (Maybe (Multi v)
Nothing, OrdPSQ k Priority (Multi v)
_) -> (Cache k v
c, [])
    (Just Multi v
x, OrdPSQ k Priority (Multi v)
q)  -> let c' :: Cache k v
c' = Cache k v -> Cache k v
forall k v. Ord k => Cache k v -> Cache k v
trim (Cache k v -> Cache k v) -> Cache k v -> Cache k v
forall a b. (a -> b) -> a -> b
$ Cache k v
c { cTick = cTick c + 1, cQueue = q }
                        xs :: [v]
xs = Multi v -> [v]
forall a. Multi a -> [a]
M.list Multi v
x
                    in (Cache k v
c', [v]
xs)
  where
    lookupAndBump :: Maybe (a, b) -> (Maybe b, Maybe (Priority, b))
lookupAndBump Maybe (a, b)
Nothing       = (Maybe b
forall a. Maybe a
Nothing, Maybe (Priority, b)
forall a. Maybe a
Nothing)
    lookupAndBump (Just (a
_, b
x)) = (b -> Maybe b
forall a. a -> Maybe a
Just b
x,  (Priority, b) -> Maybe (Priority, b)
forall a. a -> Maybe a
Just (Cache k v -> Priority
forall k v. Cache k v -> Priority
cTick Cache k v
c, b
x))