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

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
----------------------------------------------------------------
--                                                    2021.10.17
-- |
-- Module      :  Control.Concurrent.STM.TMQueue
-- 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.TQueue" where the queue is
-- closeable. This is similar to a @TQueue (Maybe a)@ with a
-- monotonicity guarantee that once there's a @Nothing@ there will
-- always be @Nothing@.
--
-- /Since: 2.0.0/
----------------------------------------------------------------
module Control.Concurrent.STM.TMQueue
    (
    -- * The TMQueue type
      TMQueue()
    -- ** Creating TMQueues
    , newTMQueue
    , newTMQueueIO
    -- ** Reading from TMQueues
    , readTMQueue
    , tryReadTMQueue
    , peekTMQueue
    , tryPeekTMQueue
    -- ** Writing to TMQueues
    , writeTMQueue
    , unGetTMQueue
    -- ** Closing TMQueues
    , closeTMQueue
    -- ** Predicates
    , isClosedTMQueue
    , isEmptyTMQueue
    ) 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.TQueue -- N.B., GHC only
----------------------------------------------------------------

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


-- | Build and returns a new instance of @TMQueue@.
newTMQueue :: STM (TMQueue a)
newTMQueue :: STM (TMQueue a)
newTMQueue = do
    TVar Bool
closed <- Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
    TQueue a
queue  <- STM (TQueue a)
forall a. STM (TQueue a)
newTQueue
    TMQueue a -> STM (TMQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> TQueue a -> TMQueue a
forall a. TVar Bool -> TQueue a -> TMQueue a
TMQueue TVar Bool
closed TQueue a
queue)


-- | @IO@ version of 'newTMQueue'. This is useful for creating
-- top-level @TMQueue@s using 'System.IO.Unsafe.unsafePerformIO',
-- because using 'Control.Monad.STM.atomically' inside
-- 'System.IO.Unsafe.unsafePerformIO' isn't possible.
newTMQueueIO :: IO (TMQueue a)
newTMQueueIO :: IO (TMQueue a)
newTMQueueIO = do
    TVar Bool
closed <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
    TQueue a
queue  <- IO (TQueue a)
forall a. IO (TQueue a)
newTQueueIO
    TMQueue a -> IO (TMQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> TQueue a -> TMQueue a
forall a. TVar Bool -> TQueue a -> TMQueue a
TMQueue TVar Bool
closed TQueue a
queue)


-- | Read the next value from the @TMQueue@, retrying if the queue
-- is empty (and not closed). We return @Nothing@ immediately if
-- the queue is closed and empty.
readTMQueue :: TMQueue a -> STM (Maybe a)
readTMQueue :: TMQueue a -> STM (Maybe a)
readTMQueue (TMQueue TVar Bool
closed TQueue a
queue) = do
    Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
    if Bool
b
        then TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
        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
<$> TQueue a -> STM a
forall a. TQueue a -> STM a
readTQueue TQueue a
queue
{-
-- The above is lazier reading from @queue@, and slightly optimized, compared to the clearer:
readTMQueue (TMQueue closed queue) = do
    b  <- isEmptyTQueue queue
    b' <- readTVar closed
    if b && b'
        then return Nothing
        else Just <$> readTQueue queue
-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
-}


-- | A version of 'readTMQueue' which does not retry. Instead it
-- returns @Just Nothing@ if the queue is open but no value is
-- available; it still returns @Nothing@ if the queue is closed
-- and empty.
tryReadTMQueue :: TMQueue a -> STM (Maybe (Maybe a))
tryReadTMQueue :: TMQueue a -> STM (Maybe (Maybe a))
tryReadTMQueue (TMQueue TVar Bool
closed TQueue a
queue) = 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
<$> TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
        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
<$> TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
{-
-- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer:
tryReadTMQueue (TMQueue closed queue) = do
    b  <- isEmptyTQueue queue
    b' <- readTVar closed
    if b && b'
        then return Nothing
        else Just <$> tryReadTQueue queue
-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
-}


