Control/Concurrent/SampleVar.hs

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