{-# LANGUAGE CPP
, NoImplicitPrelude
, FlexibleContexts
, TupleSections #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Safe #-}
#endif
{- |
Module : Control.Concurrent.MVar.Lifted
Copyright : Bas van Dijk
License : BSD-style
Maintainer : Bas van Dijk <v.dijk.bas@gmail.com>
Stability : experimental
This is a wrapped version of "Control.Concurrent.MVar" with types generalized
from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'.
-}
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
--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------
-- from base:
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
-- from transformers-base:
import Control.Monad.Base ( MonadBase, liftBase )
-- from monad-control:
import Control.Monad.Trans.Control ( MonadBaseControl
, control
, liftBaseOp
, liftBaseDiscard
)
#include "inlinable.h"
--------------------------------------------------------------------------------
-- * MVars
--------------------------------------------------------------------------------
-- | Generalized version of 'MVar.newEmptyMVar'.
newEmptyMVar :: MonadBase IO m => m (MVar a)
newEmptyMVar = liftBase MVar.newEmptyMVar
{-# INLINABLE newEmptyMVar #-}
-- | Generalized version of 'MVar.newMVar'.
newMVar :: MonadBase IO m => a -> m (MVar a)
newMVar = liftBase . MVar.newMVar
{-# INLINABLE newMVar #-}
-- | Generalized version of 'MVar.takeMVar'.
takeMVar :: MonadBase IO m => MVar a -> m a
takeMVar = liftBase . MVar.takeMVar
{-# INLINABLE takeMVar #-}
-- | Generalized version of 'MVar.putMVar'.
putMVar :: MonadBase IO m => MVar a -> a -> m ()
putMVar mv x = liftBase $ MVar.putMVar mv x
{-# INLINABLE putMVar #-}
-- | Generalized version of 'MVar.readMVar'.
readMVar :: MonadBase IO m => MVar a -> m a
readMVar = liftBase . MVar.readMVar
{-# INLINABLE readMVar #-}
-- | Generalized version of 'MVar.swapMVar'.
swapMVar :: MonadBase IO m => MVar a -> a -> m a
swapMVar mv x = liftBase $ MVar.swapMVar mv x
{-# INLINABLE swapMVar #-}
-- | Generalized version of 'MVar.tryTakeMVar'.
tryTakeMVar :: MonadBase IO m => MVar a -> m (Maybe a)
tryTakeMVar = liftBase . MVar.tryTakeMVar
{-# INLINABLE tryTakeMVar #-}
-- | Generalized version of 'MVar.tryPutMVar'.
tryPutMVar :: MonadBase IO m => MVar a -> a -> m Bool
tryPutMVar mv x = liftBase $ MVar.tryPutMVar mv x
{-# INLINABLE tryPutMVar #-}
-- | Generalized version of 'MVar.isEmptyMVar'.
isEmptyMVar :: MonadBase IO m => MVar a -> m Bool
isEmptyMVar = liftBase . MVar.isEmptyMVar
{-# INLINABLE isEmptyMVar #-}
-- | Generalized version of 'MVar.withMVar'.
withMVar :: MonadBaseControl IO m => MVar a -> (a -> m b) -> m b
withMVar = liftBaseOp . MVar.withMVar
{-# INLINABLE withMVar #-}
-- | Generalized version of 'MVar.modifyMVar_'.
modifyMVar_ :: (MonadBaseControl IO m) => MVar a -> (a -> m a) -> m ()
modifyMVar_ mv = modifyMVar mv . (fmap (, ()) .)
{-# INLINABLE modifyMVar_ #-}
-- | Generalized version of 'MVar.modifyMVar'.
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
{-# INLINABLE modifyMVar #-}
#if MIN_VERSION_base(4,6,0)
-- | Generalized version of 'MVar.modifyMVarMasked_'.
modifyMVarMasked_ :: (MonadBaseControl IO m) => MVar a -> (a -> m a) -> m ()
modifyMVarMasked_ mv = modifyMVarMasked mv . (fmap (, ()) .)
{-# INLINABLE modifyMVarMasked_ #-}
-- | Generalized version of 'MVar.modifyMVarMasked'.
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
{-# INLINABLE modifyMVarMasked #-}
#endif
#if MIN_VERSION_base(4,6,0)
-- | Generalized version of 'MVar.mkWeakMVar'.
--
-- Note any monadic side effects in @m@ of the \"finalizer\" computation are
-- discarded.
mkWeakMVar :: MonadBaseControl IO m => MVar a -> m () -> m (Weak (MVar a))
mkWeakMVar = liftBaseDiscard . MVar.mkWeakMVar
{-# INLINABLE mkWeakMVar #-}
#else
-- | Generalized version of 'MVar.addMVarFinalizer'.
--
-- Note any monadic side effects in @m@ of the \"finalizer\" computation are
-- discarded.
addMVarFinalizer :: MonadBaseControl IO m => MVar a -> m () -> m ()
addMVarFinalizer = liftBaseDiscard . MVar.addMVarFinalizer
{-# INLINABLE addMVarFinalizer #-}
#endif
#if MIN_VERSION_base (4,7,0)
-- | Generalized version of 'MVar.withMVarMasked'.
withMVarMasked :: MonadBaseControl IO m => MVar a -> (a -> m b) -> m b
withMVarMasked = liftBaseOp . MVar.withMVarMasked
-- | Generalized version of 'MVar.tryReadMVar'.
tryReadMVar :: MonadBase IO m => MVar a -> m (Maybe a)
tryReadMVar = liftBase . MVar.tryReadMVar
#endif