[project @ 2002-05-09 13:16:29 by simonmar]
[packages/random.git] / 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
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