Control/Concurrent/SampleVar.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Concurrent.SampleVar
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable (concurrency)
  10 --
  11 -- Sample variables
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Control.Concurrent.SampleVar
  16        (
  17          -- * Sample Variables
  18          SampleVar,         -- :: type _ =
  19
  20          newEmptySampleVar, -- :: IO (SampleVar a)
  21          newSampleVar,      -- :: a -> IO (SampleVar a)
  22          emptySampleVar,    -- :: SampleVar a -> IO ()
  23          readSampleVar,     -- :: SampleVar a -> IO a
  24          writeSampleVar,    -- :: SampleVar a -> a -> IO ()
  25          isEmptySampleVar,  -- :: SampleVar a -> IO Bool
  26
  27        ) where
  28
  29 import Prelude
  30
  31 import Control.Concurrent.MVar
  32
  33 import Control.Exception ( mask_ )
  34
  35 import Data.Functor ( (<$>) )
  36
  37 import Data.Typeable
  38
  39 #include "Typeable.h"
  40
  41 -- |
  42 -- Sample variables are slightly different from a normal 'MVar':
  43 --
  44 --  * Reading an empty 'SampleVar' causes the reader to block.
  45 --    (same as 'takeMVar' on empty 'MVar')
  46 --
  47 --  * Reading a filled 'SampleVar' empties it and returns value.
  48 --    (same as 'takeMVar')
  49 --
  50 --  * Writing to an empty 'SampleVar' fills it with a value, and
  51 --    potentially, wakes up a blocked reader (same as for 'putMVar' on
  52 --    empty 'MVar').
  53 --
  54 --  * Writing to a filled 'SampleVar' overwrites the current value.
  55 --    (different from 'putMVar' on full 'MVar'.)
  56
  57 newtype SampleVar a = SampleVar ( MVar ( Int    -- 1  == full
  58                                                 -- 0  == empty
  59                                                 -- <0 no of readers blocked
  60                                        , MVar a
  61                                        )
  62                                 )
  63     deriving (Eq)
  64
  65 INSTANCE_TYPEABLE1(SampleVar,sampleVarTc,"SampleVar")
  66
  67 -- |Build a new, empty, 'SampleVar'
  68 newEmptySampleVar :: IO (SampleVar a)
  69 newEmptySampleVar = do
  70    v <- newEmptyMVar
  71    SampleVar <$> newMVar (0,v)
  72
  73 -- |Build a 'SampleVar' with an initial value.
  74 newSampleVar :: a -> IO (SampleVar a)
  75 newSampleVar a = do
  76    v <- newMVar a
  77    SampleVar <$> newMVar (1,v)
  78
  79 -- |If the SampleVar is full, leave it empty.  Otherwise, do nothing.
  80 emptySampleVar :: SampleVar a -> IO ()
  81 emptySampleVar (SampleVar v) = mask_ $ do
  82    s@(readers, var) <- takeMVar v
  83    if readers > 0 then do
  84      _ <- takeMVar var
  85      putMVar v (0,var)
  86     else
  87      putMVar v s
  88
  89 -- |Wait for a value to become available, then take it and return.
  90 readSampleVar :: SampleVar a -> IO a
  91 readSampleVar (SampleVar svar) = mask_ $ do
  92 --
  93 -- filled => make empty and grab sample
  94 -- not filled => try to grab value, empty when read val.
  95 --
  96    (readers,val) <- takeMVar svar
  97    let readers' = readers-1
  98    readers' `seq` putMVar svar (readers',val)
  99    takeMVar val
 100
 101 -- |Write a value into the 'SampleVar', overwriting any previous value that
 102 -- was there.
 103 writeSampleVar :: SampleVar a -> a -> IO ()
 104 writeSampleVar (SampleVar svar) v = mask_ $ do
 105 --
 106 -- filled => overwrite
 107 -- not filled => fill, write val
 108 --
 109    s@(readers,val) <- takeMVar svar
 110    case readers of
 111      1 ->
 112        swapMVar val v >>
 113        putMVar svar s
 114      _ ->
 115        putMVar val v >>
 116        let readers' = min 1 (readers+1)
 117        in readers' `seq` putMVar svar (readers', val)
 118
 119 -- | Returns 'True' if the 'SampleVar' is currently empty.
 120 --
 121 -- Note that this function is only useful if you know that no other
 122 -- threads can be modifying the state of the 'SampleVar', because
 123 -- otherwise the state of the 'SampleVar' may have changed by the time
 124 -- you see the result of 'isEmptySampleVar'.
 125 --
 126 isEmptySampleVar :: SampleVar a -> IO Bool
 127 isEmptySampleVar (SampleVar svar) = do
 128    (readers, _) <- readMVar svar
 129    return (readers <= 0)
 130