module Control.Concurrent.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