Control/Concurrent/SampleVar.hs

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