{-|
Module      : Control.Concurrent.Stack
Description : Simple stack with concurrent access
Copyright   : (c) Bastian Holst, 2014
License     : BSD3
Maintainer  : bastianholst@gmx.de
Stability   : experimental
Portability : POSIX

A simple stack implementation with an concurrent access functions similar to
that of 'Chan'. In contrast to 'Chan', which is a FIFO buffer,
this type is a LIFO buffer.
-}
module Control.Concurrent.Stack
 ( Stack ()
 , newStack
 , readStack
 , writeStack )
where

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad (join)

-- | Concurrent stack.
data Stack a = Stack { readLock :: MVar (), waitBuf :: MVar a, stackVar :: MVar [a] }

-- | Build and return a new instance of 'Stack'.
newStack :: IO (Stack a)
newStack = do
  rL <- newMVar ()
  wB <- newEmptyMVar
  sV <- newMVar []
  return $ Stack rL wB sV

-- | Read the next value from the 'Stack'.
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)

-- | Write a value into the 'Stack'.
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