{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
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
newtype STM a = STM (IORef (IO ()) -> IO a)
unSTM :: STM a -> IORef (IO ()) -> IO a
unSTM :: forall a. STM a -> IORef (IO ()) -> IO a
unSTM (STM IORef (IO ()) -> IO a
f) = IORef (IO ()) -> IO a
f
instance Functor STM where
fmap :: forall a b. (a -> b) -> STM a -> STM b
fmap a -> b
f (STM IORef (IO ()) -> IO a
m) = (IORef (IO ()) -> IO b) -> STM b
forall a. (IORef (IO ()) -> IO a) -> STM a
STM ((a -> b) -> IO a -> IO b
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (IO a -> IO b) -> (IORef (IO ()) -> IO a) -> IORef (IO ()) -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (IO ()) -> IO a
m)
instance Applicative STM where
pure :: forall a. a -> STM a
pure = (IORef (IO ()) -> IO a) -> STM a
forall a. (IORef (IO ()) -> IO a) -> STM a
STM ((IORef (IO ()) -> IO a) -> STM a)
-> (a -> IORef (IO ()) -> IO a) -> a -> STM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IORef (IO ()) -> IO a
forall a b. a -> b -> a
const (IO a -> IORef (IO ()) -> IO a)
-> (a -> IO a) -> a -> IORef (IO ()) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
STM IORef (IO ()) -> IO (a -> b)
mf <*> :: forall a b. STM (a -> b) -> STM a -> STM b
<*> STM IORef (IO ()) -> IO a
mx = (IORef (IO ()) -> IO b) -> STM b
forall a. (IORef (IO ()) -> IO a) -> STM a
STM ((IORef (IO ()) -> IO b) -> STM b)
-> (IORef (IO ()) -> IO b) -> STM b
forall a b. (a -> b) -> a -> b
$ \ IORef (IO ())
r -> IORef (IO ()) -> IO (a -> b)
mf IORef (IO ())
r IO (a -> b) -> IO a -> IO b
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IORef (IO ()) -> IO a
mx IORef (IO ())
r
instance Monad STM where
return :: forall a. a -> STM a
return = a -> STM a
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
STM IORef (IO ()) -> IO a
m >>= :: forall a b. STM a -> (a -> STM b) -> STM b
>>= a -> STM b
k = (IORef (IO ()) -> IO b) -> STM b
forall a. (IORef (IO ()) -> IO a) -> STM a
STM ((IORef (IO ()) -> IO b) -> STM b)
-> (IORef (IO ()) -> IO b) -> STM b
forall a b. (a -> b) -> a -> b
$ \ IORef (IO ())
r -> do
x <- IORef (IO ()) -> IO a
m IORef (IO ())
r
unSTM (k x) r
atomically :: STM a -> IO a
atomically :: forall a. STM a -> IO a
atomically (STM IORef (IO ()) -> IO a
m) = do
r <- IO () -> IO (IORef (IO ()))
forall a. a -> IO (IORef a)
newIORef (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
m r `onException` do
rollback <- readIORef r
rollback
throwSTM :: Exception e => e -> STM a
throwSTM :: forall e a. Exception e => e -> STM a
throwSTM = (IORef (IO ()) -> IO a) -> STM a
forall a. (IORef (IO ()) -> IO a) -> STM a
STM ((IORef (IO ()) -> IO a) -> STM a)
-> (e -> IORef (IO ()) -> IO a) -> e -> STM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IORef (IO ()) -> IO a
forall a b. a -> b -> a
const (IO a -> IORef (IO ()) -> IO a)
-> (e -> IO a) -> e -> IORef (IO ()) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO
catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
catchSTM :: forall e a. Exception e => STM a -> (e -> STM a) -> STM a
catchSTM (STM IORef (IO ()) -> IO a
m) e -> STM a
h = (IORef (IO ()) -> IO a) -> STM a
forall a. (IORef (IO ()) -> IO a) -> STM a
STM ((IORef (IO ()) -> IO a) -> STM a)
-> (IORef (IO ()) -> IO a) -> STM a
forall a b. (a -> b) -> a -> b
$ \ IORef (IO ())
r -> do
old_rollback <- IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef IORef (IO ())
r
writeIORef r (return ())
res <- try (m r)
rollback_m <- readIORef r
case res of
Left e
ex -> do
IO ()
rollback_m
IORef (IO ()) -> IO () -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IO ())
r IO ()
old_rollback
STM a -> IORef (IO ()) -> IO a
forall a. STM a -> IORef (IO ()) -> IO a
unSTM (e -> STM a
h e
ex) IORef (IO ())
r
Right a
a -> do
IORef (IO ()) -> IO () -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IO ())
r (IO ()
rollback_m IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
old_rollback)
a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
newtype TVar a = TVar (IORef a)
deriving (TVar a -> TVar a -> Bool
(TVar a -> TVar a -> Bool)
-> (TVar a -> TVar a -> Bool) -> Eq (TVar a)
forall a. TVar a -> TVar a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. TVar a -> TVar a -> Bool
== :: TVar a -> TVar a -> Bool
$c/= :: forall a. TVar a -> TVar a -> Bool
/= :: TVar a -> TVar a -> Bool
Eq)
newTVar :: a -> STM (TVar a)
newTVar :: forall a. a -> STM (TVar a)
newTVar a
a = (IORef (IO ()) -> IO (TVar a)) -> STM (TVar a)
forall a. (IORef (IO ()) -> IO a) -> STM a
STM (IO (TVar a) -> IORef (IO ()) -> IO (TVar a)
forall a b. a -> b -> a
const (a -> IO (TVar a)
forall a. a -> IO (TVar a)
newTVarIO a
a))
newTVarIO :: a -> IO (TVar a)
newTVarIO :: forall a. a -> IO (TVar a)
newTVarIO a
a = do
ref <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a
return (TVar ref)
readTVar :: TVar a -> STM a
readTVar :: forall a. TVar a -> STM a
readTVar (TVar IORef a
ref) = (IORef (IO ()) -> IO a) -> STM a
forall a. (IORef (IO ()) -> IO a) -> STM a
STM (IO a -> IORef (IO ()) -> IO a
forall a b. a -> b -> a
const (IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref))
readTVarIO :: TVar a -> IO a
readTVarIO :: forall a. TVar a -> IO a
readTVarIO (TVar IORef a
ref) = IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref
writeTVar :: TVar a -> a -> STM ()
writeTVar :: forall a. TVar a -> a -> STM ()
writeTVar (TVar IORef a
ref) a
a = (IORef (IO ()) -> IO ()) -> STM ()
forall a. (IORef (IO ()) -> IO a) -> STM a
STM ((IORef (IO ()) -> IO ()) -> STM ())
-> (IORef (IO ()) -> IO ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \ IORef (IO ())
r -> do
oldval <- IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref
modifyIORef r (writeIORef ref oldval >>)
writeIORef ref a