{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.STM.TMVar
-- Copyright   :  (c) The University of Glasgow 2004
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (requires STM)
--
-- TMVar: Transactional MVars, for use in the STM monad
-- (GHC only)
--
-----------------------------------------------------------------------------

module Control.Concurrent.STM.TMVar (
#ifdef __GLASGOW_HASKELL__
        -- * TMVars
        TMVar,
        newTMVar,
        newEmptyTMVar,
        newTMVarIO,
        newEmptyTMVarIO,
        takeTMVar,
        putTMVar,
        readTMVar,
        tryReadTMVar,
        swapTMVar,
        tryTakeTMVar,
        tryPutTMVar,
        isEmptyTMVar,
        mkWeakTMVar
#endif
  ) where

#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.Conc
import GHC.Weak

import Data.Typeable (Typeable)

newtype TMVar a = TMVar (TVar (Maybe a)) deriving (TMVar a -> TMVar a -> Bool
(TMVar a -> TMVar a -> Bool)
-> (TMVar a -> TMVar a -> Bool) -> Eq (TMVar a)
forall a. TMVar a -> TMVar a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TMVar a -> TMVar a -> Bool
$c/= :: forall a. TMVar a -> TMVar a -> Bool
== :: TMVar a -> TMVar a -> Bool
$c== :: forall a. TMVar a -> TMVar a -> Bool
Eq, Typeable)
{- ^
A 'TMVar' is a synchronising variable, used
for communication between concurrent threads.  It can be thought of
as a box, which may be empty or full.
-}

-- |Create a 'TMVar' which contains the supplied value.
newTMVar :: a -> STM (TMVar a)
newTMVar :: forall a. a -> STM (TMVar a)
newTMVar a
a = do
  TVar (Maybe a)
t <- Maybe a -> STM (TVar (Maybe a))
forall a. a -> STM (TVar a)
newTVar (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
  TMVar a -> STM (TMVar a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (Maybe a) -> TMVar a
forall a. TVar (Maybe a) -> TMVar a
TMVar TVar (Maybe a)
t)

-- |@IO@ version of 'newTMVar'.  This is useful for creating top-level
-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using
-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
-- possible.
newTMVarIO :: a -> IO (TMVar a)
newTMVarIO :: forall a. a -> IO (TMVar a)
newTMVarIO a
a = do
  TVar (Maybe a)
t <- Maybe a -> IO (TVar (Maybe a))
forall a. a -> IO (TVar a)
newTVarIO (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
  TMVar a -> IO (TMVar a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (Maybe a) -> TMVar a
forall a. TVar (Maybe a) -> TMVar a
TMVar TVar (Maybe a)
t)

-- |Create a 'TMVar' which is initially empty.
newEmptyTMVar :: STM (TMVar a)
newEmptyTMVar :: forall a. STM (TMVar a)
newEmptyTMVar = do
  TVar (Maybe a)
t <- Maybe a -> STM (TVar (Maybe a))
forall a. a -> STM (TVar a)
newTVar Maybe a
forall a. Maybe a
Nothing
  TMVar a -> STM (TMVar a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (Maybe a) -> TMVar a
forall a. TVar (Maybe a) -> TMVar a
TMVar TVar (Maybe a)
t)

-- |@IO@ version of 'newEmptyTMVar'.  This is useful for creating top-level
-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using
-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
-- possible.
newEmptyTMVarIO :: IO (TMVar a)
newEmptyTMVarIO :: forall a. IO (TMVar a)
newEmptyTMVarIO = do
  TVar (Maybe a)
t <- Maybe a -> IO (TVar (Maybe a))
forall a. a -> IO (TVar a)
newTVarIO Maybe a
forall a. Maybe a
Nothing
  TMVar a -> IO (TMVar a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (Maybe a) -> TMVar a
forall a. TVar (Maybe a) -> TMVar a
TMVar TVar (Maybe a)
t)

-- |Return the contents of the 'TMVar'.  If the 'TMVar' is currently
-- empty, the transaction will 'retry'.  After a 'takeTMVar',
-- the 'TMVar' is left empty.
takeTMVar :: TMVar a -> STM a
takeTMVar :: forall a. TMVar a -> STM a
takeTMVar (TMVar TVar (Maybe a)
t) = do
  Maybe a
m <- TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> STM a
forall a. STM a
retry
    Just a
a  -> do TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
t Maybe a
forall a. Maybe a
Nothing; a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | A version of 'takeTMVar' that does not 'retry'.  The 'tryTakeTMVar'
-- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if
-- the 'TMVar' was full with contents @a@.  After 'tryTakeTMVar', the
-- 'TMVar' is left empty.
tryTakeTMVar :: TMVar a -> STM (Maybe a)
tryTakeTMVar :: forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar (TMVar TVar (Maybe a)
t) = do
  Maybe a
m <- TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just a
a  -> do TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
t Maybe a
forall a. Maybe a
Nothing; Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)

-- |Put a value into a 'TMVar'.  If the 'TMVar' is currently full,
-- 'putTMVar' will 'retry'.
putTMVar :: TMVar a -> a -> STM ()
putTMVar :: forall a. TMVar a -> a -> STM ()
putTMVar (TMVar TVar (Maybe a)
t) a
a = do
  Maybe a
m <- TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> do TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
t (a -> Maybe a
forall a. a -> Maybe a
Just a
a); () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just a
_  -> STM ()
forall a. STM a
retry

-- | A version of 'putTMVar' that does not 'retry'.  The 'tryPutTMVar'
-- function attempts to put the value @a@ into the 'TMVar', returning
-- 'True' if it was successful, or 'False' otherwise.
tryPutTMVar :: TMVar a -> a -> STM Bool
tryPutTMVar :: forall a. TMVar a -> a -> STM Bool
tryPutTMVar (TMVar TVar (Maybe a)
t) a
a = do
  Maybe a
m <- TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> do TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
t (a -> Maybe a
forall a. a -> Maybe a
Just a
a); Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Just a
_  -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | This is a combination of 'takeTMVar' and 'putTMVar'; ie. it
-- takes the value from the 'TMVar', puts it back, and also returns
-- it.
readTMVar :: TMVar a -> STM a
readTMVar :: forall a. TMVar a -> STM a
readTMVar (TMVar TVar (Maybe a)
t) = do
  Maybe a
m <- TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> STM a
forall a. STM a
retry
    Just a
a  -> a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | A version of 'readTMVar' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
--
-- @since 2.3
tryReadTMVar :: TMVar a -> STM (Maybe a)
tryReadTMVar :: forall a. TMVar a -> STM (Maybe a)
tryReadTMVar (TMVar TVar (Maybe a)
t) = TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
t

-- |Swap the contents of a 'TMVar' for a new value.
swapTMVar :: TMVar a -> a -> STM a
swapTMVar :: forall a. TMVar a -> a -> STM a
swapTMVar (TMVar TVar (Maybe a)
t) a
new = do
  Maybe a
m <- TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> STM a
forall a. STM a
retry
    Just a
old -> do TVar (Maybe a) -> Maybe a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe a)
t (a -> Maybe a
forall a. a -> Maybe a
Just a
new); a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
old

-- |Check whether a given 'TMVar' is empty.
isEmptyTMVar :: TMVar a -> STM Bool
isEmptyTMVar :: forall a. TMVar a -> STM Bool
isEmptyTMVar (TMVar TVar (Maybe a)
t) = do
  Maybe a
m <- TVar (Maybe a) -> STM (Maybe a)
forall a. TVar a -> STM a
readTVar TVar (Maybe a)
t
  case Maybe a
m of
    Maybe a
Nothing -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Just a
_  -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Make a 'Weak' pointer to a 'TMVar', using the second argument as
-- a finalizer to run when the 'TMVar' is garbage-collected.
--
-- @since 2.4.4
mkWeakTMVar :: TMVar a -> IO () -> IO (Weak (TMVar a))
mkWeakTMVar :: forall a. TMVar a -> IO () -> IO (Weak (TMVar a))
mkWeakTMVar tmv :: TMVar a
tmv@(TMVar (TVar TVar# RealWorld (Maybe a)
t#)) (IO State# RealWorld -> (# State# RealWorld, () #)
finalizer) = (State# RealWorld -> (# State# RealWorld, Weak (TMVar a) #))
-> IO (Weak (TMVar a))
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Weak (TMVar a) #))
 -> IO (Weak (TMVar a)))
-> (State# RealWorld -> (# State# RealWorld, Weak (TMVar a) #))
-> IO (Weak (TMVar a))
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case TVar# RealWorld (Maybe a)
-> TMVar a
-> (State# RealWorld -> (# State# RealWorld, () #))
-> State# RealWorld
-> (# State# RealWorld, Weak# (TMVar a) #)
mkWeak# TVar# RealWorld (Maybe a)
t# TMVar a
tmv State# RealWorld -> (# State# RealWorld, () #)
finalizer State# RealWorld
s of (# State# RealWorld
s1, Weak# (TMVar a)
w #) -> (# State# RealWorld
s1, Weak# (TMVar a) -> Weak (TMVar a)
forall v. Weak# v -> Weak v
Weak Weak# (TMVar a)
w #)
#endif