{-# 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 :: forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar = IO (MVar a) -> m (MVar a)
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO (MVar a)
forall a. IO (MVar a)
MVar.newEmptyMVar
{-# INLINABLE newEmptyMVar #-}

-- | Generalized version of 'MVar.newMVar'.
newMVar :: MonadBase IO m => a -> m (MVar a)
newMVar :: forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar = IO (MVar a) -> m (MVar a)
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (MVar a) -> m (MVar a))
-> (a -> IO (MVar a)) -> a -> m (MVar a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO (MVar a)
forall a. a -> IO (MVar a)
MVar.newMVar
{-# INLINABLE newMVar #-}

-- | Generalized version of 'MVar.takeMVar'.
takeMVar :: MonadBase IO m => MVar a -> m a
takeMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
takeMVar = IO a -> m a
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO a -> m a) -> (MVar a -> IO a) -> MVar a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> IO a
forall a. MVar a -> IO a
MVar.takeMVar
{-# INLINABLE takeMVar #-}

-- | Generalized version of 'MVar.putMVar'.
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 = IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
{-# INLINABLE putMVar #-}

-- | Generalized version of 'MVar.readMVar'.
readMVar :: MonadBase IO m => MVar a -> m a
readMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar = IO a -> m a
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO a -> m a) -> (MVar a -> IO a) -> MVar a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> IO a
forall a. MVar a -> IO a
MVar.readMVar
{-# INLINABLE readMVar #-}

-- | Generalized version of 'MVar.swapMVar'.
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 = IO a -> m a
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO a
forall a. MVar a -> a -> IO a
MVar.swapMVar MVar a
mv a
x
{-# INLINABLE swapMVar #-}

-- | Generalized version of 'MVar.tryTakeMVar'.
tryTakeMVar :: MonadBase IO m => MVar a -> m (Maybe a)
tryTakeMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m (Maybe a)
tryTakeMVar = IO (Maybe a) -> m (Maybe a)
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Maybe a) -> m (Maybe a))
-> (MVar a -> IO (Maybe a)) -> MVar a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> IO (Maybe a)
forall a. MVar a -> IO (Maybe a)
MVar.tryTakeMVar
{-# INLINABLE tryTakeMVar #-}

-- | Generalized version of 'MVar.tryPutMVar'.
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 = IO Bool -> m Bool
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO Bool
forall a. MVar a -> a -> IO Bool
MVar.tryPutMVar MVar a
mv a
x
{-# INLINABLE tryPutMVar #-}

-- | Generalized version of 'MVar.isEmptyMVar'.
isEmptyMVar :: MonadBase IO m => MVar a -> m Bool
isEmptyMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m Bool
isEmptyMVar = IO Bool -> m Bool
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO Bool -> m Bool) -> (MVar a -> IO Bool) -> MVar a -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> IO Bool
forall a. MVar a -> IO Bool
MVar.isEmptyMVar
{-# INLINABLE isEmptyMVar #-}

-- | Generalized version of 'MVar.withMVar'.
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 = ((a -> IO (StM m b)) -> IO (StM m b)) -> (a -> m b) -> m b
forall (b :: * -> *) (m :: * -> *) a c d.
MonadBaseControl b m =>
((a -> b (StM m c)) -> b (StM m d)) -> (a -> m c) -> m d
liftBaseOp (((a -> IO (StM m b)) -> IO (StM m b)) -> (a -> m b) -> m b)
-> (MVar a -> (a -> IO (StM m b)) -> IO (StM m b))
-> MVar a
-> (a -> m b)
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> (a -> IO (StM m b)) -> IO (StM m b)
forall a b. MVar a -> (a -> IO b) -> IO b
MVar.withMVar
{-# INLINABLE withMVar #-}

-- | Generalized version of 'MVar.modifyMVar_'.
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 = MVar a -> (a -> m (a, ())) -> m ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar a
mv ((a -> m (a, ())) -> m ())
-> ((a -> m a) -> a -> m (a, ())) -> (a -> m a) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> (a, ())) -> m a -> m (a, ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, ()) (m a -> m (a, ())) -> (a -> m a) -> a -> m (a, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
{-# 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 :: forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar a
mv a -> m (a, b)
f = (RunInBase m IO -> IO (StM m b)) -> m b
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m IO -> IO (StM m b)) -> m b)
-> (RunInBase m IO -> IO (StM m b)) -> m b
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO -> ((forall a. IO a -> IO a) -> IO (StM m b)) -> IO (StM m b)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (StM m b)) -> IO (StM m b))
-> ((forall a. IO a -> IO a) -> IO (StM m b)) -> IO (StM m b)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    IORef Bool
aborted <- Bool -> IO (IORef Bool)
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
        IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
aborted Bool
False
          MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x'
        b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
    a
x <- MVar a -> IO a
forall a. MVar a -> IO a
MVar.takeMVar MVar a
mv
    StM m b
stM <- IO (StM m b) -> IO (StM m b)
forall a. IO a -> IO a
restore (m b -> IO (StM m b)
RunInBase m IO
runInIO (a -> m b
f' a
x)) IO (StM m b) -> IO () -> IO (StM m b)
forall a b. IO a -> IO b -> IO a
`onException` MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
    Bool
abort <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
aborted
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
abort (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
    StM m b -> IO (StM m b)
forall a. a -> IO a
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)
-- | Generalized version of 'MVar.modifyMVarMasked_'.
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 = MVar a -> (a -> m (a, ())) -> m ()
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVarMasked MVar a
mv ((a -> m (a, ())) -> m ())
-> ((a -> m a) -> a -> m (a, ())) -> (a -> m a) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> (a, ())) -> m a -> m (a, ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, ()) (m a -> m (a, ())) -> (a -> m a) -> a -> m (a, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
{-# INLINABLE modifyMVarMasked_ #-}

-- | Generalized version of 'MVar.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 = (RunInBase m IO -> IO (StM m b)) -> m b
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m IO -> IO (StM m b)) -> m b)
-> (RunInBase m IO -> IO (StM m b)) -> m b
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO -> IO (StM m b) -> IO (StM m b)
forall a. IO a -> IO a
mask_ (IO (StM m b) -> IO (StM m b)) -> IO (StM m b) -> IO (StM m b)
forall a b. (a -> b) -> a -> b
$ do
    IORef Bool
aborted <- Bool -> IO (IORef Bool)
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
        IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
aborted Bool
False
          MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x'
        b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
    a
x <- MVar a -> IO a
forall a. MVar a -> IO a
MVar.takeMVar MVar a
mv
    StM m b
stM <- m b -> IO (StM m b)
RunInBase m IO
runInIO (a -> m b
f' a
x) IO (StM m b) -> IO () -> IO (StM m b)
forall a b. IO a -> IO b -> IO a
`onException` MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
    Bool
abort <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
aborted
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
abort (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
MVar.putMVar MVar a
mv a
x
    StM m b -> IO (StM m b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return StM m b
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 :: forall (m :: * -> *) a.
MonadBaseControl IO m =>
MVar a -> m () -> m (Weak (MVar a))
mkWeakMVar = (IO () -> IO (Weak (MVar a))) -> m () -> m (Weak (MVar a))
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(b () -> b a) -> m () -> m a
liftBaseDiscard ((IO () -> IO (Weak (MVar a))) -> m () -> m (Weak (MVar a)))
-> (MVar a -> IO () -> IO (Weak (MVar a)))
-> MVar a
-> m ()
-> m (Weak (MVar a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> IO () -> IO (Weak (MVar a))
forall a. MVar a -> IO () -> IO (Weak (MVar a))
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 :: forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m b) -> m b
withMVarMasked = ((a -> IO (StM m b)) -> IO (StM m b)) -> (a -> m b) -> m b
forall (b :: * -> *) (m :: * -> *) a c d.
MonadBaseControl b m =>
((a -> b (StM m c)) -> b (StM m d)) -> (a -> m c) -> m d
liftBaseOp (((a -> IO (StM m b)) -> IO (StM m b)) -> (a -> m b) -> m b)
-> (MVar a -> (a -> IO (StM m b)) -> IO (StM m b))
-> MVar a
-> (a -> m b)
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> (a -> IO (StM m b)) -> IO (StM m b)
forall a b. MVar a -> (a -> IO b) -> IO b
MVar.withMVarMasked

-- | Generalized version of 'MVar.tryReadMVar'.
tryReadMVar :: MonadBase IO m => MVar a -> m (Maybe a)
tryReadMVar :: forall (m :: * -> *) a. MonadBase IO m => MVar a -> m (Maybe a)
tryReadMVar = IO (Maybe a) -> m (Maybe a)
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (Maybe a) -> m (Maybe a))
-> (MVar a -> IO (Maybe a)) -> MVar a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> IO (Maybe a)
forall a. MVar a -> IO (Maybe a)
MVar.tryReadMVar
#endif