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         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
  32     ) where
  33
  34 #ifdef __HUGS__
  35 import ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
  36                   tryTakeMVar, tryPutMVar, isEmptyMVar,
  37                   readMVar, swapMVar,
  38                 )
  39 import Prelude hiding( catch )
  40 #endif
  41
  42 #ifdef __GLASGOW_HASKELL__
  43 import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
  44                   tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
  45                 )
  46 #endif
  47
  48 import Control.Exception as Exception
  49
  50 #ifdef __HUGS__
  51 -- This is as close as Hugs gets to providing throw
  52 throw :: Exception -> IO a
  53 throw = throwIO
  54 #endif
  55
  56 #ifdef __GLASGOW_HASKELL__
  57 {-|
  58   This is a combination of 'takeMVar' and 'putMVar'; ie. it takes the value
  59   from the 'MVar', puts it back, and also returns it.
  60 -}
  61 readMVar :: MVar a -> IO a
  62 readMVar m =
  63   block $ do
  64     a <- takeMVar m
  65     putMVar m a
  66     return a
  67
  68 -- |Swap the contents of an 'MVar' for a new value.
  69 swapMVar :: MVar a -> a -> IO a
  70 swapMVar mvar new = modifyMVar mvar (\old -> return (new,old))
  71 #endif
  72
  73 {-|
  74   'withMVar' is a safe wrapper for operating on the contents of an
  75   'MVar'.  This operation is exception-safe: it will replace the
  76   original contents of the 'MVar' if an exception is raised (see
  77   "Control.Exception").
  78 -}
  79 withMVar :: MVar a -> (a -> IO b) -> IO b
  80 withMVar m io =
  81   block $ do
  82     a <- takeMVar m
  83     b <- Exception.catch (unblock (io a))
  84             (\e -> do putMVar m a; throw e)
  85     putMVar m a
  86     return b
  87
  88 {-|
  89   A safe wrapper for modifying the contents of an 'MVar'.  Like 'withMVar',
  90   'modifyMVar' will replace the original contents of the 'MVar' if an
  91   exception is raised during the operation.
  92 -}
  93 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
  94 modifyMVar_ m io =
  95   block $ do
  96     a  <- takeMVar m
  97     a' <- Exception.catch (unblock (io a))
  98             (\e -> do putMVar m a; throw e)
  99     putMVar m a'
 100
 101 {-|
 102   A slight variation on 'modifyMVar_' that allows a value to be
 103   returned (@b@) in addition to the modified value of the 'MVar'.
 104 -}
 105 modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
 106 modifyMVar m io =
 107   block $ do
 108     a      <- takeMVar m
 109     (a',b) <- Exception.catch (unblock (io a))
 110                 (\e -> do putMVar m a; throw e)
 111     putMVar m a'
 112     return b