MSampleVar.hs

--
-- Module      :  Control.Concurrent.MSampleVar
-- Copyright   :  (c) Chris Kuklewicz 2011
-- License     :  3 clause BSD-style (see the file LICENSE)
-- 
-- Maintainer  :  haskell@list.mightyreason.com
-- Stability   :  experimental
-- Portability :  non-portable (concurrency)
--

-- | 'MSampleVar' is a safer version of the "Control.Concurrent.SampleVar" in
-- base.  The same problem as QSem(N) is being fixed, that of handling waiters
-- that die before being woken normally.  For "Control.Concurrent.SampleVar" in
-- base this error can lead to thinking a full 'SampleVar' is really empty and
-- cause 'writeSampleVar' to hang.  The 'MSampleVar' in this module is immune
-- to this error, and has a simpler implementation.
module Control.Concurrent.MSampleVar
       (
         -- * Sample Variables
         MSampleVar,         -- :: type _ =
 
         newEmptySV, -- :: IO (MSampleVar a)
         newSV,      -- :: a -> IO (MSampleVar a)
         emptySV,    -- :: MSampleVar a -> IO ()
         readSV,     -- :: MSampleVar a -> IO a
         writeSV,    -- :: MSampleVar a -> a -> IO ()
         isEmptySV,  -- :: MSampleVar a -> IO Bool

       ) where

import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
import Data.Typeable(Typeable)

-- |
-- Sample variables are slightly different from a normal 'MVar':
-- 
--  * Reading an empty 'MSampleVar' causes the reader to block.
--    (same as 'takeMVar' on empty 'MVar')
-- 
--  * Reading a filled 'MSampleVar' empties it and returns value.
--    (same as 'takeMVar')
--
--  * Try reading a filled 'MSampleVar' returns a Maybe value.
--    (same as 'tryTakeMVar')
-- 
--  * Writing to an empty 'MSampleVar' fills it with a value, and
--    potentially, wakes up a blocked reader (same as for 'putMVar' on
--    empty 'MVar').
--
--  * Writing to a filled 'MSampleVar' overwrites the current value.
--    (different from 'putMVar' on full 'MVar'.)
data MSampleVar a = MSampleVar { readQueue :: MVar ()
                               , lockedStore :: MVar (MVar a) }

-- 'newEmptySV' allocates a new MSampleVar in an empty state.  No futher
-- allocation is done when using the 'MSampleVar'.
newEmptySV :: IO (MSampleVar a)
newEmptySV = do
  newReadQueue <- newMVar ()
  newLockedStore <- newMVar =<< newEmptyMVar
  return (MSampleVar { readQueue = newReadQueue
                     , lockedStore = newLockedStore })

-- 'newSV' allocates a new MSampleVar containing the passed value.  The value
-- is not evalated or forced, but stored lazily.  No futher allocation is done
-- when using the 'MSampleVar'.
newSV :: a -> IO (MSampleVar a)
newSV a = do
  newReadQueue <- newMVar ()
  newLockedStore <- newMVar =<< newMVar a
  return (MSampleVar { readQueue = newReadQueue
                     , lockedStore = newLockedStore })

-- 'isEmptySV' can block and be interrupted, in which case it does nothing.  If
-- 'isEmptySV' returns then it reports the momentary status the 'MSampleVar'.
-- Using this value without producing unwanted race conditions is left up to
-- the programmer.
isEmptySV :: MSampleVar a -> IO Bool
isEmptySV (MSampleVar _ ls) = withMVar ls isEmptyMVar
  -- (withMVar ls) might block, interrupting is okay

-- | If the 'MSampleVar' is full, leave it empty.  Otherwise, do nothing.
--
-- 'emptySV' can block and be interrupted, in which case it does nothing.  If
-- 'emptySV' returns then it left the 'MSampleVar' in an empty state.
emptySV :: MSampleVar a -> IO ()
emptySV (MSampleVar _ ls) = withMVar ls (void . tryTakeMVar)
  -- (withMVar ls) might block, interrupting is okay

-- | Wait for a value to become available, then take it and return.
--
-- 'readSV' can block and be interrupted, in which case it takes nothing.  If
-- 'readSV returns normally then it has taken a value.
readSV :: MSampleVar a -> IO a
readSV (MSampleVar rq ls) =  mask_ $ withMVar rq $ \ () ->
  join $ withMVar ls (return . takeMVar)
  -- (withMVar rq) might block, interrupting is okay
  -- (withMVar ls) might block, interrupting is okay
  -- join (takeMVar v) might block if empty, interrupting is okay

-- | Write a value into the 'MSampleVar', overwriting any previous value that was
-- there.
--
-- 'writeSV' can block and be interrupted, in which case it does nothing.
writeSV :: MSampleVar a -> a -> IO ()
writeSV (MSampleVar _ ls) a = mask_ $ withMVar ls $ \ v -> do
  void (tryTakeMVar v)
  putMVar v a           -- cannot block
  -- (withMVar ls) might block, interrupting is okay