add readIORef to sequential implementation
[packages/stm.git] / Control / Sequential / STM.hs
1 -- Transactional memory for sequential implementations.
2 -- Transactions do not run concurrently, but are atomic in the face
3 -- of exceptions.
4
5 -- #hide
6 module Control.Sequential.STM (
7 STM, atomically, catchSTM,
8 TVar, newTVar, newTVarIO, readTVar, readTVarIO, writeTVar
9 ) where
10
11 import Prelude hiding (catch)
12 import Control.Exception
13 import Data.IORef
14
15 -- The reference contains a rollback action to be executed on exceptions
16 newtype STM a = STM (IORef (IO ()) -> IO a)
17
18 unSTM :: STM a -> IORef (IO ()) -> IO a
19 unSTM (STM f) = f
20
21 instance Functor STM where
22 fmap f (STM m) = STM (fmap f . m)
23
24 instance Monad STM where
25 return x = STM (const (return x))
26 STM m >>= k = STM $ \ r -> do
27 x <- m r
28 unSTM (k x) r
29
30 #ifdef BASE4
31 atomically :: STM a -> IO a
32 atomically (STM m) = do
33 r <- newIORef (return ())
34 m r `onException` do
35 rollback <- readIORef r
36 rollback
37 #else
38 atomically :: STM a -> IO a
39 atomically (STM m) = do
40 r <- newIORef (return ())
41 m r `catch` \ ex -> do
42 rollback <- readIORef r
43 rollback
44 throw ex
45 #endif
46
47 #ifdef BASE4
48 catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
49 #else
50 catchSTM :: STM a -> (Exception -> STM a) -> STM a
51 #endif
52 catchSTM (STM m) h = STM $ \ r -> do
53 old_rollback <- readIORef r
54 writeIORef r (return ())
55 res <- try (m r)
56 rollback_m <- readIORef r
57 case res of
58 Left ex -> do
59 rollback_m
60 writeIORef r old_rollback
61 unSTM (h ex) r
62 Right a -> do
63 writeIORef r (rollback_m >> old_rollback)
64 return a
65
66 newtype TVar a = TVar (IORef a)
67 deriving (Eq)
68
69 newTVar :: a -> STM (TVar a)
70 newTVar a = STM (const (newTVarIO a))
71
72 newTVarIO :: a -> IO (TVar a)
73 newTVarIO a = do
74 ref <- newIORef a
75 return (TVar ref)
76
77 readTVar :: TVar a -> STM a
78 readTVar (TVar ref) = STM (const (readIORef ref))
79
80 readTVarIO :: TVar a -> IO a
81 readTVarIO (TVar ref) = readIORef ref
82
83 writeTVar :: TVar a -> a -> STM ()
84 writeTVar (TVar ref) a = STM $ \ r -> do
85 oldval <- readIORef ref
86 modifyIORef r (writeIORef ref oldval >>)
87 writeIORef ref a