TMVar.hs

-- |
-- 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 = newTMVarN ""

-- | 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 n a = do
  let n' = if null n then "ctmvar" else "ctmvar-" ++ n
  ctvar <- newTVarN n' $ Just a
  pure (TMVar ctvar)

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

-- | 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 n = do
  let n' = if null n then "ctmvar" else "ctmvar-" ++ n
  ctvar <- newTVarN n' Nothing
  pure (TMVar 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 ctmvar = do
  taken <- tryTakeTMVar ctmvar
  maybe retry pure 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 ctmvar a = do
  putted <- tryPutTMVar ctmvar a
  unless putted 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 ctmvar = do
  readed <- tryReadTMVar ctmvar
  maybe retry pure 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 (TMVar ctvar) = do
  val <- readTVar ctvar
  when (isJust val) $ writeTVar ctvar Nothing
  pure 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 (TMVar ctvar) a = do
  val <- readTVar ctvar
  when (isNothing val) $ writeTVar ctvar (Just a)
  pure (isNothing 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 (TMVar ctvar) = readTVar ctvar

-- | Check if a 'TMVar' is empty or not.
--
-- @since 1.0.0.0
isEmptyTMVar :: MonadSTM stm => TMVar stm a -> stm Bool
isEmptyTMVar ctmvar = isNothing <$> tryReadTMVar 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 ctmvar a = do
  val <- takeTMVar ctmvar
  putTMVar ctmvar a
  pure val