-- |
-- Module      : Control.Concurrent.Classy.STM.TMVar
-- Copyright   : (c) 2016 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : stable
-- Portability : portable
--
-- Transactional @MVar@s, for use with 'MonadSTM'.
--
-- __Deviations:__ @TMVar@ as defined here does not have an @Eq@
-- instance, this is because the @MonadSTM@ @TVar@ type does not have
-- an @Eq@ constraint. Furthermore, the @newTMVarIO@,
-- @newEmptyTMVarIO@, and @mkWeakTMVar@ functions are not provided.
module Control.Concurrent.Classy.STM.TMVar
  ( -- * @TMVar@s
    TMVar
  , newTMVar
  , newTMVarN
  , newEmptyTMVar
  , newEmptyTMVarN
  , takeTMVar
  , putTMVar
  , readTMVar
  , tryTakeTMVar
  , tryPutTMVar
  , tryReadTMVar
  , isEmptyTMVar
  , swapTMVar
  ) where

import           Control.Monad           (unless, when)
import           Control.Monad.STM.Class
import           Data.Maybe              (isJust, isNothing)

-- | A @TMVar@ is like an @MVar@ or a @mVar@, but using transactional
-- memory. As transactions are atomic, this makes dealing with
-- multiple @TMVar@s easier than wrangling multiple @mVar@s.
--
-- @since 1.0.0.0
newtype TMVar stm a = TMVar (TVar stm (Maybe a))

-- | Create a 'TMVar' containing the given value.
--
-- @since 1.0.0.0
newTMVar :: MonadSTM stm => a -> stm (TMVar stm a)
newTMVar :: forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TMVar stm a)
newTMVar = forall (stm :: * -> *) a.
MonadSTM stm =>
String -> a -> stm (TMVar stm a)
newTMVarN String
""

-- | Create a 'TMVar' containing the given value, with the given
-- name.
--
-- Name conflicts are handled as usual for 'TVar's. The name is
-- prefixed with \"ctmvar-\".
--
-- @since 1.0.0.0
newTMVarN :: MonadSTM stm => String -> a -> stm (TMVar stm a)
newTMVarN :: forall (stm :: * -> *) a.
MonadSTM stm =>
String -> a -> stm (TMVar stm a)
newTMVarN String
n a
a = do
  let n' :: String
n' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n then String
"ctmvar" else String
"ctmvar-" forall a. [a] -> [a] -> [a]
++ String
n
  TVar stm (Maybe a)
ctvar <- forall (stm :: * -> *) a.
MonadSTM stm =>
String -> a -> stm (TVar stm a)
newTVarN String
n' forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
a
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stm :: * -> *) a. TVar stm (Maybe a) -> TMVar stm a
TMVar TVar stm (Maybe a)
ctvar)

-- | Create a new empty 'TMVar'.
--
-- @since 1.0.0.0
newEmptyTMVar :: MonadSTM stm => stm (TMVar stm a)
newEmptyTMVar :: forall (stm :: * -> *) a. MonadSTM stm => stm (TMVar stm a)
newEmptyTMVar = forall (stm :: * -> *) a.
MonadSTM stm =>
String -> stm (TMVar stm a)
newEmptyTMVarN String
""

-- | Create a new empty 'TMVar' with the given name.
--
-- Name conflicts are handled as usual for 'TVar's. The name is
-- prefixed with \"ctmvar-\".
--
-- @since 1.0.0.0
newEmptyTMVarN :: MonadSTM stm => String -> stm (TMVar stm a)
newEmptyTMVarN :: forall (stm :: * -> *) a.
MonadSTM stm =>
String -> stm (TMVar stm a)
newEmptyTMVarN String
n = do
  let n' :: String
n' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n then String
"ctmvar" else String
"ctmvar-" forall a. [a] -> [a] -> [a]
++ String
n
  TVar stm (Maybe a)
