blob: a562bc586845d24bbce90ae363789e3dab706419 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
{-# LANGUAGE CPP #-}
module LockedChan
( LockedChan
, cloneLChan
, newLockedChan
, peekLChan
, unlockChan
, writeLChan )
where
import Control.Monad.STM
import Control.Concurrent.STM
data LockedChan a = LockedChan
{ lock :: TVar Bool
, chan :: TChan a
}
unlockChan :: LockedChan a -> IO (TChan a)
unlockChan c = do
waslocked <- atomically $ swapTVar (lock c) False
if waslocked
then return (chan c)
else error "Attempt to read unlocked channel"
writeLChan :: LockedChan a -> a -> STM ()
writeLChan c a = writeTChan (chan c) a
-- This one blocks rather than throwing an exception...
-- todo: probably this should be changed to conform to the rest
-- of the api.
peekLChan :: LockedChan a -> STM a
peekLChan c = do
readTVar (lock c) >>= check
peekTChan (chan c)
newLockedChan :: STM (LockedChan a)
newLockedChan = do
lock <- newTVar True
chan <- newTChan
return $ LockedChan lock chan
cloneLChan :: LockedChan a -> IO (LockedChan a)
cloneLChan c = do
mchan <- atomically $ do
locked <- readTVar (lock c)
if locked
then fmap Just $ do
c2 <- cloneTChan (chan c)
l2 <- newTVar True
return $ LockedChan l2 c2
else return Nothing
return $ maybe (error "Attempt to clone unlocked channel")
id
mchan
#if MIN_VERSION_stm(2,4,0)
#else
-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the
-- same content available as the original channel.
--
-- Terrible inefficient implementation provided to build against older libraries.
cloneTChan :: TChan a -> STM (TChan a)
cloneTChan chan = do
contents <- chanContents' chan
chan2 <- dupTChan chan
mapM_ (writeTChan chan) contents
return chan2
where
chanContents' chan = do
b <- isEmptyTChan chan
if b then return [] else do
x <- readTChan chan
xs <- chanContents' chan
return (x:xs)
#endif
|
