module Control.Concurrent.Cache (CachedData, fetch, fetchCached, createReadOnceCache, createTimedCache) where
import Data.Maybe (isNothing)
import Control.Concurrent (forkIO, threadDelay, killThread, MVar, modifyMVar_, readMVar, ThreadId, newMVar)
import Control.Monad (when, liftM)
data Timeout = TimeSinceCreation Int | TimeSinceLastRead Int
data CachedData a = TimedCachedData (Timeout, (MVar (Maybe ThreadId, IO a, Maybe a))) | ReadOnceCachedData (MVar (Either (IO a) a))
fetchCached :: CachedData a
-> IO (Maybe a)
fetchCached (ReadOnceCachedData mvar) = do
cached <- readMVar mvar
return $ case cached of
Left _ -> Nothing
Right value -> Just value
fetchCached (TimedCachedData (timeout, mvar)) = do
(_,_,value) <- readMVar mvar
modifyMVar_ mvar $ \mvar'@(thread', action', value') -> do
let newThread x = do threadDelay x
modifyMVar_ mvar $ \(_, action'', _) -> return (Nothing, action'', Nothing)
case timeout of
TimeSinceLastRead time -> do
when (not $ isNothing thread') $ let Just thread'' = thread' in killThread thread''
newThreadId <- forkIO $ newThread time
return (Just newThreadId, action', value')
TimeSinceCreation time -> do
if (isNothing thread')
then do newThread' <- forkIO $ newThread time
return (Just newThread', action', value')
else return mvar'
return value
fetch :: CachedData a
-> IO (a)
fetch state@(ReadOnceCachedData mvar) = go where
go = do
cached <- fetchCached state
case cached of
Nothing -> do
modifyMVar_ mvar $ \cached' -> case cached' of
Left x -> liftM Right x
Right x -> return $ Right x
go
Just value -> return value
fetch state@(TimedCachedData (timeout, mvar)) = go where
go = do
cached <- fetchCached state
case cached of
Nothing -> do
modifyMVar_ mvar $ \mvar'@(threadId, action, value) -> case value of
Nothing -> do newVal <- action
return (threadId, action, Just newVal)
Just x -> return $ mvar'
go
Just value -> return value
createReadOnceCache :: IO (a)
-> IO (CachedData a)
createReadOnceCache action = do
var <- newMVar $ Left action
return $ ReadOnceCachedData var
createTimedCache :: Int
-> Bool
-> IO (a)
-> IO (CachedData a)
createTimedCache timeout resetOnRead action = do
var <- newMVar (Nothing, action, Nothing)
let timeout' = if resetOnRead
then TimeSinceLastRead timeout
else TimeSinceCreation timeout
return $ TimedCachedData (timeout', var)