-- |
-- Module     : Simulation.Aivika.Distributed.Optimistic.Internal.Channel
-- Copyright  : Copyright (c) 2015-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 7.10.3
--
-- This module defines a channel with fast checking procedure whether the channel is empty.
--
module Simulation.Aivika.Distributed.Optimistic.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 <- [a] -> IO (TVar [a])
forall a. a -> IO (TVar a)
newTVarIO []
     TVar Bool
listEmpty <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
True
     IORef Bool
listEmptyIO <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
     Channel a -> IO (Channel a)
forall a. a -> IO a
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
{-# INLINE channelEmpty #-}
channelEmpty :: forall a. Channel a -> IO Bool
channelEmpty Channel a
ch =
  IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Channel a -> IORef Bool
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 <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (Channel a -> IORef Bool
forall a. Channel a -> IORef Bool
channelListEmptyIO Channel a
ch)
     if Bool
empty
       then [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
       else do IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef (Channel a -> IORef Bool
forall a. Channel a -> IORef Bool
channelListEmptyIO Channel a
ch) Bool
True
               [a]
xs <- STM [a] -> IO [a]
forall a. STM a -> IO a
atomically (STM [a] -> IO [a]) -> STM [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$
                     do [a]
xs <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar (Channel a -> TVar [a]
forall a. Channel a -> TVar [a]
channelList Channel a
ch)
                        TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Channel a -> TVar [a]
forall a. Channel a -> TVar [a]
channelList Channel a
ch) []
                        TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Channel a -> TVar Bool
forall a. Channel a -> TVar Bool
channelListEmpty Channel a
ch) Bool
True
                        [a] -> STM [a]
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs
               [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [a]
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 STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
       do [a]
xs <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar (Channel a -> TVar [a]
forall a. Channel a -> TVar [a]
channelList Channel a
ch)
          TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Channel a -> TVar [a]
forall a. Channel a -> TVar [a]
channelList Channel a
ch) (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)
          TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (Channel a -> TVar Bool
forall a. Channel a -> TVar Bool
channelListEmpty Channel a
ch) Bool
False
     IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef (Channel a -> IORef Bool
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 =
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
  do Bool
empty <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar (Channel a -> TVar Bool
forall a. Channel a -> TVar Bool
channelListEmpty Channel a
ch)
     Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
empty STM ()
forall a. STM a
retry