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