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 -- $Id: MVar.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
  12 --
  13 -- MVars: Synchronising variables
  14 --
  15 -----------------------------------------------------------------------------
  16
  17 module Control.Concurrent.MVar
  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 readMVar :: MVar a -> IO a
  58 readMVar m =
  59   block $ do
  60     a <- takeMVar m
  61     putMVar m a
  62     return a
  63
  64 swapMVar :: MVar a -> a -> IO a
  65 swapMVar mvar new = modifyMVar mvar (\old -> return (new,old))
  66 #endif
  67
  68 -- put back the same value, return something
  69 withMVar :: MVar a -> (a -> IO b) -> IO b
  70 withMVar m io =
  71   block $ do
  72     a <- takeMVar m
  73     b <- Exception.catch (unblock (io a))
  74             (\e -> do putMVar m a; throw e)
  75     putMVar m a
  76     return b
  77
  78 -- put back a new value, return ()
  79 modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
  80 modifyMVar_ m io =
  81   block $ do
  82     a  <- takeMVar m
  83     a' <- Exception.catch (unblock (io a))
  84             (\e -> do putMVar m a; throw e)
  85     putMVar m a'
  86
  87 -- put back a new value, return something
  88 modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
  89 modifyMVar m io =
  90   block $ do
  91     a      <- takeMVar m
  92     (a',b) <- Exception.catch (unblock (io a))
  93                 (\e -> do putMVar m a; throw e)
  94     putMVar m a'
  95     return b