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