module Control.Concurrent.Stack
( Stack ()
, newStack
, readStack
, writeStack )
where
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad (join)
data Stack a = Stack { readLock :: MVar (), waitBuf :: MVar a, stackVar :: MVar [a] }
newStack :: IO (Stack a)
newStack = do
rL <- newMVar ()
wB <- newEmptyMVar
sV <- newMVar []
return $ Stack rL wB sV
readStack :: Stack a -> IO a
readStack stack = do
withMVar (readLock stack) $ \() -> do
join $ modifyMVar (stackVar stack) $ \xss -> do
mx <- tryTakeMVar (waitBuf stack)
case mx of
Just x -> do
return (xss, return x)
Nothing -> do
case xss of
[] -> do
return ([], takeMVar (waitBuf stack))
x:xs -> do
return (xs, return x)
writeStack :: Stack a -> a -> IO ()
writeStack stack x = do
modifyMVar_ (stackVar stack) $ \xs -> do
wasWaiting <- tryPutMVar (waitBuf stack) x
if wasWaiting
then return xs
else return $ x:xs