{-# 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) = forall a. (IORef (IO ()) -> IO a) -> STM a
STM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f 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 = forall a. (IORef (IO ()) -> IO a) -> STM a
STM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. (IORef (IO ()) -> IO a) -> STM a
STM forall a b. (a -> b) -> a -> b
$ \ IORef (IO ())
r -> IORef (IO ()) -> IO (a -> b)
mf IORef (IO ())
r 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 = 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 = forall a. (IORef (IO ()) -> IO a) -> STM a
STM forall a b. (a -> b) -> a -> b
$ \ IORef (IO ())
r -> do
a
x <- IORef (IO ()) -> IO a
m IORef (IO ())
r
forall a. STM a -> IORef (IO ()) -> IO a
unSTM (a -> STM b
k a
x) IORef (IO ())
r
atomically :: STM a -> IO a
atomically :: forall a. STM a -> IO a
atomically (STM IORef (IO ()) -> IO a
m) = do
IORef (IO ())
r <- forall a. a -> IO (IORef a)
newIORef (forall (m :: * -> *) a. Monad m => a -> m a
return ())
IORef (IO ()) -> IO a
m IORef (IO ())
r forall a b. IO a -> IO b -> IO a
`onException` do
IO ()
rollback <- forall a. IORef a -> IO a
readIORef IORef (IO ())
r
IO ()
rollback
throwSTM :: Exception e => e -> STM a
throwSTM :: forall e a. Exception e => e -> STM a
throwSTM = forall a. (IORef (IO ()) -> IO a) -> STM a
STM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. 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 = forall a. (IORef (IO ()) -> IO a) -> STM a
STM forall a b. (a -> b) -> a -> b
$ \ IORef (IO ())
r -> do
IO ()
old_rollback <- forall a. IORef a -> IO a
readIORef IORef (IO ())
r
forall a. IORef a -> a -> IO ()
writeIORef IORef (IO ())
r (forall (m :: * -> *) a. Monad m => a -> m a
return ())
Either e a
res <- forall e a. Exception e => IO a -> IO (Either e a)
try (IORef (IO ()) -> IO a
m IORef (IO ())
r)
IO ()
rollback_m <- forall a. IORef a -> IO a
readIORef IORef (IO ())
r
case Either e a
res of
Left e
ex -> do
IO ()
rollback_m
forall a. IORef a -> a -> IO ()
writeIORef IORef (IO ())
r IO ()
old_rollback
forall a. STM a -> IORef (IO ()) -> IO a
unSTM (e -> STM a
h e
ex) IORef (IO ())
r
Right a
a -> do
forall a. IORef a -> a -> IO ()
writeIORef IORef (IO ())
r (IO ()
rollback_m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
old_rollback)
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
newtype TVar a = TVar (IORef a)
deriving (TVar a -> TVar a -> Bool
forall a. TVar a -> TVar a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TVar a -> TVar a -> Bool
$c/= :: forall a. TVar a -> TVar a -> Bool
== :: TVar a -> TVar a -> Bool
$c== :: forall a. TVar a -> TVar a -> Bool
Eq)
newTVar :: a -> STM (TVar a)
newTVar :: forall a. a -> STM (TVar a)
newTVar a
a = forall a. (IORef (IO ()) -> IO a) -> STM a
STM (forall a b. a -> b -> a
const (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
IORef a
ref <- forall a. a -> IO (IORef a)
newIORef a
a
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. IORef a -> TVar a
TVar IORef a
ref)
readTVar :: TVar a -> STM a
readTVar :: forall a. TVar a -> STM a
readTVar (TVar IORef a
ref) = forall a. (IORef (IO ()) -> IO a) -> STM a
STM (forall a b. a -> b -> a
const (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) = 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 = forall a. (IORef (IO ()) -> IO a) -> STM a
STM forall a b. (a -> b) -> a -> b
$ \ IORef (IO ())
r -> do
a
oldval <- forall a. IORef a -> IO a
readIORef IORef a
ref
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (IO ())
r (forall a. IORef a -> a -> IO ()
writeIORef IORef a
ref a
oldval forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>)
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ref a
a