Control.Concurrent.STM.TChan: added tryReadTChan, peekTChan, tryPeekTChan
authorSimon Marlow <marlowsd@gmail.com>
Mon, 11 Apr 2011 10:05:54 +0000 (11:05 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 11 Apr 2011 10:05:54 +0000 (11:05 +0100)
Control/Concurrent/STM/TChan.hs
Control/Concurrent/STM/TChan.hs.orig [new file with mode: 0644]
Control/Concurrent/STM/TChan.hs.rej [new file with mode: 0644]
Control/Concurrent/STM/TMVar.hs.orig [new file with mode: 0644]
Control/Concurrent/STM/TMVar.hs.rej [new file with mode: 0644]

index f230e44..cdd62f9 100644 (file)
@@ -23,6 +23,9 @@ module Control.Concurrent.STM.TChan (
        newTChan,
        newTChanIO,
        readTChan,
+       tryReadTChan,
+       peekTChan,
+       tryPeekTChan,
        writeTChan,
        dupTChan,
        unGetTChan,
@@ -79,6 +82,36 @@ readTChan (TChan read _write) = do
        writeTVar read tail
        return a
 
+-- | Non-blocking version of 'readTChan'.
+tryReadTChan :: TChan a -> STM (Maybe a)
+tryReadTChan (TChan read _write) = do
+  listhead <- readTVar read
+  head <- readTVar listhead
+  case head of
+    TNil       -> return Nothing
+    TCons a tl -> do
+      writeTVar read tl
+      return (Just a)
+
+-- | Get the next value from the 'TChan' without removing it,
+-- blocking if the channel is empty.
+peekTChan :: TChan a -> STM a
+peekTChan (TChan read _write) = do
+  listhead <- readTVar read
+  head <- readTVar listhead
+  case head of
+    TNil      -> retry
+    TCons a _ -> return a
+
+-- | Non-blocking version of 'peekTChan'.
+tryPeekTChan :: TChan a -> STM (Maybe a)
+tryPeekTChan (TChan read _write) = do
+  listhead <- readTVar read
+  head <- readTVar listhead
+  case head of
+    TNil      -> return Nothing
+    TCons a _ -> return (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
diff --git a/Control/Concurrent/STM/TChan.hs.orig b/Control/Concurrent/STM/TChan.hs.orig
new file mode 100644 (file)
index 0000000..f230e44
--- /dev/null
@@ -0,0 +1,107 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Concurrent.STM.TChan
+-- Copyright   :  (c) The University of Glasgow 2004
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (requires STM)
+--
+-- TChan: Transactional channels
+-- (GHC only)
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.STM.TChan (
+#ifdef __GLASGOW_HASKELL__
+       -- * TChans
+       TChan,
+       newTChan,
+       newTChanIO,
+       readTChan,
+       writeTChan,
+       dupTChan,
+       unGetTChan,
+       isEmptyTChan
+#endif
+  ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc
+
+import Data.Typeable (Typeable)
+
+-- | 'TChan' is an abstract type representing an unbounded FIFO channel.
+data TChan a = TChan (TVar (TVarList a)) (TVar (TVarList a)) deriving Typeable
+
+type TVarList a = TVar (TList a)
+data TList a = TNil | TCons a (TVarList a)
+
+-- |Build and returns a new instance of 'TChan'
+newTChan :: STM (TChan a)
+newTChan = do
+  hole <- newTVar TNil
+  read <- newTVar hole
+  write <- newTVar hole
+  return (TChan read write)
+
+-- |@IO@ version of 'newTChan'.  This is useful for creating top-level
+-- 'TChan's using 'System.IO.Unsafe.unsafePerformIO', because using
+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
+-- possible.
+newTChanIO :: IO (TChan a)
+newTChanIO = do
+  hole <- newTVarIO TNil
+  read <- newTVarIO hole
+  write <- newTVarIO hole
+  return (TChan read write)
+
+-- |Write a value to a 'TChan'.
+writeTChan :: TChan a -> a -> STM ()
+writeTChan (TChan _read write) a = do
+  listend <- readTVar write -- listend == TVar pointing to TNil
+  new_listend <- newTVar TNil
+  writeTVar listend (TCons a new_listend)
+  writeTVar write new_listend
+
+-- |Read the next value from the 'TChan'.
+readTChan :: TChan a -> STM a
+readTChan (TChan read _write) = do
+  listhead <- readTVar read
+  head <- readTVar listhead
+  case head of
+    TNil -> retry
+    TCons a tail -> do
+       writeTVar read tail
+       return 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 :: TChan a -> STM (TChan a)
+dupTChan (TChan _read write) = do
+  hole <- readTVar write  
+  new_read <- newTVar hole
+  return (TChan new_read write)
+
+-- |Put a data item back onto a channel, where it will be the next item read.
+unGetTChan :: TChan a -> a -> STM ()
+unGetTChan (TChan read _write) a = do
+   listhead <- readTVar read
+   newhead <- newTVar (TCons a listhead)
+   writeTVar read newhead
+
+-- |Returns 'True' if the supplied 'TChan' is empty.
+isEmptyTChan :: TChan a -> STM Bool
+isEmptyTChan (TChan read _write) = do
+  listhead <- readTVar read
+  head <- readTVar listhead
+  case head of
+    TNil -> return True
+    TCons _ _ -> return False
+#endif
diff --git a/Control/Concurrent/STM/TChan.hs.rej b/Control/Concurrent/STM/TChan.hs.rej
new file mode 100644 (file)
index 0000000..e113bfa
--- /dev/null
@@ -0,0 +1,33 @@
+--- Control/Concurrent/STM/TChan.hs    2011-04-11 11:05:30.740727673 +0100
++++ Control/Concurrent/STM/TChan.hs    2011-04-11 11:05:30.740727673 +0100
+@@ -82,7 +82,8 @@
+       writeTVar read tail
+       return a
+--- | Non-blocking version of 'readTChan'.
++-- | A version of 'readTChan' which does not retry. Instead it
++-- returns @Nothing@ if no value is available.
+ tryReadTChan :: TChan a -> STM (Maybe a)
+ tryReadTChan (TChan read _write) = do
+   listhead <- readTVar read
+@@ -93,8 +94,8 @@
+       writeTVar read tl
+       return (Just a)
+--- | Get the next value from the 'TChan' without removing it,
+--- blocking if the channel is empty.
++-- | Get the next value from the @TChan@ without removing it,
++-- retrying if the channel is empty.
+ peekTChan :: TChan a -> STM a
+ peekTChan (TChan read _write) = do
+   listhead <- readTVar read
+@@ -103,7 +104,8 @@
+     TNil      -> retry
+     TCons a _ -> return a
+--- | Non-blocking version of 'peekTChan'.
++-- | A version of 'peekTChan' which does not retry. Instead it
++-- returns @Nothing@ if no value is available.
+ tryPeekTChan :: TChan a -> STM (Maybe a)
+ tryPeekTChan (TChan read _write) = do
+   listhead <- readTVar read
diff --git a/Control/Concurrent/STM/TMVar.hs.orig b/Control/Concurrent/STM/TMVar.hs.orig
new file mode 100644 (file)
index 0000000..0a43b0a
--- /dev/null
@@ -0,0 +1,149 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Concurrent.STM.TMVar
+-- Copyright   :  (c) The University of Glasgow 2004
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (requires STM)
+--
+-- TMVar: Transactional MVars, for use in the STM monad
+-- (GHC only)
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.STM.TMVar (
+#ifdef __GLASGOW_HASKELL__
+       -- * TMVars
+       TMVar,
+       newTMVar,
+       newEmptyTMVar,
+       newTMVarIO,
+       newEmptyTMVarIO,
+       takeTMVar,
+       putTMVar,
+       readTMVar,      
+       swapTMVar,
+       tryTakeTMVar,
+       tryPutTMVar,
+       isEmptyTMVar
+#endif
+  ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc
+
+import Data.Typeable (Typeable)
+
+newtype TMVar a = TMVar (TVar (Maybe a)) deriving (Eq, Typeable)
+{- ^
+A 'TMVar' is a synchronising variable, used
+for communication between concurrent threads.  It can be thought of
+as a box, which may be empty or full.
+-}
+
+-- |Create a 'TMVar' which contains the supplied value.
+newTMVar :: a -> STM (TMVar a)
+newTMVar a = do
+  t <- newTVar (Just a)
+  return (TMVar t)
+
+-- |@IO@ version of 'newTMVar'.  This is useful for creating top-level
+-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using
+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
+-- possible.
+newTMVarIO :: a -> IO (TMVar a)
+newTMVarIO a = do
+  t <- newTVarIO (Just a)
+  return (TMVar t)
+
+-- |Create a 'TMVar' which is initially empty.
+newEmptyTMVar :: STM (TMVar a)
+newEmptyTMVar = do
+  t <- newTVar Nothing
+  return (TMVar t)
+
+-- |@IO@ version of 'newEmptyTMVar'.  This is useful for creating top-level
+-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using
+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
+-- possible.
+newEmptyTMVarIO :: IO (TMVar a)
+newEmptyTMVarIO = do
+  t <- newTVarIO Nothing
+  return (TMVar t)
+
+-- |Return the contents of the 'TMVar'.  If the 'TMVar' is currently
+-- empty, the transaction will 'retry'.  After a 'takeTMVar', 
+-- the 'TMVar' is left empty.
+takeTMVar :: TMVar a -> STM a
+takeTMVar (TMVar t) = do
+  m <- readTVar t
+  case m of
+    Nothing -> retry
+    Just a  -> do writeTVar t Nothing; return a
+
+-- | A version of 'takeTMVar' that does not 'retry'.  The 'tryTakeTMVar'
+-- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if
+-- the 'TMVar' was full with contents @a@.  After 'tryTakeTMVar', the
+-- 'TMVar' is left empty.
+tryTakeTMVar :: TMVar a -> STM (Maybe a)
+tryTakeTMVar (TMVar t) = do
+  m <- readTVar t
+  case m of
+    Nothing -> return Nothing
+    Just a  -> do writeTVar t Nothing; return (Just a)
+
+-- |Put a value into a 'TMVar'.  If the 'TMVar' is currently full,
+-- 'putTMVar' will 'retry'.
+putTMVar :: TMVar a -> a -> STM ()
+putTMVar (TMVar t) a = do
+  m <- readTVar t
+  case m of
+    Nothing -> do writeTVar t (Just a); return ()
+    Just _  -> retry
+
+-- | A version of 'putTMVar' that does not 'retry'.  The 'tryPutTMVar'
+-- function attempts to put the value @a@ into the 'TMVar', returning
+-- 'True' if it was successful, or 'False' otherwise.
+tryPutTMVar :: TMVar a -> a -> STM Bool
+tryPutTMVar (TMVar t) a = do
+  m <- readTVar t
+  case m of
+    Nothing -> do writeTVar t (Just a); return True
+    Just _  -> return False
+
+{-|
+  This is a combination of 'takeTMVar' and 'putTMVar'; ie. it takes the value
+  from the 'TMVar', puts it back, and also returns it.
+-}
+readTMVar :: TMVar a -> STM a
+readTMVar (TMVar t) = do
+  m <- readTVar t
+  case m of
+    Nothing -> retry
+    Just a  -> return a
+
+-- |Swap the contents of a 'TMVar' for a new value.
+swapTMVar :: TMVar a -> a -> STM a
+swapTMVar (TMVar t) new = do
+  m <- readTVar t
+  case m of
+    Nothing -> retry
+    Just old -> do writeTVar t (Just new); return old
+
+-- |Check whether a given 'TMVar' is empty.
+--
+-- Notice that the boolean value returned  is just a snapshot of
+-- the state of the 'TMVar'. By the time you get to react on its result,
+-- the 'TMVar' may have been filled (or emptied) - so be extremely
+-- careful when using this operation.   Use 'tryTakeTMVar' instead if possible.
+isEmptyTMVar :: TMVar a -> STM Bool
+isEmptyTMVar (TMVar t) = do
+  m <- readTVar t
+  case m of
+    Nothing -> return True
+    Just _  -> return False
+#endif
diff --git a/Control/Concurrent/STM/TMVar.hs.rej b/Control/Concurrent/STM/TMVar.hs.rej
new file mode 100644 (file)
index 0000000..436e8db
--- /dev/null
@@ -0,0 +1,12 @@
+--- Control/Concurrent/STM/TMVar.hs    2011-04-11 11:05:30.740727673 +0100
++++ Control/Concurrent/STM/TMVar.hs    2011-04-11 11:05:30.750728046 +0100
+@@ -126,7 +126,8 @@
+     Nothing -> retry
+     Just a  -> return a
+--- | Non-blocking version of 'readTMVar'.
++-- | A version of 'readTMVar' which does not retry. Instead it
++-- returns @Nothing@ if no value is available.
+ tryReadTMVar :: TMVar a -> STM (Maybe a)
+ tryReadTMVar (TMVar t) = readTVar t