{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}
{-|
Module: Internal.TCloseQ
Description: Transactional queues with a close operation.

This module provides a thin layer over 'TQueue', which affords "closing"
queues. Reading from a closed queue returns 'Nothing'.
-}
module Internal.TCloseQ
    ( Q
    , ErrClosed(..)
    , new
    , read
    , write
    , close
    ) where

import Prelude hiding (read)

import Control.Concurrent.STM

import Control.Exception (Exception)
import Control.Monad     (unless, when)
import Data.Maybe        (isNothing)

-- | A Queue with a close operation, with element type @a@.
data Q a = Q
    { Q a -> TQueue (Maybe a)
q        :: TQueue (Maybe a)
    , Q a -> TVar Bool
isClosed :: TVar Bool
    }

-- | An exception which is thrown if a caller tries to write to a closed queue.
data ErrClosed = ErrClosed
    deriving(Int -> ErrClosed -> ShowS
[ErrClosed] -> ShowS
ErrClosed -> String
(Int -> ErrClosed -> ShowS)
-> (ErrClosed -> String)
-> ([ErrClosed] -> ShowS)
-> Show ErrClosed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrClosed] -> ShowS
$cshowList :: [ErrClosed] -> ShowS
show :: ErrClosed -> String
$cshow :: ErrClosed -> String
showsPrec :: Int -> ErrClosed -> ShowS
$cshowsPrec :: Int -> ErrClosed -> ShowS
Show)
instance Exception ErrClosed

-- | Create a new empty queue.
new :: STM (Q a)
new :: STM (Q a)
new = do
    TQueue (Maybe a)
q <- STM (TQueue (Maybe a))
forall a. STM (TQueue a)
newTQueue
    TVar Bool
isClosed <- Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
    Q a -> STM (Q a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Q :: forall a. TQueue (Maybe a) -> TVar Bool -> Q a
Q{TVar Bool
TQueue (Maybe a)
isClosed :: TVar Bool
q :: TQueue (Maybe a)
isClosed :: TVar Bool
q :: TQueue (Maybe a)
..}

-- | Read a value from the queue. Returns Nothing if the queue is closed.
read :: Q a -> STM (Maybe a)
read :: Q a -> STM (Maybe a)
read Q{TQueue (Maybe a)
q :: TQueue (Maybe a)
q :: forall a. Q a -> TQueue (Maybe a)
q} = do
    Maybe a
ret <- TQueue (Maybe a) -> STM (Maybe a)
forall a. TQueue a -> STM a
readTQueue TQueue (Maybe a)
q
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
ret) (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
        -- put it back in, so future reads also return nothing:
        TQueue (Maybe a) -> Maybe a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe a)
q Maybe a
ret
    Maybe a -> STM (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
ret

-- | Write a value to the queue, which must not be closed. If it is closed,
-- this will throw 'ErrClosed'.
write :: Q a -> a -> STM ()
write :: Q a -> a -> STM ()
write Q{TQueue (Maybe a)
q :: TQueue (Maybe a)
q :: forall a. Q a -> TQueue (Maybe a)
q, TVar Bool
isClosed :: TVar Bool
isClosed :: forall a. Q a -> TVar Bool
isClosed} a
v = do
    Bool
c <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
isClosed
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ ErrClosed -> STM ()
forall e a. Exception e => e -> STM a
throwSTM ErrClosed
ErrClosed
    TQueue (Maybe a) -> Maybe a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe a)
q (a -> Maybe a
forall a. a -> Maybe a
Just a
v)

-- | Close a queue. It is safe to close a queue more than once; subsequent
-- closes will have no effect.
close :: Q a -> STM ()
close :: Q a -> STM ()
close Q{TQueue (Maybe a)
q :: TQueue (Maybe a)
q :: forall a. Q a -> TQueue (Maybe a)
q, TVar Bool
isClosed :: TVar Bool
isClosed :: forall a. Q a -> TVar Bool
isClosed} = do
    Bool
c <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
isClosed
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
c (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ do
        TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
isClosed Bool
True
        TQueue (Maybe a) -> Maybe a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe a)
q Maybe a
forall a. Maybe a
Nothing