Skip to content

Commit d26aaa2

Browse files
cootcoot
committed
MonadSTM: added TChan
Fixes #2586
1 parent f28bba5 commit d26aaa2

File tree

2 files changed

+272
-19
lines changed

2 files changed

+272
-19
lines changed

‎io-classes/src/Control/Monad/Class/MonadSTM.hs

Lines changed: 269 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,8 @@ module Control.Monad.Class.MonadSTM
3636
, TArrayDefault (..)
3737
-- * Default 'TSem' implementation
3838
, TSemDefault (..)
39+
-- * Default 'TChan' implementation
40+
, TChanDefault (..)
3941
-- * MonadThrow aliases
4042
, throwSTM
4143
, catchSTM
@@ -52,6 +54,7 @@ module Control.Monad.Class.MonadSTM
5254
import Prelude hiding (read)
5355

5456
import qualified Control.Concurrent.STM.TArray as STM
57+
import qualified Control.Concurrent.STM.TChan as STM
5558
import qualified Control.Concurrent.STM.TBQueue as STM
5659
import qualified Control.Concurrent.STM.TMVar as STM
5760
import qualified Control.Concurrent.STM.TQueue as STM
@@ -169,14 +172,30 @@ class ( Monad m
169172
signalTSem :: TSem m -> STM m ()
170173
signalTSemN :: Natural -> TSem m -> STM m ()
171174

175+
type TChan m :: Type -> Type
176+
newTChan :: STM m (TChan m a)
177+
newBroadcastTChan :: STM m (TChan m a)
178+
dupTChan :: TChan m a -> STM m (TChan m a)
179+
cloneTChan :: TChan m a -> STM m (TChan m a)
180+
readTChan :: TChan m a -> STM m a
181+
tryReadTChan :: TChan m a -> STM m (Maybe a)
182+
peekTChan :: TChan m a -> STM m a
183+
tryPeekTChan :: TChan m a -> STM m (Maybe a)
184+
writeTChan :: TChan m a -> a -> STM m ()
185+
unGetTChan :: TChan m a -> a -> STM m ()
186+
isEmptyTChan :: TChan m a -> STM m Bool
187+
188+
172189
-- Helpful derived functions with default implementations
173190

174-
newTVarIO :: a -> m (TVar m a)
175-
readTVarIO :: TVar m a -> m a
176-
newTMVarIO :: a -> m (TMVar m a)
177-
newEmptyTMVarIO :: m (TMVar m a)
178-
newTQueueIO :: m (TQueue m a)
179-
newTBQueueIO :: Natural -> m (TBQueue m a)
191+
newTVarIO :: a -> m (TVar m a)
192+
readTVarIO :: TVar m a -> m a
193+
newTMVarIO :: a -> m (TMVar m a)
194+
newEmptyTMVarIO :: m (TMVar m a)
195+
newTQueueIO :: m (TQueue m a)
196+
newTBQueueIO :: Natural -> m (TBQueue m a)
197+
newTChanIO :: m (TChan m a)
198+
newBroadcastTChanIO :: m (TChan m a)
180199

181200
--
182201
-- default implementations
@@ -190,12 +209,14 @@ class ( Monad m
190209
=> STM m (TMVar m a)
191210
newEmptyTMVar = newEmptyTMVarDefault
192211

193-
newTVarIO = atomically . newTVar
194-
readTVarIO = atomically . readTVar
195-
newTMVarIO = atomically . newTMVar
196-
newEmptyTMVarIO = atomically newEmptyTMVar
197-
newTQueueIO = atomically newTQueue
198-
newTBQueueIO = atomically . newTBQueue
212+
newTVarIO = atomically . newTVar
213+
readTVarIO = atomically . readTVar
214+
newTMVarIO = atomically . newTMVar
215+
newEmptyTMVarIO = atomically newEmptyTMVar
216+
newTQueueIO = atomically newTQueue
217+
newTBQueueIO = atomically . newTBQueue
218+
newTChanIO = atomically newTChan
219+
newBroadcastTChanIO = atomically newBroadcastTChan
199220

200221
default takeTMVar :: TMVar m ~ TMVarDefault m
201222
=> TMVar m a -> STM m a
@@ -319,6 +340,50 @@ class ( Monad m
319340
=> Natural -> TSem m -> STM m ()
320341
signalTSemN = signalTSemNDefault
321342

343+
default newTChan :: TChan m ~ TChanDefault m
344+
=> STM m (TChan m a)
345+
newTChan = newTChanDefault
346+
347+
default newBroadcastTChan :: TChan m ~ TChanDefault m
348+
=> STM m (TChan m a)
349+
newBroadcastTChan = newBroadcastTChanDefault
350+
351+
default writeTChan :: TChan m ~ TChanDefault m
352+
=> TChan m a -> a -> STM m ()
353+
writeTChan = writeTChanDefault
354+
355+
default readTChan :: TChan m ~ TChanDefault m
356+
=> TChan m a -> STM m a
357+
readTChan = readTChanDefault
358+
359+
default tryReadTChan :: TChan m ~ TChanDefault m
360+
=> TChan m a -> STM m (Maybe a)
361+
tryReadTChan = tryReadTChanDefault
362+
363+
default peekTChan :: TChan m ~ TChanDefault m
364+
=> TChan m a -> STM m a
365+
peekTChan = peekTChanDefault
366+
367+
default tryPeekTChan :: TChan m ~ TChanDefault m
368+
=> TChan m a -> STM m (Maybe a)
369+
tryPeekTChan = tryPeekTChanDefault
370+
371+
default dupTChan :: TChan m ~ TChanDefault m
372+
=> TChan m a -> STM m (TChan m a)
373+
dupTChan = dupTChanDefault
374+
375+
default unGetTChan :: TChan m ~ TChanDefault m
376+
=> TChan m a -> a -> STM m ()
377+
unGetTChan = unGetTChanDefault
378+
379+
default isEmptyTChan :: TChan m ~ TChanDefault m
380+
=> TChan m a -> STM m Bool
381+
isEmptyTChan = isEmptyTChanDefault
382+
383+
default cloneTChan :: TChan m ~ TChanDefault m
384+
=> TChan m a -> STM m (TChan m a)
385+
cloneTChan = cloneTChanDefault
386+
322387

323388
stateTVarDefault :: MonadSTM m => TVar m s -> (s -> (a, s)) -> STM m a
324389
stateTVarDefault var f = do
@@ -596,6 +661,7 @@ instance MonadSTM IO where
596661
type TBQueue IO = STM.TBQueue
597662
type TArray IO = STM.TArray
598663
type TSem IO = STM.TSem
664+
type TChan IO = STM.TChan
599665

600666
newTVar = STM.newTVar
601667
readTVar = STM.readTVar
@@ -641,12 +707,26 @@ instance MonadSTM IO where
641707
signalTSem = STM.signalTSem
642708
signalTSemN = STM.signalTSemN
643709

644-
newTVarIO = STM.newTVarIO
645-
readTVarIO = STM.readTVarIO
646-
newTMVarIO = STM.newTMVarIO
647-
newEmptyTMVarIO = STM.newEmptyTMVarIO
648-
newTQueueIO = STM.newTQueueIO
649-
newTBQueueIO = STM.newTBQueueIO
710+
newTChan = STM.newTChan
711+
newBroadcastTChan = STM.newBroadcastTChan
712+
dupTChan = STM.dupTChan
713+
cloneTChan = STM.cloneTChan
714+
readTChan = STM.readTChan
715+
tryReadTChan = STM.tryReadTChan
716+
peekTChan = STM.peekTChan
717+
tryPeekTChan = STM.tryPeekTChan
718+
writeTChan = STM.writeTChan
719+
unGetTChan = STM.unGetTChan
720+
isEmptyTChan = STM.isEmptyTChan
721+
722+
newTVarIO = STM.newTVarIO
723+
readTVarIO = STM.readTVarIO
724+
newTMVarIO = STM.newTMVarIO
725+
newEmptyTMVarIO = STM.newEmptyTMVarIO
726+
newTQueueIO = STM.newTQueueIO
727+
newTBQueueIO = STM.newTBQueueIO
728+
newTChanIO = STM.newTChanIO
729+
newBroadcastTChanIO = STM.newBroadcastTChanIO
650730

651731
-- | noop instance
652732
--
@@ -1084,6 +1164,99 @@ signalTSemNDefault n (TSem t) = do
10841164
i <- readTVar t
10851165
writeTVar t $! i+(toInteger n)
10861166

1167+
--
1168+
-- Default `TChan` implementation
1169+
--
1170+
1171+
type TVarList m a = TVar m (TList m a)
1172+
data TList m a = TNil | TCons a (TVarList m a)
1173+
1174+
data TChanDefault m a = TChan (TVar m (TVarList m a)) (TVar m (TVarList m a))
1175+
1176+
newTChanDefault :: MonadSTM m => STM m (TChanDefault m a)
1177+
newTChanDefault = do
1178+
hole <- newTVar TNil
1179+
read <- newTVar hole
1180+
write <- newTVar hole
1181+
return (TChan read write)
1182+
1183+
newBroadcastTChanDefault :: MonadSTM m => STM m (TChanDefault m a)
1184+
newBroadcastTChanDefault = do
1185+
write_hole <- newTVar TNil
1186+
read <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first")
1187+
write <- newTVar write_hole
1188+
return (TChan read write)
1189+
1190+
writeTChanDefault :: MonadSTM m => TChanDefault m a -> a -> STM m ()
1191+
writeTChanDefault (TChan _read write) a = do
1192+
listend <- readTVar write -- listend == TVar pointing to TNil
1193+
new_listend <- newTVar TNil
1194+
writeTVar listend (TCons a new_listend)
1195+
writeTVar write new_listend
1196+
1197+
readTChanDefault :: MonadSTM m => TChanDefault m a -> STM m a
1198+
readTChanDefault (TChan read _write) = do
1199+
listhead <- readTVar read
1200+
head_ <- readTVar listhead
1201+
case head_ of
1202+
TNil -> retry
1203+
TCons a tail_ -> do
1204+
writeTVar read tail_
1205+
return a
1206+
1207+
tryReadTChanDefault :: MonadSTM m => TChanDefault m a -> STM m (Maybe a)
1208+
tryReadTChanDefault (TChan read _write) = do
1209+
listhead <- readTVar read
1210+
head_ <- readTVar listhead
1211+
case head_ of
1212+
TNil -> return Nothing
1213+
TCons a tl -> do
1214+
writeTVar read tl
1215+
return (Just a)
1216+
1217+
peekTChanDefault :: MonadSTM m => TChanDefault m a -> STM m a
1218+
peekTChanDefault (TChan read _write) = do
1219+
listhead <- readTVar read
1220+
head_ <- readTVar listhead
1221+
case head_ of
1222+
TNil -> retry
1223+
TCons a _ -> return a
1224+
1225+
tryPeekTChanDefault :: MonadSTM m => TChanDefault m a -> STM m (Maybe a)
1226+
tryPeekTChanDefault (TChan read _write) = do
1227+
listhead <- readTVar read
1228+
head_ <- readTVar listhead
1229+
case head_ of
1230+
TNil -> return Nothing
1231+
TCons a _ -> return (Just a)
1232+
1233+
dupTChanDefault :: MonadSTM m => TChanDefault m a -> STM m (TChanDefault m a)
1234+
dupTChanDefault (TChan _read write) = do
1235+
hole <- readTVar write
1236+
new_read <- newTVar hole
1237+
return (TChan new_read write)
1238+
1239+
unGetTChanDefault :: MonadSTM m => TChanDefault m a -> a -> STM m ()
1240+
unGetTChanDefault (TChan read _write) a = do
1241+
listhead <- readTVar read
1242+
newhead <- newTVar (TCons a listhead)
1243+
writeTVar read newhead
1244+
1245+
isEmptyTChanDefault :: MonadSTM m => TChanDefault m a -> STM m Bool
1246+
isEmptyTChanDefault (TChan read _write) = do
1247+
listhead <- readTVar read
1248+
head_ <- readTVar listhead
1249+
case head_ of
1250+
TNil -> return True
1251+
TCons _ _ -> return False
1252+
1253+
cloneTChanDefault :: MonadSTM m => TChanDefault m a -> STM m (TChanDefault m a)
1254+
cloneTChanDefault (TChan read write) = do
1255+
readpos <- readTVar read
1256+
new_read <- newTVar readpos
1257+
return (TChan new_read write)
1258+
1259+
10871260
-- | 'throwIO' specialised to @stm@ monad.
10881261
--
10891262
throwSTM :: (MonadSTM m, MonadThrow.MonadThrow (STM m), Exception e)
@@ -1203,6 +1376,19 @@ instance MonadSTM m => MonadSTM (ContT r m) where
12031376
signalTSem = WrappedSTM . signalTSem
12041377
signalTSemN = WrappedSTM .: signalTSemN
12051378

1379+
type TChan (ContT r m) = TChan m
1380+
newTChan = WrappedSTM newTChan
1381+
newBroadcastTChan = WrappedSTM newBroadcastTChan
1382+
dupTChan = WrappedSTM . dupTChan
1383+
cloneTChan = WrappedSTM . cloneTChan
1384+
readTChan = WrappedSTM . readTChan
1385+
tryReadTChan = WrappedSTM . tryReadTChan
1386+
peekTChan = WrappedSTM . peekTChan
1387+
tryPeekTChan = WrappedSTM . tryPeekTChan
1388+
writeTChan = WrappedSTM .: writeTChan
1389+
unGetTChan = WrappedSTM .: unGetTChan
1390+
isEmptyTChan = WrappedSTM . isEmptyTChan
1391+
12061392

12071393
instance MonadSTM m => MonadSTM (ReaderT r m) where
12081394
type STM (ReaderT r m) = WrappedSTM Reader r m
@@ -1264,6 +1450,19 @@ instance MonadSTM m => MonadSTM (ReaderT r m) where
12641450
signalTSem = WrappedSTM . signalTSem
12651451
signalTSemN = WrappedSTM .: signalTSemN
12661452

1453+
type TChan (ReaderT r m) = TChan m
1454+
newTChan = WrappedSTM newTChan
1455+
newBroadcastTChan = WrappedSTM newBroadcastTChan
1456+
dupTChan = WrappedSTM . dupTChan
1457+
cloneTChan = WrappedSTM . cloneTChan
1458+
readTChan = WrappedSTM . readTChan
1459+
tryReadTChan = WrappedSTM . tryReadTChan
1460+
peekTChan = WrappedSTM . peekTChan
1461+
tryPeekTChan = WrappedSTM . tryPeekTChan
1462+
writeTChan = WrappedSTM .: writeTChan
1463+
unGetTChan = WrappedSTM .: unGetTChan
1464+
isEmptyTChan = WrappedSTM . isEmptyTChan
1465+
12671466

12681467
instance (Monoid w, MonadSTM m) => MonadSTM (WriterT w m) where
12691468
type STM (WriterT w m) = WrappedSTM Writer w m
@@ -1325,6 +1524,19 @@ instance (Monoid w, MonadSTM m) => MonadSTM (WriterT w m) where
13251524
signalTSem = WrappedSTM . signalTSem
13261525
signalTSemN = WrappedSTM .: signalTSemN
13271526

1527+
type TChan (WriterT w m) = TChan m
1528+
newTChan = WrappedSTM newTChan
1529+
newBroadcastTChan = WrappedSTM newBroadcastTChan
1530+
dupTChan = WrappedSTM . dupTChan
1531+
cloneTChan = WrappedSTM . cloneTChan
1532+
readTChan = WrappedSTM . readTChan
1533+
tryReadTChan = WrappedSTM . tryReadTChan
1534+
peekTChan = WrappedSTM . peekTChan
1535+
tryPeekTChan = WrappedSTM . tryPeekTChan
1536+
writeTChan = WrappedSTM .: writeTChan
1537+
unGetTChan = WrappedSTM .: unGetTChan
1538+
isEmptyTChan = WrappedSTM . isEmptyTChan
1539+
13281540

13291541
instance MonadSTM m => MonadSTM (StateT s m) where
13301542
type STM (StateT s m) = WrappedSTM State s m
@@ -1386,6 +1598,19 @@ instance MonadSTM m => MonadSTM (StateT s m) where
13861598
signalTSem = WrappedSTM . signalTSem
13871599
signalTSemN = WrappedSTM .: signalTSemN
13881600

1601+
type TChan (StateT s m) = TChan m
1602+
newTChan = WrappedSTM newTChan
1603+
newBroadcastTChan = WrappedSTM newBroadcastTChan
1604+
dupTChan = WrappedSTM . dupTChan
1605+
cloneTChan = WrappedSTM . cloneTChan
1606+
readTChan = WrappedSTM . readTChan
1607+
tryReadTChan = WrappedSTM . tryReadTChan
1608+
peekTChan = WrappedSTM . peekTChan
1609+
tryPeekTChan = WrappedSTM . tryPeekTChan
1610+
writeTChan = WrappedSTM .: writeTChan
1611+
unGetTChan = WrappedSTM .: unGetTChan
1612+
isEmptyTChan = WrappedSTM . isEmptyTChan
1613+
13891614

13901615
instance MonadSTM m => MonadSTM (ExceptT e m) where
13911616
type STM (ExceptT e m) = WrappedSTM Except e m
@@ -1447,6 +1672,19 @@ instance MonadSTM m => MonadSTM (ExceptT e m) where
14471672
signalTSem = WrappedSTM . signalTSem
14481673
signalTSemN = WrappedSTM .: signalTSemN
14491674

1675+
type TChan (ExceptT e m) = TChan m
1676+
newTChan = WrappedSTM newTChan
1677+
newBroadcastTChan = WrappedSTM newBroadcastTChan
1678+
dupTChan = WrappedSTM . dupTChan
1679+
cloneTChan = WrappedSTM . cloneTChan
1680+
readTChan = WrappedSTM . readTChan
1681+
tryReadTChan = WrappedSTM . tryReadTChan
1682+
peekTChan = WrappedSTM . peekTChan
1683+
tryPeekTChan = WrappedSTM . tryPeekTChan
1684+
writeTChan = WrappedSTM .: writeTChan
1685+
unGetTChan = WrappedSTM .: unGetTChan
1686+
isEmptyTChan = WrappedSTM . isEmptyTChan
1687+
14501688

14511689
instance (Monoid w, MonadSTM m) => MonadSTM (RWST r w s m) where
14521690
type STM (RWST r w s m) = WrappedSTM RWS (r, w, s) m
@@ -1508,6 +1746,19 @@ instance (Monoid w, MonadSTM m) => MonadSTM (RWST r w s m) where
15081746
signalTSem = WrappedSTM . signalTSem
15091747
signalTSemN = WrappedSTM .: signalTSemN
15101748

1749+
type TChan (RWST r w s m) = TChan m
1750+
newTChan = WrappedSTM newTChan
1751+
newBroadcastTChan = WrappedSTM newBroadcastTChan
1752+
dupTChan = WrappedSTM . dupTChan
1753+
cloneTChan = WrappedSTM . cloneTChan
1754+
readTChan = WrappedSTM . readTChan
1755+
tryReadTChan = WrappedSTM . tryReadTChan
1756+
peekTChan = WrappedSTM . peekTChan
1757+
tryPeekTChan = WrappedSTM . tryPeekTChan
1758+
writeTChan = WrappedSTM .: writeTChan
1759+
unGetTChan = WrappedSTM .: unGetTChan
1760+
isEmptyTChan = WrappedSTM . isEmptyTChan
1761+
15111762

15121763
(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
15131764
(f .: g) x y = f (g x y)

0 commit comments

Comments
 (0)