-- |
-- Module      : Control.Concurrent.Classy.MVar
-- Copyright   : (c) 2016 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : stable
-- Portability : portable
--
-- An @'MVar' t@ is mutable location that is either empty or contains
-- a value of type @t@.  It has two fundamental operations: 'putMVar'
-- which fills an 'MVar' if it is empty and blocks otherwise, and
-- 'takeMVar' which empties an 'MVar' if it is full and blocks
-- otherwise.  They can be used in multiple different ways:
--
--   1. As synchronized mutable variables,
--
--   2. As channels, with 'takeMVar' and 'putMVar' as receive and
--      send, and
--
--   3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and
--      'putMVar' as wait and signal.
--
-- __Deviations:__ There is no @Eq@ instance for @MonadConc@ the
-- @MVar@ type. Furthermore, the @mkWeakMVar@ and @addMVarFinalizer@
-- functions are not provided. Finally, normal @MVar@s have a fairness
-- guarantee, which dejafu does not currently make use of when
-- generating schedules to test, so your program may be tested with
-- /unfair/ schedules.
module Control.Concurrent.Classy.MVar
 ( -- *@MVar@s
  MVar
 , newEmptyMVar
 , newEmptyMVarN
 , newMVar
 , newMVarN
 , takeMVar
 , putMVar
 , readMVar
 , swapMVar
 , tryTakeMVar
 , tryPutMVar
 , isEmptyMVar
 , withMVar
 , withMVarMasked
 , modifyMVar_
 , modifyMVar
 , modifyMVarMasked_
 , modifyMVarMasked
 ) where

import           Control.Monad.Catch      (onException)
import           Control.Monad.Conc.Class
import           Data.Maybe               (isJust)

-- | Swap the contents of a @MVar@, and return the value taken. This
-- function is atomic only if there are no other producers fro this
-- @MVar@.
--
-- @since 1.0.0.0
swapMVar :: MonadConc m => MVar m a -> a -> m a
swapMVar :: forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m a
swapMVar MVar m a
cvar a
a = forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
  a
old <- forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
takeMVar MVar m a
cvar
  forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m a
cvar a
a
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
old

-- | Check if a @MVar@ is empty.
--
-- The boolean value returned is just a snapshot of the state of the
-- @MVar@, it may have been emptied (or filled) by the time you
-- actually access it. Generally prefer 'tryPutMVar', 'tryTakeMVar',
-- and 'tryReadMVar'.
--
-- @since 1.0.0.0
isEmptyMVar :: MonadConc m => MVar m a -> m Bool
isEmptyMVar :: forall (m :: * -> *) a. MonadConc m => MVar m a -> m Bool
isEmptyMVar = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadConc m => MVar m a -> m (Maybe a)
tryReadMVar

