Buffer.hs

{- |
Module      :  <File name or $Header$ to be replaced automatically>
Description :  This module implements a buffer with cells and futures.
Maintainer  :  willig@ki.informatik.uni-frankfurt.de
Stability   :  experimental
Portability :  non-portable (requires Futures)

This module implements one-place buffers using futures.
Warning: All operations on buffers should only be used within the global wrapper function
'Futures.withFuturesDo'!
-}
module Control.Concurrent.Futures.Buffer ( 
 Buffer,
 newBuf,
 putBuf,
 getBuf
) where

import Control.Concurrent.Futures.Futures as Futures
import Control.Concurrent.MVar
import System.IO

-- | The buffer type contains of 3 cells and a handle. The first 2 cells are for
-- communication of either a put or get is allowed. The thrist cell is the storage
-- cell, the last cell contains a the active handle.
type Buffer a = (Cell Bool, Cell Bool, Cell a, Cell (Bool -> IO ()))

-----------------------------------------------------------------------
---Cells

-- | A cell type. Cells provide an automic 'exchange' operation.
type Cell a = MVar a

-- | Creates a new cell.
cell :: a -> IO (Cell a)
cell a = newMVar a

exchange :: Cell a -> a -> IO a 
exchange a b = swapMVar a b

-- | TestAndSet on cells provides test and set functions in one atomic operation.
testAndSet :: Cell Bool -> IO t -> IO Bool
testAndSet cell code =  do 
 val <- (exchange cell True)
 case val of
   True -> return True
   False -> do 
           code
           exchange cell False
-------------------------------------------------------------------------------

-- | Waits its argument to become true.
wait :: Bool -> IO Bool
wait x = do
 case x of
  True -> return x
  otherwise -> return x

-- | Creates a new empty buffer.
newBuf :: IO (Buffer a)
newBuf = do
 (h,f) <- Futures.newhandled
 (h',f') <- Futures.newhandled
 putg <- cell True
 getg <- cell f
 stored <- cell f'
 handler <- cell h
 return (putg,getg,stored,handler)

-- | Puts a new value to a buffer. 'putBuf' blocks if
-- the buffer is full.  
putBuf :: Buffer a -> a -> IO ()
putBuf (putg,getg,stored,handler) val = do
   (h,f) <- Futures.newhandled
   old_value <- exchange putg f
   wait old_value
   exchange stored val
   old_handler <- exchange handler h
   old_handler True

-- | Gets the contents of a non-empty buffer. If the buffer is empty, then 
-- this function blocks until the buffer is filled.
getBuf :: Buffer a -> IO a 
getBuf (putg,getg,stored,handler) = do
 (h,f) <- Futures.newhandled
 (h',f') <- Futures.newhandled
 old_value <- exchange getg f
 wait old_value
 val <- exchange stored f'
 old_handler <- exchange handler h
 old_handler True
 return val