-- |
-- Module     : Simulation.Aivika.RealTime.Internal.Channel
-- Copyright  : Copyright (c) 2016-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- This module defines a channel with fast checking procedure whether the channel is empty.
--
module Simulation.Aivika.RealTime.Internal.Channel
       (Channel,
        newChannel,
        channelEmpty,
        readChannel,
        writeChannel,
        awaitChannel) where

import Data.List
import Data.IORef

import Control.Concurrent.STM
import Control.Monad

-- | A channel.
data Channel a =
  Channel { forall a. Channel a -> TVar [a]
channelList :: TVar [a],
            forall a. Channel a -> TVar Bool
channelListEmpty :: TVar Bool,
            forall a. Channel a -> IORef Bool
channelListEmptyIO :: IORef Bool
          }

-- | Create a new channel.
newChannel :: IO (Channel a)
newChannel :: forall a. IO (Channel a)
newChannel =
  do TVar [a]
list <- forall a. a -> IO (TVar a)
newTVarIO []
     TVar Bool
listEmpty <- forall a. a -> IO (TVar a)
newTVarIO Bool
True
     IORef Bool
listEmptyIO <- forall a. a -> IO (IORef a)
newIORef Bool
True
     forall (m :: * -> *) a. Monad m => a -> m a
return Channel { channelList :: TVar [a]
channelList = TVar [a]
list,
                      channelListEmpty :: TVar Bool
channelListEmpty = TVar Bool
listEmpty,
                      channelListEmptyIO :: IORef Bool
channelListEmptyIO = IORef Bool
listEmptyIO }

-- | Test quickly whether the channel is empty.
channelEmpty :: Channel a -> IO Bool
channelEmpty :: forall a. Channel a -> IO Bool
channelEmpty Channel a
ch =
  forall a. IORef a -> IO a
readIORef (forall a. Channel a -> IORef Bool
channelListEmptyIO Channel a
ch)

-- | Read all data from the channel. 
readChannel :: Channel a -> IO [a]
readChannel :: forall a. Channel a -> IO [a]
readChannel Channel a
ch =
  do Bool
empty <- forall a. IORef a -> IO a
readIORef (forall a. Channel a -> IORef Bool
channelListEmptyIO Channel a
ch)
     if Bool
empty
       then forall (m :: * -> *) a. Monad m => a -> m a
return []
       else do forall a. IORef a -> a -> IO ()
writeIORef (forall a. Channel a -> IORef Bool
channelListEmptyIO Channel a
ch) Bool
True
               [a]
xs <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
                     do [a]
xs <- forall a. TVar a -> STM a
readTVar (forall a. Channel a -> TVar [a]
channelList Channel a
ch)
                        forall a. TVar a -> a -> STM ()
writeTVar (forall a. Channel a -> TVar [a]
channelList Channel a
ch) []
                        forall a. TVar a -> a -> STM ()
writeTVar (forall a. Channel a -> TVar Bool
channelListEmpty Channel a
ch) Bool
True
                        forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs
               forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [a]
xs)

-- | Write the value in the channel.
writeChannel :: Channel a -> a -> IO ()
writeChannel :: forall a. Channel a -> a -> IO ()
writeChannel Channel a
ch a
a =
  do forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
       do [a]
xs <- forall a. TVar a -> STM a
readTVar (forall a. Channel a -> TVar [a]
channelList Channel a
ch)
          forall a. TVar a -> a -> STM ()
writeTVar (forall a. Channel a -> TVar [a]
channelList Channel a
ch) (a
a forall a. a -> [a] -> [a]
: [a]
xs)
          forall a. TVar a -> a -> STM ()
writeTVar (forall a. Channel a -> TVar Bool
channelListEmpty Channel a
ch) Bool
False
     forall a. IORef a -> a -> IO ()
writeIORef (forall a. Channel a -> IORef Bool
channelListEmptyIO Channel a
ch) Bool
False

-- | Wait for data in the channel.
awaitChannel :: Channel a -> IO ()
awaitChannel :: forall a. Channel a -> IO ()
awaitChannel Channel a
ch =
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
  do Bool
empty <- forall a. TVar a -> STM a
readTVar (forall a. Channel a -> TVar Bool
channelListEmpty Channel a
ch)
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty forall a. STM a
retry