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 (insertInforming, newLRU, maxSize, toList)
import Data.Cache.LRU.IO (newAtomicLRU,insert,lookup)
import Data.Cache.LRU.IO.Internal (AtomicLRU(C),modifyMVar')
import Prelude hiding (lookup)
import qualified SDL as SDL (Texture, destroyTexture, Surface,freeSurface)
import qualified SDL.Raw as Raw
import SDL.Data.Texture
class Cacheable r where
releaseResource :: r -> IO ()
instance Cacheable (SDL.Texture) where
releaseResource = SDL.destroyTexture
instance Cacheable (SDL.Surface) where
releaseResource = SDL.freeSurface
instance Cacheable RawTexture where
releaseResource (RawTexture tex) = Raw.destroyTexture tex
instance (Cacheable a) => Cacheable (Maybe a) where
releaseResource Nothing = return ()
releaseResource (Just r) = releaseResource r
instance Cacheable Int where
releaseResource _ = return ()
instance (Cacheable a) => Cacheable [a] where
releaseResource = mapM_ releaseResource
newtype Cache k a = Cache (AtomicLRU k a)
newCache :: (Ord k) =>
Int
-> IO (Cache k a)
newCache s = Cache <$>
newAtomicLRU (Just . fromIntegral $ s)
putInCache :: (Ord k, Cacheable r) => Cache k r -> k -> IO r -> IO r
putInCache (Cache (C c)) key action = do
newResource <- action
mOldResource <- modifyMVar' c (return . insertInforming key newResource)
mapM_ (releaseResource.snd) mOldResource
pure newResource
lookupFromCache :: (Ord k) => Cache k r -> k -> IO (Maybe r)
lookupFromCache (Cache var) key =
lookup key var
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 (C c)) = do
res <- modifyMVar' c $ \ lru ->
return (newLRU (maxSize lru), map snd . toList $ lru)
mapM_ releaseResource res