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