f230e44fabf2c20e4ecb54a26fcab673939d3755
[packages/stm.git] / Control / Concurrent / STM / TChan.hs
1 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module : Control.Concurrent.STM.TChan
7 -- Copyright : (c) The University of Glasgow 2004
8 -- License : BSD-style (see the file libraries/base/LICENSE)
9 --
10 -- Maintainer : libraries@haskell.org
11 -- Stability : experimental
12 -- Portability : non-portable (requires STM)
13 --
14 -- TChan: Transactional channels
15 -- (GHC only)
16 --
17 -----------------------------------------------------------------------------
18
19 module Control.Concurrent.STM.TChan (
20 #ifdef __GLASGOW_HASKELL__
21 -- * TChans
22 TChan,
23 newTChan,
24 newTChanIO,
25 readTChan,
26 writeTChan,
27 dupTChan,
28 unGetTChan,
29 isEmptyTChan
30 #endif
31 ) where
32
33 #ifdef __GLASGOW_HASKELL__
34 import GHC.Conc
35
36 import Data.Typeable (Typeable)
37
38 -- | 'TChan' is an abstract type representing an unbounded FIFO channel.
39 data TChan a = TChan (TVar (TVarList a)) (TVar (TVarList a)) deriving Typeable
40
41 type TVarList a = TVar (TList a)
42 data TList a = TNil | TCons a (TVarList a)
43
44 -- |Build and returns a new instance of 'TChan'
45 newTChan :: STM (TChan a)
46 newTChan = do
47 hole <- newTVar TNil
48 read <- newTVar hole
49 write <- newTVar hole
50 return (TChan read write)
51
52 -- |@IO@ version of 'newTChan'. This is useful for creating top-level
53 -- 'TChan's using 'System.IO.Unsafe.unsafePerformIO', because using
54 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
55 -- possible.
56 newTChanIO :: IO (TChan a)
57 newTChanIO = do
58 hole <- newTVarIO TNil
59 read <- newTVarIO hole
60 write <- newTVarIO hole
61 return (TChan read write)
62
63 -- |Write a value to a 'TChan'.
64 writeTChan :: TChan a -> a -> STM ()
65 writeTChan (TChan _read write) a = do
66 listend <- readTVar write -- listend == TVar pointing to TNil
67 new_listend <- newTVar TNil
68 writeTVar listend (TCons a new_listend)
69 writeTVar write new_listend
70
71 -- |Read the next value from the 'TChan'.
72 readTChan :: TChan a -> STM a
73 readTChan (TChan read _write) = do
74 listhead <- readTVar read
75 head <- readTVar listhead
76 case head of
77 TNil -> retry
78 TCons a tail -> do
79 writeTVar read tail
80 return a
81
82 -- |Duplicate a 'TChan': the duplicate channel begins empty, but data written to
83 -- either channel from then on will be available from both. Hence this creates
84 -- a kind of broadcast channel, where data written by anyone is seen by
85 -- everyone else.
86 dupTChan :: TChan a -> STM (TChan a)
87 dupTChan (TChan _read write) = do
88 hole <- readTVar write
89 new_read <- newTVar hole
90 return (TChan new_read write)
91
92 -- |Put a data item back onto a channel, where it will be the next item read.
93 unGetTChan :: TChan a -> a -> STM ()
94 unGetTChan (TChan read _write) a = do
95 listhead <- readTVar read
96 newhead <- newTVar (TCons a listhead)
97 writeTVar read newhead
98
99 -- |Returns 'True' if the supplied 'TChan' is empty.
100 isEmptyTChan :: TChan a -> STM Bool
101 isEmptyTChan (TChan read _write) = do
102 listhead <- readTVar read
103 head <- readTVar listhead
104 case head of
105 TNil -> return True
106 TCons _ _ -> return False
107 #endif