-- 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 a -> IORef (IO ()) -> IO a
unSTM (STM IORef (IO ()) -> IO a
f) = IORef (IO ()) -> IO a
f

instance Functor STM where
    fmap :: (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor IO
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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
External instance of the constraint type Applicative IO
pure
    STM IORef (IO ()) -> IO (a -> b)
mf <*> :: 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type Applicative IO
<*> IORef (IO ()) -> IO a
mx IORef (IO ())
r

instance Monad STM where
    return :: a -> STM a
return = a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
Instance of class: Applicative of the constraint type Applicative STM
pure
    STM IORef (IO ()) -> IO a
m >>= :: 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
        a
x <- IORef (IO ()) -> IO a
m IORef (IO ())
r
        STM b -> IORef (IO ()) -> IO b
forall a. STM a -> IORef (IO ()) -> IO a
unSTM (a -> STM b
k a
x) IORef (IO ())
r

atomically :: STM a -> IO a
atomically :: STM a -> IO a
atomically (STM IORef (IO ()) -> IO a
m) = do
    IORef (IO ())
r <- IO () -> IO (IORef (IO ()))
forall a. a -> IO (IORef a)
newIORef (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return ())
    IORef (IO ()) -> IO a
m IORef (IO ())
r IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` do
        IO ()
rollback <- IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef IORef (IO ())
r
        IO ()
rollback

-- | @since 2.2.0
throwSTM :: Exception e => e -> STM a
throwSTM :: 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. Exception e => e -> IO a
Evidence bound by a type signature of the constraint type Exception e
throwIO

catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a
catchSTM :: 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
    IO ()
old_rollback <- IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef IORef (IO ())
r
    IORef (IO ()) -> IO () -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IO ())
r (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return ())
    Either e a
res <- IO a -> IO (Either e a)
forall e a. Exception e => IO a -> IO (Either e a)
Evidence bound by a type signature of the constraint type Exception e
try (IORef (IO ()) -> IO a
m IORef (IO ())
r)
    IO ()
rollback_m <- IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef IORef (IO ())
r
    case Either e a
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
External instance of the constraint type Monad IO
>> IO ()
old_rollback)
            a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
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
/= :: 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
External instance of the constraint type forall a. Eq (IORef a)
Eq)

newTVar :: a -> STM (TVar a)
newTVar :: 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 :: a -> IO (TVar a)
newTVarIO a
a = do
    IORef a
ref <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
a
    TVar a -> IO (TVar a)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type Monad IO
return (IORef a -> TVar a
forall a. IORef a -> TVar a
TVar IORef a
ref)

readTVar :: TVar a -> STM a
readTVar :: 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))

-- | @since 2.1.2
readTVarIO :: TVar a -> IO a
readTVarIO :: 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 :: 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
    a
oldval <- IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref
    IORef (IO ()) -> (IO () -> IO ()) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (IO ())
r (IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ref a
oldval IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
External instance of the constraint type Monad IO
>>)
    IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ref a
a