Control/Concurrent/MVar.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Control.Concurrent.MVar
   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 -- Synchronising variables
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Control.Concurrent.MVar
  16         (
  17           -- * @MVar@s
  18           MVar          -- abstract
  19         , newEmptyMVar  -- :: IO (MVar a)
  20         , newMVar       -- :: a -> IO (MVar a)
  21         , takeMVar      -- :: MVar a -> IO a
  22         , putMVar       -- :: MVar a -> a -> IO ()
  23         , readMVar      -- :: MVar a -> IO a
  24         , swapMVar      -- :: MVar a -> a -> IO a
  25         , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
  26         , tryPutMVar    -- :: MVar a -> a -> IO Bool
  27         , isEmptyMVar   -- :: MVar a -> IO Bool
  28         , withMVar      -- :: MVar a -> (a -> IO b) -> IO b
  29         , modifyMVar_   -- :: MVar a -> (a -> IO a) -> IO ()
  30         , modifyMVar    -- :: MVar a -> (a -> IO (a,b)) -> IO b
  31 #ifndef __HUGS__
  32         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
  33 #endif
  34     ) where
  35
  36 #ifdef __HUGS__
  37 import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
  38                   tryTakeMVar, tryPutMVar, isEmptyMVar,
  39                 )
  40 #endif
  41
  42 #ifdef __GLASGOW_HASKELL__
  43 import GHC.MVar ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
  44                   tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
  45                 )
  46 #endif
  47
  48 import Prelude
  49 import Control.Exception.Base
  50
  51 {-|
  52   This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
  53   from the 'MVar', puts it back, and also returns it.
  54 -}
  55 readMVar :: MVar a -> IO a
  56 readMVar m =
  57   block $ do
  58     a <- takeMVar m
  59     putMVar m a
  60     return a
  61
  62 {-|
  63   Take a value from an 'MVar', put a new value into the 'MVar' and
  64   return the value taken. Note that there is a race condition whereby
  65   another process can put something in the 'MVar' after the take
  66   happens but before the put does.
  67 -}
  68 swapMVar :: MVar a -> a -> IO a
  69 swapMVar mvar new =
  70   block $ do
  71     old <- takeMVar mvar
  72     putMVar mvar new
  73     return old
  74
  75 {-|
  76   'withMVar' is a safe wrapper for operating on the contents of an
  77   'MVar'.  This operation is exception-safe: it will replace the
  78   original contents of the 'MVar' if an exception is raised (see
  79   "Control.Exception").
  80 -}
  81 {-# INLINE withMVar #-}
  82 -- inlining has been reported to have dramatic effects; see
  83 -- http://www.haskell.org//pipermail/haskell/2006-May/017907.html
  84 withMVar :: MVar a -> (a -> IO b) -> IO b
  85 withMVar m io =
  86   block $ do
  87     a <- takeMVar m
  88     b <- unblock (io a) `onException` putMVar m a
  89     putMVar m a
  90     return b
  91
  92 {-|
  93   A safe wrapper for modifying the contents of an 'MVar'.  Like 'withMVar',
  94   'modifyMVar' will replace the original contents of the 'MVar' if an
  95   exception is raised during the operation.
  96 -}
  97 {-# INLINE modifyMVar_ #-}
  98 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
  99 modifyMVar_ m io =
 100   block $ do
 101     a  <- takeMVar m
 102     a' <- unblock (io a) `onException` putMVar m a
 103     putMVar m a'
 104
 105 {-|
 106   A slight variation on 'modifyMVar_' that allows a value to be
 107   returned (@b@) in addition to the modified value of the 'MVar'.
 108 -}
 109 {-# INLINE modifyMVar #-}
 110 modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
 111 modifyMVar m io =
 112   block $ do
 113     a      <- takeMVar m
 114     (a',b) <- unblock (io a) `onException` putMVar m a
 115     putMVar m a'
 116     return b