aea517689b4268532a3ffcc7a6f86a5bc123e74e
[packages/stm.git] / Control / Concurrent / STM / TChan.hs
1 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2 {-# LANGUAGE CPP, DeriveDataTypeable #-}
3
4 #if __GLASGOW_HASKELL__ >= 701
5 {-# LANGUAGE Trustworthy #-}
6 #endif
7
8 -----------------------------------------------------------------------------
9 -- |
10 -- Module : Control.Concurrent.STM.TChan
11 -- Copyright : (c) The University of Glasgow 2004
12 -- License : BSD-style (see the file libraries/base/LICENSE)
13 --
14 -- Maintainer : libraries@haskell.org
15 -- Stability : experimental
16 -- Portability : non-portable (requires STM)
17 --
18 -- TChan: Transactional channels
19 -- (GHC only)
20 --
21 -----------------------------------------------------------------------------
22
23 module Control.Concurrent.STM.TChan (
24 #ifdef __GLASGOW_HASKELL__
25 -- * TChans
26 TChan,
27 newTChan,
28 newTChanIO,
29 readTChan,
30 tryReadTChan,
31 peekTChan,
32 tryPeekTChan,
33 writeTChan,
34 dupTChan,
35 unGetTChan,
36 isEmptyTChan,
37 cloneTChan
38 #endif
39 ) where
40
41 #ifdef __GLASGOW_HASKELL__
42 import GHC.Conc
43
44 import Data.Typeable (Typeable)
45
46 -- | 'TChan' is an abstract type representing an unbounded FIFO channel.
47 data TChan a = TChan (TVar (TVarList a)) (TVar (TVarList a)) deriving Typeable
48
49 type TVarList a = TVar (TList a)
50 data TList a = TNil | TCons a (TVarList a)
51
52 -- |Build and returns a new instance of 'TChan'
53 newTChan :: STM (TChan a)
54 newTChan = do
55 hole <- newTVar TNil
56 read <- newTVar hole
57 write <- newTVar hole
58 return (TChan read write)
59
60 -- |@IO@ version of 'newTChan'. This is useful for creating top-level
61 -- 'TChan's using 'System.IO.Unsafe.unsafePerformIO', because using
62 -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
63 -- possible.
64 newTChanIO :: IO (TChan a)
65 newTChanIO = do
66 hole <- newTVarIO TNil
67 read <- newTVarIO hole
68 write <- newTVarIO hole
69 return (TChan read write)
70
71 -- |Write a value to a 'TChan'.
72 writeTChan :: TChan a -> a -> STM ()
73 writeTChan (TChan _read write) a = do
74 listend <- readTVar write -- listend == TVar pointing to TNil
75 new_listend <- newTVar TNil
76 writeTVar listend (TCons a new_listend)
77 writeTVar write new_listend
78
79 -- |Read the next value from the 'TChan'.
80 readTChan :: TChan a -> STM a
81 readTChan (TChan read _write) = do
82 listhead <- readTVar read
83 head <- readTVar listhead
84 case head of
85 TNil -> retry
86 TCons a tail -> do
87 writeTVar read tail
88 return a
89
90 -- | A version of 'readTChan' which does not retry. Instead it
91 -- returns @Nothing@ if no value is available.
92 tryReadTChan :: TChan a -> STM (Maybe a)
93 tryReadTChan (TChan read _write) = do
94 listhead <- readTVar read
95 head <- readTVar listhead
96 case head of
97 TNil -> return Nothing
98 TCons a tl -> do
99 writeTVar read tl
100 return (Just a)
101
102 -- | Get the next value from the @TChan@ without removing it,
103 -- retrying if the channel is empty.
104 peekTChan :: TChan a -> STM a
105 peekTChan (TChan read _write) = do
106 listhead <- readTVar read
107 head <- readTVar listhead
108 case head of
109 TNil -> retry
110 TCons a _ -> return a
111
112 -- | A version of 'peekTChan' which does not retry. Instead it
113 -- returns @Nothing@ if no value is available.
114 tryPeekTChan :: TChan a -> STM (Maybe a)
115 tryPeekTChan (TChan read _write) = do
116 listhead <- readTVar read
117 head <- readTVar listhead
118 case head of
119 TNil -> return Nothing
120 TCons a _ -> return (Just a)
121
122 -- |Duplicate a 'TChan': the duplicate channel begins empty, but data written to
123 -- either channel from then on will be available from both. Hence this creates
124 -- a kind of broadcast channel, where data written by anyone is seen by
125 -- everyone else.
126 dupTChan :: TChan a -> STM (TChan a)
127 dupTChan (TChan _read write) = do
128 hole <- readTVar write
129 new_read <- newTVar hole
130 return (TChan new_read write)
131
132 -- |Put a data item back onto a channel, where it will be the next item read.
133 unGetTChan :: TChan a -> a -> STM ()
134 unGetTChan (TChan read _write) a = do
135 listhead <- readTVar read
136 newhead <- newTVar (TCons a listhead)
137 writeTVar read newhead
138
139 -- |Returns 'True' if the supplied 'TChan' is empty.
140 isEmptyTChan :: TChan a -> STM Bool
141 isEmptyTChan (TChan read _write) = do
142 listhead <- readTVar read
143 head <- readTVar listhead
144 case head of
145 TNil -> return True
146 TCons _ _ -> return False
147
148 -- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the
149 -- same content available as the original channel.
150 cloneTChan :: TChan a -> STM (TChan a)
151 cloneTChan (TChan read write) = do
152 readpos <- readTVar read
153 new_read <- newTVar readpos
154 return (TChan new_read write)
155 #endif