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

module SDL.Data.Cache
    (
      Cacheable (..)
    , Cache
    , newCache
    , throughCache
    , emptyCache
    )
where

import Control.Concurrent.STM.TMVar
import Control.Monad.STM
import Data.Cache.LRU
import Prelude hiding (lookup)
import SDL

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