{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
----------------------------------------------------------------
--                                                    2021.10.17
-- |
-- Module      :  Control.Concurrent.STM.TMChan
-- Copyright   :  Copyright (c) 2011--2021 wren gayle romano
-- License     :  BSD
-- Maintainer  :  wren@cpan.org
-- Stability   :  provisional
-- Portability :  non-portable (GHC STM, DeriveDataTypeable)
--
-- A version of "Control.Concurrent.STM.TChan" where the queue is
-- closeable. This is similar to a @TChan (Maybe a)@ with a
-- monotonicity guarantee that once there's a @Nothing@ there will
-- always be @Nothing@.
----------------------------------------------------------------
module Control.Concurrent.STM.TMChan
    (
    -- * The TMChan type
      TMChan()
    -- ** Creating TMChans
    , newTMChan
    , newTMChanIO
    , dupTMChan
    , newBroadcastTMChan
    , newBroadcastTMChanIO
    -- ** Reading from TMChans
    , readTMChan
    , tryReadTMChan
    , peekTMChan
    , tryPeekTMChan
    -- ** Writing to TMChans
    , writeTMChan
    , unGetTMChan
    -- ** Closing TMChans
    , closeTMChan
    -- ** Predicates
    , isClosedTMChan
    , isEmptyTMChan
    ) where

import Data.Typeable       (Typeable)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad.STM   (STM)
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TChan -- N.B., GHC only
----------------------------------------------------------------

-- | @TMChan@ is an abstract type representing a closeable FIFO
-- channel.
data TMChan a = TMChan
    {-# UNPACK #-} !(TVar Bool)
    {-# UNPACK #-} !(TChan a)
    deriving Typeable


-- | Build and returns a new instance of @TMChan@.
newTMChan :: STM (TMChan a)
newTMChan :: STM (TMChan a)
newTMChan = do
    TVar Bool
closed <- Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
    TChan a
chan   <- STM (TChan a)
forall a. STM (TChan a)
newTChan
    TMChan a -> STM (TMChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> TChan a -> TMChan a
forall a. TVar Bool -> TChan a -> TMChan a
TMChan TVar Bool
closed TChan a
chan)


-- | @IO@ version of 'newTMChan'. This is useful for creating
-- top-level @TMChan@s using 'System.IO.Unsafe.unsafePerformIO',
-- because using 'Control.Monad.STM.atomically' inside
-- 'System.IO.Unsafe.unsafePerformIO' isn't possible.
newTMChanIO :: IO (TMChan a)
newTMChanIO :: IO (TMChan a)
newTMChanIO = do
    TVar Bool
closed <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
    TChan a
chan   <- IO (TChan a)
forall a. IO (TChan a)
newTChanIO
    TMChan a -> IO (TMChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> TChan a -> TMChan a
forall a. TVar Bool -> TChan a -> TMChan a
TMChan TVar Bool
closed TChan a
chan)


-- | Like 'newBroadcastTChan'.
--
-- /Since: 2.1.0/
newBroadcastTMChan :: STM (TMChan a)
newBroadcastTMChan :: STM (TMChan a)
newBroadcastTMChan = do
    TVar Bool
closed <- Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
    TChan a
chan   <- STM (TChan a)
forall a. STM (TChan a)
newBroadcastTChan
    TMChan a -> STM (TMChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> TChan a -> TMChan a
forall a. TVar Bool -> TChan a -> TMChan a
TMChan TVar Bool
closed TChan a
chan)


-- | @IO@ version of 'newBroadcastTMChan'.
--
-- /Since: 2.1.0/
newBroadcastTMChanIO :: IO (TMChan a)
newBroadcastTMChanIO :: IO (TMChan a)
newBroadcastTMChanIO = do
    TVar Bool
closed <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
    TChan a
chan   <- IO (TChan a)
forall a. IO (TChan a)
newBroadcastTChanIO
    TMChan a -> IO (TMChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> TChan a -> TMChan a
forall a. TVar Bool -> TChan a -> TMChan a
TMChan TVar Bool
closed TChan a
chan)


-- | Duplicate a @TMChan@: the duplicate channel begins empty, but
-- data written to either channel from then on will be available
-- from both, and closing one copy will close them all. Hence this
-- creates a kind of broadcast channel, where data written by anyone
-- is seen by everyone else.
dupTMChan :: TMChan a -> STM (TMChan a)
dupTMChan :: TMChan a -> STM (TMChan a)
dupTMChan (TMChan TVar Bool
closed TChan a
chan) = do
    TChan a
new_chan <- TChan a -> STM (TChan a)
forall a. TChan a -> STM (TChan a)
dupTChan TChan a
chan
    TMChan a -> STM (TMChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> TChan a -> TMChan a
forall a. TVar Bool -> TChan a -> TMChan a
TMChan TVar Bool
closed TChan a
new_chan)


-- | Read the next value from the @TMChan@, retrying if the channel
-- is empty (and not closed). We return @Nothing@ immediately if
-- the channel is closed and empty.
readTMChan :: TMChan a -> STM (Maybe a)
readTMChan :: TMChan a -> STM (Maybe a)
readTMChan (TMChan TVar Bool
closed TChan a
chan) = do
    Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
    if Bool
b
        then TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
chan
        else a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan a -> STM a
forall a. TChan a -> STM a
readTChan TChan a
chan
{-
-- The above is lazier reading from @chan@, and slightly optimized, compared to the clearer:
readTMChan (TMChan closed chan) = do
    b  <- isEmptyTChan chan
    b' <- readTVar closed
    if b && b'
        then return Nothing
        else Just <$> readTChan chan
-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
-}


-- | A version of 'readTMChan' which does not retry. Instead it
-- returns @Just Nothing@ if the channel is open but no value is
-- available; it still returns @Nothing@ if the channel is closed
-- and empty.
tryReadTMChan :: TMChan a -> STM (Maybe (Maybe a))
tryReadTMChan :: TMChan a -> STM (Maybe (Maybe a))
tryReadTMChan (TMChan TVar Bool
closed TChan a
chan) = do
    Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
    if Bool
b
        then (a -> Maybe a) -> Maybe a -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a))
-> STM (Maybe a) -> STM (Maybe (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
chan
        else Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a))
-> STM (Maybe a) -> STM (Maybe (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
chan
{-
-- The above is lazier reading from @chan@ (and removes an extraneous isEmptyTChan when using the compatibility layer) than the clearer:
tryReadTMChan (TMChan closed chan) = do
    b  <- isEmptyTChan chan
    b' <- readTVar closed
    if b && b'
        then return Nothing
        else Just <$> tryReadTChan chan
-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
-}


-- | Get the next value from the @TMChan@ without removing it,
-- retrying if the channel is empty.
peekTMChan :: TMChan a -> STM (Maybe a)
peekTMChan :: TMChan a -> STM (Maybe a)
peekTMChan (TMChan TVar Bool
closed TChan a
chan) = do
    Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
    if Bool
b
        then do
            Bool
b' <- TChan a -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan a
chan
            if Bool
b'
                then Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                else a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan a -> STM a
forall a. TChan a -> STM a
peekTChan TChan a
chan
        else a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan a -> STM a
forall a. TChan a -> STM a
peekTChan TChan a
chan
{-
-- The above is lazier reading from @chan@ than the clearer:
peekTMChan (TMChan closed chan) = do
    b  <- isEmptyTChan chan
    b' <- readTVar closed
    if b && b'
        then return Nothing
        else Just <$> peekTChan chan
-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
-}


-- | A version of 'peekTMChan' which does not retry. Instead it
-- returns @Just Nothing@ if the channel is open but no value is
-- available; it still returns @Nothing@ if the channel is closed
-- and empty.
tryPeekTMChan :: TMChan a -> STM (Maybe (Maybe a))
tryPeekTMChan :: TMChan a -> STM (Maybe (Maybe a))
tryPeekTMChan (TMChan TVar Bool
closed TChan a
chan) = do
    Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
    if Bool
b
        then (a -> Maybe a) -> Maybe a -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a))
-> STM (Maybe a) -> STM (Maybe (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryPeekTChan TChan a
chan
        else Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a))
-> STM (Maybe a) -> STM (Maybe (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryPeekTChan TChan a
chan
{-
-- The above is lazier reading from @chan@ (and removes an extraneous isEmptyTChan when using the compatibility layer) than the clearer:
tryPeekTMChan (TMChan closed chan) = do
    b  <- isEmptyTChan chan
    b' <- readTVar closed
    if b && b'
        then return Nothing
        else Just <$> tryPeekTChan chan
-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
-}


-- | Write a value to a @TMChan@. If the channel is closed then the
-- value is silently discarded. Use 'isClosedTMChan' to determine
-- if the channel is closed before writing, as needed.
writeTMChan :: TMChan a -> a -> STM ()
writeTMChan :: TMChan a -> a -> STM ()
writeTMChan (TMChan TVar Bool
closed TChan a
chan) a
x = do
    Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
    if Bool
b
        then () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- discard silently
        else TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan a
chan a
x


-- | Put a data item back onto a channel, where it will be the next
-- item read. If the channel is closed then the value is silently
-- discarded; you can use 'peekTMChan' to circumvent this in certain
-- circumstances.
unGetTMChan :: TMChan a -> a -> STM ()
unGetTMChan :: TMChan a -> a -> STM ()
unGetTMChan (TMChan TVar Bool
closed TChan a
chan) a
x = do
    Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
    if Bool
b
        then () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- discard silently
        else TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
unGetTChan TChan a
chan a
x


-- | Closes the @TMChan@, preventing any further writes.
closeTMChan :: TMChan a -> STM ()
closeTMChan :: TMChan a -> STM ()
closeTMChan (TMChan TVar Bool
closed TChan a
_chan) =
    TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
closed Bool
True


-- | Returns @True@ if the supplied @TMChan@ has been closed.
isClosedTMChan :: TMChan a -> STM Bool
isClosedTMChan :: TMChan a -> STM Bool
isClosedTMChan (TMChan TVar Bool
closed TChan a
_chan) =
    TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed

{-
-- | Returns @True@ if the supplied @TMChan@ has been closed.
isClosedTMChanIO :: TMChan a -> IO Bool
isClosedTMChanIO (TMChan closed _chan) =
    readTVarIO closed
-}


-- | Returns @True@ if the supplied @TMChan@ is empty.
isEmptyTMChan :: TMChan a -> STM Bool
isEmptyTMChan :: TMChan a -> STM Bool
isEmptyTMChan (TMChan TVar Bool
_closed TChan a
chan) =
    TChan a -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan a
chan

----------------------------------------------------------------
----------------------------------------------------------- fin.