-- | Get the next value from the @TMQueue@ without removing it,
-- retrying if the queue is empty.
peekTMQueue :: TMQueue a -> STM (Maybe a)
peekTMQueue :: TMQueue a -> STM (Maybe a)
peekTMQueue (TMQueue TVar Bool
closed TQueue a
queue) = do
    Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
    if Bool
b
        then do
            Bool
b' <- TQueue a -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue a
queue
            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
<$> TQueue a -> STM a
forall a. TQueue a -> STM a
peekTQueue TQueue a
queue
        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
<$> TQueue a -> STM a
forall a. TQueue a -> STM a
peekTQueue TQueue a
queue
{-
-- The above is lazier reading from @queue@ than the clearer:
peekTMQueue (TMQueue closed queue) = do
    b  <- isEmptyTQueue queue
    b' <- readTVar closed
    if b && b'
        then return Nothing
        else Just <$> peekTQueue queue
-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
-}


-- | A version of 'peekTMQueue' which does not retry. Instead it
-- returns @Just Nothing@ if the queue is open but no value is
-- available; it still returns @Nothing@ if the queue is closed
-- and empty.
tryPeekTMQueue :: TMQueue a -> STM (Maybe (Maybe a))
tryPeekTMQueue :: TMQueue a -> STM (Maybe (Maybe a))
tryPeekTMQueue (TMQueue TVar Bool
closed TQueue a
queue) = 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
<$> TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryPeekTQueue TQueue a
queue
        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
<$> TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryPeekTQueue TQueue a
queue
{-
-- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer:
tryPeekTMQueue (TMQueue closed queue) = do
    b  <- isEmptyTQueue queue
    b' <- readTVar closed
    if b && b'
        then return Nothing
        else Just <$> tryPeekTQueue queue
-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
-}


-- | Write a value to a @TMQueue@. If the queue is closed then the
-- value is silently discarded. Use 'isClosedTMQueue' to determine
-- if the queue is closed before writing, as needed.
writeTMQueue :: TMQueue a -> a -> STM ()
writeTMQueue :: TMQueue a -> a -> STM ()
writeTMQueue (TMQueue TVar Bool
closed TQueue a
queue) 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 TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue a
queue a
x


-- | Put a data item back onto a queue, where it will be the next
-- item read. If the queue is closed then the value is silently
-- discarded; you can use 'peekTMQueue' to circumvent this in certain
-- circumstances.
unGetTMQueue :: TMQueue a -> a -> STM ()
unGetTMQueue :: TMQueue a -> a -> STM ()
unGetTMQueue (TMQueue TVar Bool
closed TQueue a
queue) 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 TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
unGetTQueue TQueue a
queue a
x


-- | Closes the @TMQueue@, preventing any further writes.
closeTMQueue :: TMQueue a -> STM ()
closeTMQueue :: TMQueue a -> STM ()
closeTMQueue (TMQueue TVar Bool
closed TQueue a
_queue) =
    TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
closed Bool
True


-- | Returns @True@ if the supplied @TMQueue@ has been closed.
isClosedTMQueue :: TMQueue a -> STM Bool
isClosedTMQueue :: TMQueue a -> STM Bool
isClosedTMQueue (TMQueue TVar Bool
closed TQueue a
_queue) =
    TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed

{-
-- | Returns @True@ if the supplied @TMQueue@ has been closed.
isClosedTMQueueIO :: TMQueue a -> IO Bool
isClosedTMQueueIO (TMQueue closed _queue) =
    readTVarIO closed
-}


-- | Returns @True@ if the supplied @TMQueue@ is empty.
isEmptyTMQueue :: TMQueue a -> STM Bool
isEmptyTMQueue :: TMQueue a -> STM Bool
isEmptyTMQueue (TMQueue TVar Bool
_closed TQueue a
queue) =
    TQueue a -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue a
queue

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