-- 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 {
    Cache k v -> Int
cCapacity :: Int       -- ^ The maximum number of elements in the queue
  , Cache k v -> Int
cSize     :: Int       -- ^ The current number of elements in the queue
  , Cache k v -> Int
cValLimit :: Int
  , Cache k v -> Priority
cTick     :: Priority  -- ^ The next logical time
  , 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
/= :: 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
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 k, Show v) => Int -> Cache k v -> ShowS
forall k v. (Show k, Show v) => [Cache k v] -> ShowS
forall k v. (Show k, Show v) => Cache k v -> String
showList :: [Cache k v] -> ShowS
$cshowList :: forall k v. (Show k, Show v) => [Cache k v] -> ShowS
show :: Cache k v -> String
$cshow :: forall k v. (Show k, Show v) => Cache k v -> String
showsPrec :: Int -> Cache k v -> ShowS
$cshowsPrec :: forall k v. (Show k, Show v) => Int -> Cache k v -> ShowS
Show)

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

insert :: (Ord k, Ord v) => k -> v -> Cache k v -> Cache k v
insert :: k -> v -> Cache k v -> Cache k v
insert k :: k
k v :: v
v c :: 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
    (True,  q :: 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 :: Priority
cTick = Cache k v -> Priority
forall k v. Cache k v -> Priority
cTick Cache k v
c Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ 1, cQueue :: OrdPSQ k Priority (Multi v)
cQueue = OrdPSQ k Priority (Multi v)
q, cSize :: Int
cSize = Cache k v -> Int
forall k v. Cache k v -> Int
cSize Cache k v
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1}
    (False, q :: 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 :: Priority
cTick = Cache k v -> Priority
forall k v. Cache k v -> Priority
cTick Cache k v
c Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ 1, cQueue :: OrdPSQ k Priority (Multi v)
cQueue = OrdPSQ k Priority (Multi v)
q }
  where
    lookupAndBump :: Maybe (a, Multi v) -> (Bool, Maybe (Priority, Multi v))
lookupAndBump 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 (_, x :: 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 :: k -> Cache k v -> (Cache k v, [v])
lookup k :: k
k c :: 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
    (Nothing, _) -> (Cache k v
c, [])
    (Just x :: Multi v
x, q :: 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 :: Priority
cTick = Cache k v -> Priority
forall k v. Cache k v -> Priority
cTick Cache k v
c Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ 1, cQueue :: OrdPSQ k Priority (Multi v)
cQueue = OrdPSQ k Priority (Multi v)
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 Nothing       = (Maybe b
forall a. Maybe a
Nothing, Maybe (Priority, b)
forall a. Maybe a
Nothing)
    lookupAndBump (Just (_, x :: 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))