module Control.Concurrent.STM.TMonoid (TMonoid, writeTMonoid, readTMonoid, newDelayedTMonoid) where
import Control.Concurrent.STM
import Data.Monoid
import Control.Monad (when)
data TMonoid m = TMonoid {
writeTMonoid :: m -> STM (),
readTMonoid :: STM m
}
newDelayedTMonoid :: (Monoid m, Eq m)
=> Int
-> STM (TMonoid m)
newDelayedTMonoid n = do
x <- newTVar mempty
was <- newTVar 0
let write y | y == mempty = readTVar was >>= writeTVar was . (+ 1)
| otherwise = readTVar x >>= writeTVar x . (`mappend` y) >> writeTVar was 0
read' = do
y <- readTVar x
z <- readTVar was
when (y == mempty || z < n) retry
writeTVar x mempty
return y
return $ TMonoid write read'