sdl2-compositor-1.2.0.4: SDL/Data/Cache.hs

-- | This module provides a simple caching implementation based on the
-- LRU caching strategy.  The cache is implemented via software
-- transactional memory, which means that you can use the cache from
-- different threads.
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 qualified SDL as SDL (Texture, destroyTexture, Surface,freeSurface)
import qualified SDL.Raw as Raw

import           SDL.Data.Texture

-- | Something is cacheable if there is an action to release the
-- resource (if necessary).
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

-- | Thread safe LRU cache.
data Cache k a = Cache (TMVar (LRU k a)) Int

-- | Create a new cache instance.
newCache :: (Ord k) =>
            Int -- ^ the size of the cache to be created (in elements)
         -> 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

-- | Check if a certain element is already cached.  If not execute the
-- action the generate this element.
throughCache :: (Cacheable r, Ord k) =>
                Cache k r -- ^ cache instance
             -> k         -- ^ cache key
             -> IO r      -- ^ action to generate the rsource
             -> IO r
throughCache cache key action = do
  mVal <- lookupFromCache cache key
  case mVal of
   Nothing -> putInCache cache key action
   Just val -> return val

-- | Invalidate every element in the cache and release the resources
-- accordingly.
emptyCache :: (Cacheable r, Ord k) => Cache k r -> IO ()
emptyCache (Cache var _) = do
  mlru <- atomically $ tryTakeTMVar var
  mapM_ (mapM_ releaseResource) mlru