module SDL.Data.Cache
(
Cacheable (..)
, Cache
, newCache
, throughCache
, emptyCache
)
where
import Control.Concurrent.STM.TMVar
(TMVar,newTMVar,tryReadTMVar,tryTakeTMVar,putTMVar)
import Control.Monad.STM (atomically)
import Data.Cache.LRU (LRU,newLRU,insert,insertInforming,lookup)
import Prelude hiding (lookup)
import SDL (Texture, destroyTexture,Surface,freeSurface)
class Cacheable r where
releaseResource :: r -> IO ()
instance Cacheable Texture where
releaseResource = destroyTexture
instance Cacheable Surface where
releaseResource = freeSurface
data Cache k a = Cache (TMVar (LRU k a)) Int
newCache :: (Ord k) =>
Int
-> IO (Cache k a)
newCache s = Cache <$>
atomically (newTMVar (newLRU (Just (fromIntegral s)))) <*>
pure s
putInCache :: (Ord k, Cacheable r) => Cache k r -> k -> IO r -> IO r
putInCache (Cache var s) key action = do
newResource <- action
mOldResource <- atomically $ do
mlru <- tryReadTMVar var
case mlru of
Nothing -> do
let lru = newLRU (Just $ fromIntegral s)
putTMVar var (insert key newResource lru)
return Nothing
Just lru -> do
let (newLru,mOld) = insertInforming key newResource lru
putTMVar var newLru
return mOld
mapM_ (releaseResource.snd) mOldResource
pure newResource
lookupFromCache :: (Ord k) => Cache k r -> k -> IO (Maybe r)
lookupFromCache (Cache var s) key =
atomically $ do
mLru <- tryTakeTMVar var
case mLru of
Nothing -> do
putTMVar var (newLRU (Just $ fromIntegral s))
return Nothing
Just lru -> do
let (newLru,mVal) = lookup key lru
putTMVar var newLru
return mVal
throughCache :: (Cacheable r, Ord k) =>
Cache k r
-> k
-> IO r
-> IO r
throughCache cache key action = do
mVal <- lookupFromCache cache key
case mVal of
Nothing -> putInCache cache key action
Just val -> return val
emptyCache :: (Cacheable r, Ord k) => Cache k r -> IO ()
emptyCache (Cache var _) = do
mlru <- atomically $ tryTakeTMVar var
mapM_ (mapM_ releaseResource) mlru