diff --git a/dejafu/Control/Concurrent/STM/Classy.hs b/dejafu/Control/Concurrent/STM/Classy.hs index 956cb3a..e268f7c 100644 --- a/dejafu/Control/Concurrent/STM/Classy.hs +++ b/dejafu/Control/Concurrent/STM/Classy.hs @@ -3,8 +3,10 @@ module Control.Concurrent.STM.Classy ( module Control.Monad.STM.Class , module Control.Concurrent.STM.Classy.TVar , module Control.Concurrent.STM.Classy.TMVar + , module Control.Concurrent.STM.Classy.TChan ) where import Control.Monad.STM.Class import Control.Concurrent.STM.Classy.TVar import Control.Concurrent.STM.Classy.TMVar +import Control.Concurrent.STM.Classy.TChan diff --git a/dejafu/Control/Concurrent/STM/Classy/TChan.hs b/dejafu/Control/Concurrent/STM/Classy/TChan.hs new file mode 100644 index 0000000..2572231 --- /dev/null +++ b/dejafu/Control/Concurrent/STM/Classy/TChan.hs @@ -0,0 +1,122 @@ +-- | Transactional channels +module Control.Concurrent.STM.Classy.TChan + ( -- * TChans + TChan + + -- * Construction + , newTChan + , newBroadcastTChan + , dupTChan + , cloneTChan + + -- * Reading and writing + , readTChan + , tryReadTChan + , peekTChan + , tryPeekTChan + , writeTChan + , unGetTChan + , isEmptyTChan + ) where + +import Control.Monad.STM.Class + +-- | 'TChan' is an abstract type representing an unbounded FIFO +-- channel. +data TChan stm a = TChan (TVar stm (TVarList stm a)) + (TVar stm (TVarList stm a)) + +type TVarList stm a = TVar stm (TList stm a) +data TList stm a = TNil | TCons a (TVarList stm a) + +-- |Build and return a new instance of 'TChan' +newTChan :: MonadSTM stm => stm (TChan stm a) +newTChan = do + hole <- newTVar TNil + readH <- newTVar hole + writeH <- newTVar hole + pure (TChan readH writeH) + +-- | Create a write-only 'TChan'. More precisely, 'readTChan' will 'retry' +-- even after items have been written to the channel. The only way to +-- read a broadcast channel is to duplicate it with 'dupTChan'. +newBroadcastTChan :: MonadSTM stm => stm (TChan stm a) +newBroadcastTChan = do + hole <- newTVar TNil + readT <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first") + writeT <- newTVar hole + pure (TChan readT writeT) + +-- | Write a value to a 'TChan'. +writeTChan :: MonadSTM stm => TChan stm a -> a -> stm () +writeTChan (TChan _ writeT) a = do + listend <- readTVar writeT + listend' <- newTVar TNil + writeTVar listend (TCons a listend') + writeTVar writeT listend' + +-- | Read the next value from the 'TChan'. +readTChan :: MonadSTM stm => TChan stm a -> stm a +readTChan tchan = tryReadTChan tchan >>= maybe retry pure + +-- | A version of 'readTChan' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a) +tryReadTChan (TChan readT _) = do + listhead <- readTVar readT + hd <- readTVar listhead + case hd of + TNil -> pure Nothing + TCons a tl -> do + writeTVar readT tl + pure (Just a) + +-- | Get the next value from the 'TChan' without removing it, +-- retrying if the channel is empty. +peekTChan :: MonadSTM stm => TChan stm a -> stm a +peekTChan tchan = tryPeekTChan tchan >>= maybe retry pure + +-- | A version of 'peekTChan' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryPeekTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a) +tryPeekTChan (TChan readT _) = do + listhead <- readTVar readT + hd <- readTVar listhead + pure $ case hd of + TNil -> Nothing + TCons a _ -> Just a + +-- | Duplicate a 'TChan': the duplicate channel begins empty, but data written to +-- either channel from then on will be available from both. Hence +-- this creates a kind of broadcast channel, where data written by +-- anyone is seen by everyone else. +dupTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a) +dupTChan (TChan _ writeT) = do + hole <- readTVar writeT + readT' <- newTVar hole + return (TChan readT' writeT) + +-- | Put a data item back onto a channel, where it will be the next +-- item read. +unGetTChan :: MonadSTM stm => TChan stm a -> a -> stm () +unGetTChan (TChan readT _) a = do + listhead <- readTVar readT + head' <- newTVar (TCons a listhead) + writeTVar readT head' + +-- | Returns 'True' if the supplied 'TChan' is empty. +isEmptyTChan :: MonadSTM stm => TChan stm a -> stm Bool +isEmptyTChan (TChan readT _) = do + listhead <- readTVar readT + hd <- readTVar listhead + pure $ case hd of + TNil -> True + TCons _ _ -> False + +-- | Clone a 'TChan': similar to 'dupTChan', but the cloned channel starts with the +-- same content available as the original channel. +cloneTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a) +cloneTChan (TChan readT writeT) = do + readpos <- readTVar readT + readT' <- newTVar readpos + pure (TChan readT' writeT) diff --git a/dejafu/dejafu.cabal b/dejafu/dejafu.cabal index 9a89a7d..230e684 100755 --- a/dejafu/dejafu.cabal +++ b/dejafu/dejafu.cabal @@ -88,6 +88,7 @@ library , Control.Concurrent.STM.Classy , Control.Concurrent.STM.Classy.TVar , Control.Concurrent.STM.Classy.TMVar + , Control.Concurrent.STM.Classy.TChan , Test.DejaFu , Test.DejaFu.Deterministic