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
|
module GraphicsEvents(
Events, newEvents, getEvent, sendEvent, getTick, sendTick,
Event
) where
import GraphicsEvent( Event )
import Concurrent
( MVar, newEmptyMVar, newMVar, takeMVar, putMVar
, Chan, newChan, readChan, writeChan
)
data Events = Events { events :: Chan Event
, tick :: Flag ()
}
newEvents :: IO Events
newEvents = do
events <- newChan
tick <- newFlag
return (Events { events, tick })
getEvent :: Events -> IO Event
getEvent evs = readChan (events evs)
sendEvent :: Events -> Event -> IO ()
sendEvent evs = writeChan (events evs)
sendTick :: Events -> IO ()
sendTick evs = setFlag (tick evs) ()
getTick :: Events -> IO ()
getTick evs = resetFlag (tick evs)
----------------------------------------------------------------
-- Flags (should be a separate module)
--
-- set : sets the flag, never blocks, never fails
-- reset : block until the flag is set (and reset it)
--
----------------------------------------------------------------
-- We maintain a list of blocked processes.
-- Blocked processes are "stored" in MVars; the outer MVar
-- is used to implement a critical section.
newtype Flag a = Flag (MVar [MVar a])
newFlag :: IO (Flag a)
newFlag = do
queue <- newMVar []
return (Flag queue)
setFlag :: Flag a -> a -> IO ()
setFlag (Flag queue) a = do
ps <- takeMVar queue
mapM_ (\ p -> putMVar p a) ps
putMVar queue []
resetFlag :: Flag a -> IO a
resetFlag (Flag queue) = do
ps <- takeMVar queue
p <- newEmptyMVar
putMVar queue (p:ps)
takeMVar p -- block
|
