#if __GLASGOW_HASKELL__ >= 702
#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
) where
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 Data.Function.Unicode ( (∘) )
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 = liftBase MVar.newEmptyMVar
newMVar ∷ MonadBase IO m ⇒ a → m (MVar a)
newMVar = liftBase ∘ MVar.newMVar
takeMVar ∷ MonadBase IO m ⇒ MVar a → m a
takeMVar = liftBase ∘ MVar.takeMVar
putMVar ∷ MonadBase IO m ⇒ MVar a → a → m ()
putMVar mv x = liftBase $ MVar.putMVar mv x
readMVar ∷ MonadBase IO m ⇒ MVar a → m a
readMVar = liftBase ∘ MVar.readMVar
swapMVar ∷ MonadBase IO m ⇒ MVar a → a → m a
swapMVar mv x = liftBase $ MVar.swapMVar mv x
tryTakeMVar ∷ MonadBase IO m ⇒ MVar a → m (Maybe a)
tryTakeMVar = liftBase ∘ MVar.tryTakeMVar
tryPutMVar ∷ MonadBase IO m ⇒ MVar a → a → m Bool
tryPutMVar mv x = liftBase $ MVar.tryPutMVar mv x
isEmptyMVar ∷ MonadBase IO m ⇒ MVar a → m Bool
isEmptyMVar = liftBase ∘ MVar.isEmptyMVar
withMVar ∷ MonadBaseControl IO m ⇒ MVar a → (a → m b) → m b
withMVar = liftBaseOp ∘ MVar.withMVar
modifyMVar_ ∷ (MonadBaseControl IO m) ⇒ MVar a → (a → m a) → m ()
modifyMVar_ mv = modifyMVar mv ∘ (fmap (, ()) ∘)
modifyMVar ∷ (MonadBaseControl IO m) ⇒ MVar a → (a → m (a, b)) → m b
#if MIN_VERSION_base(4,3,0)
modifyMVar mv f = control $ \runInIO → mask $ \restore → do
aborted ← newIORef True
let f' x = do
(x', a) ← f x
liftBase $ mask_ $ do
writeIORef aborted False
MVar.putMVar mv x'
return a
x ← MVar.takeMVar mv
stM ← restore (runInIO (f' x)) `onException` MVar.putMVar mv x
abort ← readIORef aborted
when abort $ MVar.putMVar mv x
return 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
#if MIN_VERSION_base(4,6,0)
modifyMVarMasked_ ∷ (MonadBaseControl IO m) ⇒ MVar a → (a → m a) → m ()
modifyMVarMasked_ mv = modifyMVarMasked mv ∘ (fmap (, ()) ∘)
modifyMVarMasked ∷ (MonadBaseControl IO m) ⇒ MVar a → (a → m (a, b)) → m b
modifyMVarMasked mv f = control $ \runInIO → mask_ $ do
aborted ← newIORef True
let f' x = do
(x', a) ← f x
liftBase $ do
writeIORef aborted False
MVar.putMVar mv x'
return a
x ← MVar.takeMVar mv
stM ← runInIO (f' x) `onException` MVar.putMVar mv x
abort ← readIORef aborted
when abort $ MVar.putMVar mv x
return stM
#endif
#if MIN_VERSION_base(4,6,0)
mkWeakMVar ∷ MonadBaseControl IO m ⇒ MVar a → m () → m (Weak (MVar a))
mkWeakMVar = liftBaseDiscard ∘ MVar.mkWeakMVar
#else
addMVarFinalizer ∷ MonadBaseControl IO m ⇒ MVar a → m () → m ()
addMVarFinalizer = liftBaseDiscard ∘ MVar.addMVarFinalizer
#endif