module Control.Concurrent.FiniteChan (
	Chan,
	newChan, openedChan, closedChan, doneChan, sendChan, getChan, closeChan, stopChan
	) where

import Control.Monad (void, when, liftM2)
import Control.Monad.Loops
import Control.Concurrent.STM

-- | 'Chan' is stoppable channel
data Chan a = Chan {
	Chan a -> TMVar Bool
chanOpened :: TMVar Bool,
	Chan a -> TQueue a
chanQueue :: TQueue a }

-- -- | Create new channel
newChan :: IO (Chan a)
newChan :: IO (Chan a)
newChan = (TMVar Bool -> TQueue a -> Chan a)
-> IO (TMVar Bool) -> IO (TQueue a) -> IO (Chan a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 TMVar Bool -> TQueue a -> Chan a
forall a. TMVar Bool -> TQueue a -> Chan a
Chan (Bool -> IO (TMVar Bool)
forall a. a -> IO (TMVar a)
newTMVarIO Bool
True) IO (TQueue a)
forall a. IO (TQueue a)
newTQueueIO

-- | Is channel opened
openedChan :: Chan a -> IO Bool
openedChan :: Chan a -> IO Bool
openedChan = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> (Chan a -> STM Bool) -> Chan a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar Bool -> STM Bool
forall a. TMVar a -> STM a
readTMVar (TMVar Bool -> STM Bool)
-> (Chan a -> TMVar Bool) -> Chan a -> STM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chan a -> TMVar Bool
forall a. Chan a -> TMVar Bool
chanOpened

-- | Is channel closed
closedChan :: Chan a -> IO Bool
closedChan :: Chan a -> IO Bool
closedChan = (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool) -> (Chan a -> IO Bool) -> Chan a -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chan a -> IO Bool
forall a. Chan a -> IO Bool
openedChan

-- | Is channel closed and all data consumed
doneChan :: Chan a -> IO Bool
doneChan :: Chan a -> IO Bool
doneChan Chan a
ch = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
	Bool
o <- TMVar Bool -> STM Bool
forall a. TMVar a -> STM a
readTMVar (TMVar Bool -> STM Bool) -> TMVar Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ Chan a -> TMVar Bool
forall a. Chan a -> TMVar Bool
chanOpened Chan a
ch
	Bool
e <- TQueue a -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue (Chan a -> TQueue a
forall a. Chan a -> TQueue a
chanQueue Chan a
ch)
	Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM Bool) -> Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
o Bool -> Bool -> Bool
&& Bool
e

-- | Write data to channel if it is open
sendChan :: Chan a -> a -> IO Bool
sendChan :: Chan a -> a -> IO Bool
sendChan Chan a
ch a
v = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
	Bool
o <- TMVar Bool -> STM Bool
forall a. TMVar a -> STM a
readTMVar (TMVar Bool -> STM Bool) -> TMVar Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ Chan a -> TMVar Bool
forall a. Chan a -> TMVar Bool
chanOpened Chan a
ch
	Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
o (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$ TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (Chan a -> TQueue a
forall a. Chan a -> TQueue a
chanQueue Chan a
ch) a
v
	Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
o

-- | Get data from channel
getChan :: Chan a -> IO (Maybe a)
getChan :: Chan a -> IO (Maybe a)
getChan Chan a
ch = STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a)) -> STM (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
	Bool
o <- TMVar Bool -> STM Bool
forall a. TMVar a -> STM a
readTMVar (TMVar Bool -> STM Bool) -> TMVar Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ Chan a -> TMVar Bool
forall a. Chan a -> TMVar Bool
chanOpened Chan a
ch
	if Bool
o
		then (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (TQueue a -> STM a
forall a. TQueue a -> STM a
readTQueue (Chan a -> TQueue a
forall a. Chan a -> TQueue a
chanQueue Chan a
ch))
		else TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue (Chan a -> TQueue a
forall a. Chan a -> TQueue a
chanQueue Chan a
ch)

-- | Close channel
closeChan :: Chan a -> IO ()
closeChan :: Chan a -> IO ()
closeChan Chan a
ch = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Bool -> STM ()) -> STM Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ TMVar Bool -> Bool -> STM Bool
forall a. TMVar a -> a -> STM a
swapTMVar (Chan a -> TMVar Bool
forall a. Chan a -> TMVar Bool
chanOpened Chan a
ch) Bool
False

-- | Close channel and read all messages
stopChan :: Chan a -> IO [a]
stopChan :: Chan a -> IO [a]
stopChan Chan a
ch = do
	Chan a -> IO ()
forall a. Chan a -> IO ()
closeChan Chan a
ch
	IO (Maybe a) -> (a -> IO a) -> IO [a]
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m [b]
whileJust (Chan a -> IO (Maybe a)
forall a. Chan a -> IO (Maybe a)
getChan Chan a
ch) a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return