ctvar <- forall (stm :: * -> *) a.
MonadSTM stm =>
String -> a -> stm (TVar stm a)
newTVarN String
n' forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stm :: * -> *) a. TVar stm (Maybe a) -> TMVar stm a
TMVar TVar stm (Maybe a)
ctvar)

-- | Take the contents of a 'TMVar', or 'retry' if it is empty.
--
-- @since 1.0.0.0
takeTMVar :: MonadSTM stm => TMVar stm a -> stm a
takeTMVar :: forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> stm a
takeTMVar TMVar stm a
ctmvar = do
  Maybe a
taken <- forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> stm (Maybe a)
tryTakeTMVar TMVar stm a
ctmvar
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (stm :: * -> *) a. MonadSTM stm => stm a
retry forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
taken

-- | Write to a 'TMVar', or 'retry' if it is full.
--
-- @since 1.0.0.0
putTMVar :: MonadSTM stm => TMVar stm a -> a -> stm ()
putTMVar :: forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar stm a
ctmvar a
a = do
  Bool
putted <- forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm Bool
tryPutTMVar TMVar stm a
ctmvar a
a
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
putted forall (stm :: * -> *) a. MonadSTM stm => stm a
retry

-- | Read from a 'TMVar' without emptying, or 'retry' if it is empty.
--
-- @since 1.0.0.0
readTMVar :: MonadSTM stm => TMVar stm a -> stm a
readTMVar :: forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> stm a
readTMVar TMVar stm a
ctmvar = do
  Maybe a
readed <- forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> stm (Maybe a)
tryReadTMVar TMVar stm a
ctmvar
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (stm :: * -> *) a. MonadSTM stm => stm a
retry forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
readed

-- | Try to take the contents of a 'TMVar', returning 'Nothing' if it
-- is empty.
--
-- @since 1.0.0.0
tryTakeTMVar :: MonadSTM stm => TMVar stm a -> stm (Maybe a)
tryTakeTMVar :: forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> stm (Maybe a)
tryTakeTMVar (TMVar TVar stm (Maybe a)
ctvar) = do
  Maybe a
val <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (Maybe a)
ctvar
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe a
val) forall a b. (a -> b) -> a -> b
$ forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm (Maybe a)
ctvar forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
val

-- | Try to write to a 'TMVar', returning 'False' if it is full.
--
-- @since 1.0.0.0
tryPutTMVar :: MonadSTM stm => TMVar stm a -> a -> stm Bool
tryPutTMVar :: forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm Bool
tryPutTMVar (TMVar TVar stm (Maybe a)
ctvar) a
a = do
  Maybe a
val <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (Maybe a)
ctvar
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe a
val) forall a b. (a -> b) -> a -> b
$ forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm (Maybe a)
ctvar (forall a. a -> Maybe a
Just a
a)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a -> Bool
isNothing Maybe a
val)

-- | Try to read from a 'TMVar' without emptying, returning 'Nothing'
-- if it is empty.
--
-- @since 1.0.0.0
tryReadTMVar :: MonadSTM stm => TMVar stm a -> stm (Maybe a)
tryReadTMVar :: forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> stm (Maybe a)
tryReadTMVar (TMVar TVar stm (Maybe a)
ctvar) = forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (Maybe a)
ctvar

-- | Check if a 'TMVar' is empty or not.
--
-- @since 1.0.0.0
isEmptyTMVar :: MonadSTM stm => TMVar stm a -> stm Bool
isEmptyTMVar :: forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> stm Bool
isEmptyTMVar TMVar stm a
ctmvar = forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> stm (Maybe a)
tryReadTMVar TMVar stm a
ctmvar

-- | Swap the contents of a 'TMVar' returning the old contents, or
-- 'retry' if it is empty.
--
-- @since 1.0.0.0
swapTMVar :: MonadSTM stm => TMVar stm a -> a -> stm a
swapTMVar :: forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> a -> stm a
swapTMVar TMVar stm a
ctmvar a
a = do
  a
val <- forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> stm a
takeTMVar TMVar stm a
ctmvar
  forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar stm a
ctmvar a
a
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val