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