-- |
-- 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 = String -> a -> stm (TMVar stm a)
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 String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n then String
"ctmvar" else String
"ctmvar-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n
  TVar stm (Maybe a)
ctvar <- String -> Maybe a -> stm (TVar stm (Maybe a))
forall a. String -> a -> stm (TVar stm a)
forall (stm :: * -> *) a.
MonadSTM stm =>
String -> a -> stm (TVar stm a)
newTVarN String
n' (Maybe a -> stm (TVar stm (Maybe a)))
-> Maybe a -> stm (TVar stm (Maybe a))
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
  TMVar stm a -> stm (TMVar stm a)
forall a. a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar stm (Maybe a) -> TMVar stm a
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 = String -> stm (TMVar stm a)
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 String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n then String
"ctmvar" else String
"ctmvar-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n
  TVar stm (Maybe a)
ctvar <- String -> Maybe a -> stm (TVar stm (Maybe a))
forall a. String -> a -> stm (TVar stm a)
forall (stm :: * -> *) a.
MonadSTM stm =>
String -> a -> stm (TVar stm a)
newTVarN String
n' Maybe a
forall a. Maybe a
Nothing
  TMVar stm a -> stm (TMVar stm a)
forall a. a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar stm (Maybe a) -> TMVar stm a
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 <- TMVar stm a -> stm (Maybe a)
forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> stm (Maybe a)
tryTakeTMVar TMVar stm a
ctmvar
  stm a -> (a -> stm a) -> Maybe a -> stm a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe stm a
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry a -> stm a
forall a. a -> stm a
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 <- TMVar stm a -> a -> stm Bool
forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm Bool
tryPutTMVar TMVar stm a
ctmvar a
a
  Bool -> stm () -> stm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
putted stm ()
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 <- TMVar stm a -> stm (Maybe a)
forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> stm (Maybe a)
tryReadTMVar TMVar stm a
ctmvar
  stm a -> (a -> stm a) -> Maybe a -> stm a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe stm a
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry a -> stm a
forall a. a -> stm a
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 <- TVar stm (Maybe a) -> stm (Maybe a)
forall a. TVar stm a -> stm a
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (Maybe a)
ctvar
  Bool -> stm () -> stm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
val) (stm () -> stm ()) -> stm () -> stm ()
forall a b. (a -> b) -> a -> b
$ TVar stm (Maybe a) -> Maybe a -> stm ()
forall a. TVar stm a -> a -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm (Maybe a)
ctvar Maybe a
forall a. Maybe a
Nothing
  Maybe a -> stm (Maybe a)
forall a. a -> stm a
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 <- TVar stm (Maybe a) -> stm (Maybe a)
forall a. TVar stm a -> stm a
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (Maybe a)
ctvar
  Bool -> stm () -> stm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
val) (stm () -> stm ()) -> stm () -> stm ()
forall a b. (a -> b) -> a -> b
$ TVar stm (Maybe a) -> Maybe a -> stm ()
forall a. TVar stm a -> a -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm (Maybe a)
ctvar (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
  Bool -> stm Bool
forall a. a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Bool
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) = TVar stm (Maybe a) -> stm (Maybe a)
forall a. TVar stm a -> stm a
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 = Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe a -> Bool) -> stm (Maybe a) -> stm Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar stm a -> stm (Maybe a)
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 <- TMVar stm a -> stm a
forall (stm :: * -> *) a. MonadSTM stm => TMVar stm a -> stm a
takeTMVar TMVar stm a
ctmvar
  TMVar stm a -> a -> stm ()
forall (stm :: * -> *) a.
MonadSTM stm =>
TMVar stm a -> a -> stm ()
putTMVar TMVar stm a
ctmvar a
a
  a -> stm a
forall a. a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val