]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/IOClockworks.hs
Edit change log.
[tmp/julm/arpeggigon.git] / src / RMCA / IOClockworks.hs
1 {-# LANGUAGE MultiParamTypeClasses #-}
2
3 module RMCA.IOClockworks ( IOMetronome
4 , mkClockGeneric
5 , mkClock
6 , mkClockDebug
7 , stopIOMetronome
8 , IOTick
9 , newIOTick
10 , tickIOTick
11 ) where
12
13 import Control.Concurrent
14 import Control.Monad
15 import Data.ReactiveValue
16 import FRP.Yampa (DTime)
17
18 -- A reactive value carrying unit that ticks at a regular pace. On a
19 -- tick, it executes IO actions attached to it with
20 -- reactiveValueOnCanRead.
21 newtype IOMetronome = IOMetronome (MVar [IO ()], ThreadId)
22
23 instance ReactiveValueRead IOMetronome () IO where
24 reactiveValueRead _ = return ()
25 reactiveValueOnCanRead (IOMetronome (mvar,_)) io =
26 modifyMVar_ mvar (\cbs -> return (cbs ++ [io]))
27
28 -- Make a clock that will execute any IO when it updates.
29 mkClockGeneric :: IO () -> DTime -> IO IOMetronome
30 mkClockGeneric io d = do
31 n <- newMVar []
32 tid <- forkIO $ forever $ do
33 threadDelay dInt
34 readMVar n >>= sequence_
35 io
36 return $ IOMetronome (n, tid)
37 where dInt = floor $ d * 1000
38
39 -- Ticking clock in the IO monad, sending callbacks every t milliseconds.
40 mkClock :: DTime -> IO IOMetronome
41 mkClock = mkClockGeneric (return ())
42
43 -- For debugging purposes.
44 mkClockDebug :: DTime -> IO IOMetronome
45 mkClockDebug = mkClockGeneric (putStrLn "Ping!")
46
47 stopIOMetronome :: IOMetronome -> IO ()
48 stopIOMetronome (IOMetronome (_,tid)) = killThread tid
49
50 newtype IOTick = IOTick (MVar [IO ()])
51
52 newIOTick :: IO IOTick
53 newIOTick = IOTick <$> newMVar []
54
55 tickIOTick :: IOTick -> IO ()
56 tickIOTick (IOTick mvar) = readMVar mvar >>= sequence_
57
58 instance ReactiveValueRead IOTick () IO where
59 reactiveValueRead _ = return ()
60 reactiveValueOnCanRead (IOTick mvar) io =
61 modifyMVar_ mvar (\cbs -> return (cbs ++ [io]))