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/core/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable
  10 --
  11 -- MVars: Synchronising variables
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Control.Concurrent.MVar
  16         ( MVar          -- abstract
  17         , newEmptyMVar  -- :: IO (MVar a)
  18         , newMVar       -- :: a -> IO (MVar a)
  19         , takeMVar      -- :: MVar a -> IO a
  20         , putMVar       -- :: MVar a -> a -> IO ()
  21         , readMVar      -- :: MVar a -> IO a
  22         , swapMVar      -- :: MVar a -> a -> IO a
  23         , tryTakeMVar   -- :: MVar a -> IO (Maybe a)
  24         , tryPutMVar    -- :: MVar a -> a -> IO Bool
  25         , isEmptyMVar   -- :: MVar a -> IO Bool
  26         , withMVar      -- :: MVar a -> (a -> IO b) -> IO b
  27         , modifyMVar_   -- :: MVar a -> (a -> IO a) -> IO ()
  28         , modifyMVar    -- :: MVar a -> (a -> IO (a,b)) -> IO b
  29         , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
  30     ) where
  31
  32 #ifdef __HUGS__
  33 import ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
  34                   tryTakeMVar, tryPutMVar, isEmptyMVar,
  35                   readMVar, swapMVar,
  36                 )
  37 import Prelude hiding( catch )
  38 #endif
  39
  40 #ifdef __GLASGOW_HASKELL__
  41 import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
  42                   tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
  43                 )
  44 #endif
  45
  46 import Control.Exception as Exception
  47
  48 #ifdef __HUGS__
  49 -- This is as close as Hugs gets to providing throw
  50 throw :: Exception -> IO a
  51 throw = throwIO
  52 #endif
  53
  54 #ifdef __GLASGOW_HASKELL__
  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 swapMVar :: MVar a -> a -> IO a
  63 swapMVar mvar new = modifyMVar mvar (\old -> return (new,old))
  64 #endif
  65
  66 -- put back the same value, return something
  67 withMVar :: MVar a -> (a -> IO b) -> IO b
  68 withMVar m io =
  69   block $ do
  70     a <- takeMVar m
  71     b <- Exception.catch (unblock (io a))
  72             (\e -> do putMVar m a; throw e)
  73     putMVar m a
  74     return b
  75
  76 -- put back a new value, return ()
  77 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
  78 modifyMVar_ m io =
  79   block $ do
  80     a  <- takeMVar m
  81     a' <- Exception.catch (unblock (io a))
  82             (\e -> do putMVar m a; throw e)
  83     putMVar m a'
  84
  85 -- put back a new value, return something
  86 modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
  87 modifyMVar m io =
  88   block $ do
  89     a      <- takeMVar m
  90     (a',b) <- Exception.catch (unblock (io a))
  91                 (\e -> do putMVar m a; throw e)
  92     putMVar m a'
  93     return b