{-# LANGUAGE CPP
, NoImplicitPrelude
, FlexibleContexts
, TupleSections #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif
module Control.Concurrent.MVar.Lifted
( MVar.MVar
, newEmptyMVar
, newMVar
, takeMVar
, putMVar
, readMVar
, swapMVar
, tryTakeMVar
, tryPutMVar
, isEmptyMVar
, withMVar
, modifyMVar_
, modifyMVar
#if MIN_VERSION_base(4,6,0)
, modifyMVarMasked_
, modifyMVarMasked
#endif
#if MIN_VERSION_base(4,6,0)
, mkWeakMVar
#else
, addMVarFinalizer
#endif
#if MIN_VERSION_base(4,7,0)
, withMVarMasked
, tryReadMVar
#endif
) where
import Prelude ( (.) )
import Data.Bool ( Bool(False, True) )
import Data.Function ( ($) )
import Data.Functor ( fmap )
import Data.IORef ( newIORef, readIORef, writeIORef )
import Data.Maybe ( Maybe )
import Control.Monad ( return, when )
import System.IO ( IO )
import Control.Concurrent.MVar ( MVar )
import qualified Control.Concurrent.MVar as MVar
import Control.Exception ( onException
#if MIN_VERSION_base(4,3,0)
, mask, mask_
#else
, block, unblock
#endif
)
#if MIN_VERSION_base(4,6,0)
import System.Mem.Weak ( Weak )
#endif
#if __GLASGOW_HASKELL__ < 700
import Control.Monad ( (>>=), (>>), fail )
#endif
import Control.Monad.Base ( MonadBase, liftBase )
import Control.Monad.Trans.Control ( MonadBaseControl
, control
, liftBaseOp
, liftBaseDiscard
)
#include "inlinable.h"
newEmptyMVar :: MonadBase IO m => m (MVar a)
newEmptyMVar :: forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a. IO (MVar a)
MVar.newEmptyMVar
{-# INLINABLE newEmptyMVar #-}
newMVar :: MonadBase IO m => a -> m (MVar a)
newMVar :: forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO (MVar a)
MVar.newMVar
{-# INLINABLE newMVar #-}
takeMVar :: MonadBase IO m => MVar a -> m a
takeMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
takeMVar = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO a
MVar.takeMVar
{-# INLINABLE takeMVar #-}
putMVar :: MonadBase IO m => MVar a -> a -> m ()
putMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar a
mv a
x = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
{-# INLINABLE putMVar #-}
readMVar :: MonadBase IO m => MVar a -> m a
readMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO a
MVar.readMVar
{-# INLINABLE readMVar #-}
swapMVar :: MonadBase IO m => MVar a -> a -> m a
swapMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m a
swapMVar MVar a
mv a
x = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO a
MVar.swapMVar MVar a
mv a
x
{-# INLINABLE swapMVar #-}
tryTakeMVar :: MonadBase IO m => MVar a -> m (Maybe a)
tryTakeMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m (Maybe a)
tryTakeMVar = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO (Maybe a)
MVar.tryTakeMVar
{-# INLINABLE tryTakeMVar #-}
tryPutMVar :: MonadBase IO m => MVar a -> a -> m Bool
tryPutMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m Bool
tryPutMVar MVar a
mv a
x = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
MVar.tryPutMVar MVar a
mv a
x
{-# INLINABLE tryPutMVar #-}
isEmptyMVar :: MonadBase IO m => MVar a -> m Bool
isEmptyMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m Bool
isEmptyMVar = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO Bool
MVar.isEmptyMVar
{-# INLINABLE isEmptyMVar #-}
withMVar :: MonadBaseControl IO m => MVar a -> (a -> m b) -> m b
withMVar :: forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m b) -> m b
withMVar = forall (b :: * -> *) (m :: * -> *) a c d.
MonadBaseControl b m =>
((a -> b (StM m c)) -> b (StM m d)) -> (a -> m c) -> m d
liftBaseOp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. MVar a -> (a -> IO b) -> IO b
MVar.withMVar
{-# INLINABLE withMVar #-}
modifyMVar_ :: (MonadBaseControl IO m) => MVar a -> (a -> m a) -> m ()
modifyMVar_ :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar a
mv = forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar a
mv forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
{-# INLINABLE modifyMVar_ #-}
modifyMVar :: (MonadBaseControl IO m) => MVar a -> (a -> m (a, b)) -> m b
#if MIN_VERSION_base(4,3,0)
modifyMVar :: forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar a
mv a -> m (a, b)
f = forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO -> forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
IORef Bool
aborted <- forall a. a -> IO (IORef a)
newIORef Bool
True
let f' :: a -> m b
f' a
x = do
(a
x', b
a) <- a -> m (a, b)
f a
x
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
aborted Bool
False
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x'
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
a
x <- forall a. MVar a -> IO a
MVar.takeMVar MVar a
mv
StM m b
stM <- forall a. IO a -> IO a
restore (RunInBase m IO
runInIO (a -> m b
f' a
x)) forall a b. IO a -> IO b -> IO a
`onException` forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
Bool
abort <- forall a. IORef a -> IO a
readIORef IORef Bool
aborted
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
abort forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
forall (m :: * -> *) a. Monad m => a -> m a
return StM m b
stM
#else
modifyMVar mv f = control $ \runInIO -> block $ do
aborted <- newIORef True
let f' x = do
(x', a) <- f x
liftBase $ block $ do
writeIORef aborted False
MVar.putMVar mv x'
return a
x <- MVar.takeMVar mv
stM <- unblock (runInIO (f' x)) `onException` MVar.putMVar mv x
abort <- readIORef aborted
when abort $ MVar.putMVar mv x
return stM
#endif
{-# INLINABLE modifyMVar #-}
#if MIN_VERSION_base(4,6,0)
modifyMVarMasked_ :: (MonadBaseControl IO m) => MVar a -> (a -> m a) -> m ()
modifyMVarMasked_ :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
MVar a -> (a -> m a) -> m ()
modifyMVarMasked_ MVar a
mv = forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVarMasked MVar a
mv forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, ()) forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
{-# INLINABLE modifyMVarMasked_ #-}
modifyMVarMasked :: (MonadBaseControl IO m) => MVar a -> (a -> m (a, b)) -> m b
modifyMVarMasked :: forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVarMasked MVar a
mv a -> m (a, b)
f = forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO -> forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
IORef Bool
aborted <- forall a. a -> IO (IORef a)
newIORef Bool
True
let f' :: a -> m b
f' a
x = do
(a
x', b
a) <- a -> m (a, b)
f a
x
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ do
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
aborted Bool
False
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x'
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
a
x <- forall a. MVar a -> IO a
MVar.takeMVar MVar a
mv
StM m b
stM <- RunInBase m IO
runInIO (a -> m b
f' a
x) forall a b. IO a -> IO b -> IO a
`onException` forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
Bool
abort <- forall a. IORef a -> IO a
readIORef IORef Bool
aborted
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
abort forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
forall (m :: * -> *) a. Monad m => a -> m a
return StM m b
stM
{-# INLINABLE modifyMVarMasked #-}
#endif
#if MIN_VERSION_base(4,6,0)
mkWeakMVar :: MonadBaseControl IO m => MVar a -> m () -> m (Weak (MVar a))
mkWeakMVar :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
MVar a -> m () -> m (Weak (MVar a))
mkWeakMVar = forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(b () -> b a) -> m () -> m a
liftBaseDiscard forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO () -> IO (Weak (MVar a))
MVar.mkWeakMVar
{-# INLINABLE mkWeakMVar #-}
#else
addMVarFinalizer :: MonadBaseControl IO m => MVar a -> m () -> m ()
addMVarFinalizer = liftBaseDiscard . MVar.addMVarFinalizer
{-# INLINABLE addMVarFinalizer #-}
#endif
#if MIN_VERSION_base (4,7,0)
withMVarMasked :: MonadBaseControl IO m => MVar a -> (a -> m b) -> m b
withMVarMasked :: forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m b) -> m b
withMVarMasked = forall (b :: * -> *) (m :: * -> *) a c d.
MonadBaseControl b m =>
((a -> b (StM m c)) -> b (StM m d)) -> (a -> m c) -> m d
liftBaseOp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. MVar a -> (a -> IO b) -> IO b
MVar.withMVarMasked
tryReadMVar :: MonadBase IO m => MVar a -> m (Maybe a)
tryReadMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m (Maybe a)
tryReadMVar = forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO (Maybe a)
MVar.tryReadMVar
#endif