-- | Operate on the contents of a @MVar@, replacing the contents after
-- finishing. This operation is exception-safe: it will replace the
-- original contents of the @MVar@ if an exception is raised. However,
-- it is only atomic if there are no other producers for this @MVar@.
--
-- @since 1.0.0.0
{-# INLINE withMVar #-}
withMVar :: MonadConc m => MVar m a -> (a -> m b) -> m b
withMVar :: forall (m :: * -> *) a b.
MonadConc m =>
MVar m a -> (a -> m b) -> m b
withMVar MVar m a
cvar a -> m b
f = forall (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
  a
val <- forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
takeMVar MVar m a
cvar
  b
out <- forall a. m a -> m a
restore (a -> m b
f a
val) forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m a
cvar a
val
  forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m a
cvar a
val

  forall (f :: * -> *) a. Applicative f => a -> f a
pure b
out

-- | Like 'withMVar', but the @IO@ action in the second argument is
-- executed with asynchronous exceptions masked.
--
-- @since 1.0.0.0
{-# INLINE withMVarMasked #-}
withMVarMasked :: MonadConc m => MVar m a -> (a -> m b) -> m b
withMVarMasked :: forall (m :: * -> *) a b.
MonadConc m =>
MVar m a -> (a -> m b) -> m b
withMVarMasked MVar m a
cvar a -> m b
f = forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
  a
val <- forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
takeMVar MVar m a
cvar
  b
out <- a -> m b
f a
val forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m a
cvar a
val
  forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m a
cvar a
val

  forall (f :: * -> *) a. Applicative f => a -> f a
pure b
out

-- | An exception-safe wrapper for modifying the contents of a @MVar@.
-- Like 'withMVar', 'modifyMVar' will replace the original contents of
-- the @MVar@ if an exception is raised during the operation. This
-- function is only atomic if there are no other producers for this
-- @MVar@.
--
-- @since 1.0.0.0
{-# INLINE modifyMVar_ #-}
modifyMVar_ :: MonadConc m => MVar m a -> (a -> m a) -> m ()
modifyMVar_ :: forall (m :: * -> *) a.
MonadConc m =>
MVar m a -> (a -> m a) -> m ()
modifyMVar_ MVar m a
cvar a -> m a
f = forall (m :: * -> *) a b.
MonadConc m =>
MVar m a -> (a -> m (a, b)) -> m b
modifyMVar MVar m a
cvar forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
a -> (a
a,())) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
f

-- | A slight variation on 'modifyMVar_' that allows a value to be
-- returned (@b@) in addition to the modified value of the @MVar@.
--
-- @since 1.0.0.0
{-# INLINE modifyMVar #-}
modifyMVar :: MonadConc m => MVar m a -> (a -> m (a, b)) -> m b
modifyMVar :: forall (m :: * -> *) a b.
MonadConc m =>
MVar m a -> (a -> m (a, b)) -> m b
modifyMVar MVar m a
cvar a -> m (a, b)
f = forall (m :: * -> *) b.
MonadConc m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
  a
val <- forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
takeMVar MVar m a
cvar
  (a
val', b
out) <- forall a. m a -> m a
restore (a -> m (a, b)
f a
val) forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m a
cvar a
val
  forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m a
cvar a
val'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure b
out

-- | Like 'modifyMVar_', but the @IO@ action in the second argument is
-- executed with asynchronous exceptions masked.
--
-- @since 1.0.0.0
{-# INLINE modifyMVarMasked_ #-}
modifyMVarMasked_ :: MonadConc m => MVar m a -> (a -> m a) -> m ()
modifyMVarMasked_ :: forall (m :: * -> *) a.
MonadConc m =>
MVar m a -> (a -> m a) -> m ()
modifyMVarMasked_ MVar m a
cvar a -> m a
f = forall (m :: * -> *) a b.
MonadConc m =>
MVar m a -> (a -> m (a, b)) -> m b
modifyMVarMasked MVar m a
cvar forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
a -> (a
a,())) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
f

-- | Like 'modifyMVar', but the @IO@ action in the second argument is
-- executed with asynchronous exceptions masked.
--
-- @since 1.0.0.0
{-# INLINE modifyMVarMasked #-}
modifyMVarMasked :: MonadConc m => MVar m a -> (a -> m (a, b)) -> m b
modifyMVarMasked :: forall (m :: * -> *) a b.
MonadConc m =>
MVar m a -> (a -> m (a, b)) -> m b
modifyMVarMasked MVar m a
cvar a -> m (a, b)
f = forall (m :: * -> *) a. MonadMask m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ do
  a
val <- forall (m :: * -> *) a. MonadConc m => MVar m a -> m a
takeMVar MVar m a
cvar
  (a
val', b
out) <- a -> m (a, b)
f a
val forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m a
cvar a
val
  forall (m :: * -> *) a. MonadConc m => MVar m a -> a -> m ()
putMVar MVar m a
cvar a
val'
  forall (f :: * -> *) a. Applicative f => a -> f a
pure b
out