module Data.LruCache.Haxl
  ( LruHandle (..)
  , newLruHandle
  , cached'
  , cached
  , remove
  , updateLruHandle
  ) where


import           Data.Hashable          (Hashable (..))
import           Haxl.Core              (GenHaxl, env, userEnv)
import           Haxl.Core.Monad        (unsafeLiftIO)

import           Data.HashPSQ           (delete, member)
import           Data.IORef             (atomicModifyIORef')
import           Data.LruCache          (empty, insert, lookup)
import           Data.LruCache.Internal (LruCache (..))
import           Data.LruCache.IO       (LruHandle (..), newLruHandle)
import           Prelude                hiding (lookup)

-- LruCache
doLookup :: (Hashable k, Ord k) => k -> LruCache k v -> (LruCache k v, Maybe v)
doLookup :: k -> LruCache k v -> (LruCache k v, Maybe v)
doLookup k :: k
k c :: LruCache k v
c = case k -> LruCache k v -> Maybe (v, LruCache k v)
forall k v.
(Hashable k, Ord k) =>
k -> LruCache k v -> Maybe (v, LruCache k v)
lookup k
k LruCache k v
c of
                 Nothing      -> (LruCache k v
c, Maybe v
forall a. Maybe a
Nothing)
                 Just (v :: v
v, c' :: LruCache k v
c') -> (LruCache k v
c', v -> Maybe v
forall a. a -> Maybe a
Just v
v)

doInsert :: (Hashable k, Ord k) => k -> v -> a -> LruCache k v -> (LruCache k v, a)
doInsert :: k -> v -> a -> LruCache k v -> (LruCache k v, a)
doInsert k :: k
k v :: v
v v0 :: a
v0 c :: LruCache k v
c = (k -> v -> LruCache k v -> LruCache k v
forall k v.
(Hashable k, Ord k) =>
k -> v -> LruCache k v -> LruCache k v
insert k
k v
v LruCache k v
c, a
v0)

-- | Return the cached result of the action or, in the case of a cache
-- miss, execute the action and insert it in the cache.
cached :: (Hashable k, Ord k) => (u -> Maybe (LruHandle k v)) -> k -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
cached :: (u -> Maybe (LruHandle k v))
-> k -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
cached lru :: u -> Maybe (LruHandle k v)
lru k :: k
k io :: GenHaxl u w (Maybe v)
io = do
  Maybe (LruHandle k v)
h <- u -> Maybe (LruHandle k v)
lru (u -> Maybe (LruHandle k v))
-> GenHaxl u w u -> GenHaxl u w (Maybe (LruHandle k v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env u w -> u) -> GenHaxl u w u
forall u w a. (Env u w -> a) -> GenHaxl u w a
env Env u w -> u
forall u w. Env u w -> u
userEnv
  Maybe (LruHandle k v)
-> k -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
forall k v u w.
(Hashable k, Ord k) =>
Maybe (LruHandle k v)
-> k -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
go Maybe (LruHandle k v)
h k
k GenHaxl u w (Maybe v)
io

  where go :: (Hashable k, Ord k) => Maybe (LruHandle k v) -> k -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
        go :: Maybe (LruHandle k v)
-> k -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
go Nothing _ io0 :: GenHaxl u w (Maybe v)
io0 = GenHaxl u w (Maybe v)
io0
        go (Just (LruHandle ref :: IORef (LruCache k v)
ref)) k0 :: k
k0 io0 :: GenHaxl u w (Maybe v)
io0 = do
          Maybe v
res <- IO (Maybe v) -> GenHaxl u w (Maybe v)
forall a u w. IO a -> GenHaxl u w a
unsafeLiftIO (IO (Maybe v) -> GenHaxl u w (Maybe v))
-> IO (Maybe v) -> GenHaxl u w (Maybe v)
forall a b. (a -> b) -> a -> b
$ IORef (LruCache k v)
-> (LruCache k v -> (LruCache k v, Maybe v)) -> IO (Maybe v)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LruCache k v)
ref ((LruCache k v -> (LruCache k v, Maybe v)) -> IO (Maybe v))
-> (LruCache k v -> (LruCache k v, Maybe v)) -> IO (Maybe v)
forall a b. (a -> b) -> a -> b
$ k -> LruCache k v -> (LruCache k v, Maybe v)
forall k v.
(Hashable k, Ord k) =>
k -> LruCache k v -> (LruCache k v, Maybe v)
doLookup k
k0
          case Maybe v
res of
            Just v :: v
v -> Maybe v -> GenHaxl u w (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (v -> Maybe v
forall a. a -> Maybe a
Just v
v)
            Nothing -> do
              Maybe v
v <- GenHaxl u w (Maybe v)
io0
              case Maybe v
v of
                Nothing -> Maybe v -> GenHaxl u w (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
                Just v0 :: v
v0 -> IO (Maybe v) -> GenHaxl u w (Maybe v)
forall a u w. IO a -> GenHaxl u w a
unsafeLiftIO (IO (Maybe v) -> GenHaxl u w (Maybe v))
-> IO (Maybe v) -> GenHaxl u w (Maybe v)
forall a b. (a -> b) -> a -> b
$ IORef (LruCache k v)
-> (LruCache k v -> (LruCache k v, Maybe v)) -> IO (Maybe v)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LruCache k v)
ref ((LruCache k v -> (LruCache k v, Maybe v)) -> IO (Maybe v))
-> (LruCache k v -> (LruCache k v, Maybe v)) -> IO (Maybe v)
forall a b. (a -> b) -> a -> b
$ k -> v -> Maybe v -> LruCache k v -> (LruCache k v, Maybe v)
forall k v a.
(Hashable k, Ord k) =>
k -> v -> a -> LruCache k v -> (LruCache k v, a)
doInsert k
k0 v
v0 Maybe v
v

cached' :: (Hashable k, Ord k) => (u -> Maybe (LruHandle k v)) -> k -> GenHaxl u w v -> GenHaxl u w v
cached' :: (u -> Maybe (LruHandle k v)) -> k -> GenHaxl u w v -> GenHaxl u w v
cached' lru :: u -> Maybe (LruHandle k v)
lru k :: k
k io :: GenHaxl u w v
io = do
  Maybe (LruHandle k v)
h <- u -> Maybe (LruHandle k v)
lru (u -> Maybe (LruHandle k v))
-> GenHaxl u w u -> GenHaxl u w (Maybe (LruHandle k v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env u w -> u) -> GenHaxl u w u
forall u w a. (Env u w -> a) -> GenHaxl u w a
env Env u w -> u
forall u w. Env u w -> u
userEnv
  Maybe (LruHandle k v) -> k -> GenHaxl u w v -> GenHaxl u w v
forall k v u w.
(Hashable k, Ord k) =>
Maybe (LruHandle k v) -> k -> GenHaxl u w v -> GenHaxl u w v
go Maybe (LruHandle k v)
h k
k GenHaxl u w v
io
  where go :: (Hashable k, Ord k) => Maybe (LruHandle k v) -> k -> GenHaxl u w v -> GenHaxl u w v
        go :: Maybe (LruHandle k v) -> k -> GenHaxl u w v -> GenHaxl u w v
go Nothing _ io0 :: GenHaxl u w v
io0 = GenHaxl u w v
io0
        go (Just (LruHandle ref :: IORef (LruCache k v)
ref)) k0 :: k
k0 io0 :: GenHaxl u w v
io0 = do
          Maybe v
res <- IO (Maybe v) -> GenHaxl u w (Maybe v)
forall a u w. IO a -> GenHaxl u w a
unsafeLiftIO (IO (Maybe v) -> GenHaxl u w (Maybe v))
-> IO (Maybe v) -> GenHaxl u w (Maybe v)
forall a b. (a -> b) -> a -> b
$ IORef (LruCache k v)
-> (LruCache k v -> (LruCache k v, Maybe v)) -> IO (Maybe v)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LruCache k v)
ref ((LruCache k v -> (LruCache k v, Maybe v)) -> IO (Maybe v))
-> (LruCache k v -> (LruCache k v, Maybe v)) -> IO (Maybe v)
forall a b. (a -> b) -> a -> b
$ k -> LruCache k v -> (LruCache k v, Maybe v)
forall k v.
(Hashable k, Ord k) =>
k -> LruCache k v -> (LruCache k v, Maybe v)
doLookup k
k0
          case Maybe v
res of
            Just v :: v
v -> v -> GenHaxl u w v
forall (m :: * -> *) a. Monad m => a -> m a
return v
v
            Nothing -> do
              v
v <- GenHaxl u w v
io0
              IO v -> GenHaxl u w v
forall a u w. IO a -> GenHaxl u w a
unsafeLiftIO (IO v -> GenHaxl u w v) -> IO v -> GenHaxl u w v
forall a b. (a -> b) -> a -> b
$ IORef (LruCache k v) -> (LruCache k v -> (LruCache k v, v)) -> IO v
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LruCache k v)
ref ((LruCache k v -> (LruCache k v, v)) -> IO v)
-> (LruCache k v -> (LruCache k v, v)) -> IO v
forall a b. (a -> b) -> a -> b
$ k -> v -> v -> LruCache k v -> (LruCache k v, v)
forall k v a.
(Hashable k, Ord k) =>
k -> v -> a -> LruCache k v -> (LruCache k v, a)
doInsert k
k0 v
v v
v

remove :: (Hashable k, Ord k) => (u -> Maybe (LruHandle k v)) -> k -> GenHaxl u w ()
remove :: (u -> Maybe (LruHandle k v)) -> k -> GenHaxl u w ()
remove lru :: u -> Maybe (LruHandle k v)
lru k :: k
k = do
  Maybe (LruHandle k v)
h <- u -> Maybe (LruHandle k v)
lru (u -> Maybe (LruHandle k v))
-> GenHaxl u w u -> GenHaxl u w (Maybe (LruHandle k v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env u w -> u) -> GenHaxl u w u
forall u w a. (Env u w -> a) -> GenHaxl u w a
env Env u w -> u
forall u w. Env u w -> u
userEnv
  case Maybe (LruHandle k v)
h of
    Nothing -> () -> GenHaxl u w ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (LruHandle ref :: IORef (LruCache k v)
ref) ->
      IO () -> GenHaxl u w ()
forall a u w. IO a -> GenHaxl u w a
unsafeLiftIO (IO () -> GenHaxl u w ()) -> IO () -> GenHaxl u w ()
forall a b. (a -> b) -> a -> b
$ IORef (LruCache k v)
-> (LruCache k v -> (LruCache k v, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LruCache k v)
ref ((LruCache k v -> (LruCache k v, ())) -> IO ())
-> (LruCache k v -> (LruCache k v, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \c :: LruCache k v
c -> do
        let queue :: HashPSQ k Priority v
queue = LruCache k v -> HashPSQ k Priority v
forall k v. LruCache k v -> HashPSQ k Priority v
lruQueue LruCache k v
c
            size :: Int
size  = LruCache k v -> Int
forall k v. LruCache k v -> Int
lruSize LruCache k v
c

        if k -> HashPSQ k Priority v -> Bool
forall k p v.
(Hashable k, Ord k, Ord p) =>
k -> HashPSQ k p v -> Bool
member k
k HashPSQ k Priority v
queue then (LruCache k v
c { lruSize :: Int
lruSize = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1, lruQueue :: HashPSQ k Priority v
lruQueue = k -> HashPSQ k Priority v -> HashPSQ k Priority v
forall k p v.
(Hashable k, Ord k, Ord p) =>
k -> HashPSQ k p v -> HashPSQ k p v
delete k
k HashPSQ k Priority v
queue }, ())
                else (LruCache k v
c, ())

updateLruHandle :: (Hashable k, Ord k) => LruHandle k v -> Int -> IO ()
updateLruHandle :: LruHandle k v -> Int -> IO ()
updateLruHandle (LruHandle ref :: IORef (LruCache k v)
ref) size :: Int
size =
  IORef (LruCache k v)
-> (LruCache k v -> (LruCache k v, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (LruCache k v)
ref ((LruCache k v -> (LruCache k v, ())) -> IO ())
-> (LruCache k v -> (LruCache k v, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ (LruCache k v, ()) -> LruCache k v -> (LruCache k v, ())
forall a b. a -> b -> a
const (Int -> LruCache k v
forall k v. Int -> LruCache k v
empty Int
size, ())