module Control.Concurrent.MVar.Expiring
( ExpiringMVar
, newExpiringMVar
, readExpiringMVar
, resetExpiringMVarTimer
, isExpiredMVar
, cancelExpiration
, changeExpiration
, removeExpiredMVars
) where
import Control.Concurrent
import Control.Concurrent.MVar
import qualified Data.Foldable as Foldable
import Control.Monad
import Data.Traversable as Traversable
import Control.Applicative
import Data.Monoid
data ExpiringMVar a = ExpiringMVar { var :: MVar a
, expireTime :: Int
, expirer :: ThreadId
}
newExpiringMVar :: a
-> Int
-> IO (ExpiringMVar a)
newExpiringMVar v delay = do
var <- newMVar v
clearThreadId <- forkExpireIn delay var
return $ ExpiringMVar var delay clearThreadId
readExpiringMVar :: ExpiringMVar a -> IO (Maybe a)
readExpiringMVar (ExpiringMVar var _ _) = do
v <- tryTakeMVar var
case v of
Nothing -> return Nothing
Just v -> do {putMVar var v; return (Just v)}
resetExpiringMVarTimer :: ExpiringMVar a -> IO (ExpiringMVar a)
resetExpiringMVarTimer expires@(ExpiringMVar var expireTime _) = do
wasCleared <- isExpiredMVar expires
if wasCleared
then return expires
else do cancelExpiration expires
newExpirer <- forkExpireIn expireTime var
return $ expires { expirer = newExpirer }
forkExpireIn :: Int -> MVar a -> IO ThreadId
forkExpireIn delay var = forkIO $ expireIn delay var
expireIn :: Int -> MVar a -> IO ()
expireIn delay var = do
threadDelay delay
empty <- isEmptyMVar var
tryTakeMVar var
return ()
isExpiredMVar :: ExpiringMVar a -> IO Bool
isExpiredMVar expires =
isEmptyMVar (var expires)
cancelExpiration :: ExpiringMVar a -> IO ()
cancelExpiration expires =
killThread (expirer expires)
changeExpiration :: Int
-> ExpiringMVar a -> IO (ExpiringMVar a)
changeExpiration newDelay expires =
resetExpiringMVarTimer (expires { expireTime = newDelay })
mfilterM :: (Monoid (f a), Applicative f, Traversable t, Monad m) =>
(a -> m Bool) -> t a -> m (f a)
mfilterM p c = do
t <- Traversable.mapM (\x -> do
b <- p x
return (if b
then pure x
else mempty)
) c
return $ Foldable.fold t
removeExpiredMVars :: (Monoid (f (ExpiringMVar a)), Alternative f, Traversable.Traversable t) =>
t (ExpiringMVar a) -> IO (f (ExpiringMVar a))
removeExpiredMVars = mfilterM (\x -> do {b <- isExpiredMVar x; return $ not b})
secondsToMicroseconds :: Int -> Int
secondsToMicroseconds = (* 1000000)
testAux :: [ExpiringMVar Char] -> IO ()
testAux xs = do
xs' <- removeExpiredMVars xs :: IO [ExpiringMVar Char]
print $ length xs'
when (length xs' > 0) $
do {threadDelay $ secondsToMicroseconds 10; testAux xs'}
test :: IO ()
test = do
xs <- Control.Monad.mapM (\d -> newExpiringMVar 'c' (d*1000)) [1..100000]
testAux xs