Control/Concurrent/MVar.hs

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