blob: 89dd3a86503eb1a889fdfd3670686037c2387883 (
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
|
module BatchedRunner (
Runner,
makeRunner,
stopRunner,
notifyRunner,
withRunner
) where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM.TMVar
import Control.Exception (bracket)
import Control.Monad.STM
import Control.Monad (unless, void)
import Data.Maybe (fromMaybe)
newtype Runner = Runner (TMVar Bool)
makeRunner :: IO a -> Int {- µs -} -> IO Runner
makeRunner f n = do
mv <- newEmptyTMVarIO
_ <- forkIO $ runnerLoop mv
return $ Runner mv
where runnerLoop mv = do
b <- atomically $ takeTMVar mv
unless b $ do
threadDelay n
-- clear the TMVar; we're running f now
mayB <- atomically $ tryTakeTMVar mv
_ <- f
unless (fromMaybe False mayB) $ runnerLoop mv
stopRunner :: Runner -> IO ()
stopRunner (Runner mv) = atomically $ do
mayB <- tryReadTMVar mv
case mayB of
-- if stopped/stopping, do nothing
Just True -> return ()
-- if idle or working, block, such that the Runner has a chance to see that
-- it should fire before stopping
_ -> putTMVar mv True
notifyRunner :: Runner -> IO ()
notifyRunner (Runner mv) = void $ atomically $ tryPutTMVar mv False
withRunner :: IO a -> Int -> (Runner -> IO b) -> IO b
withRunner f n = bracket (makeRunner f n) stopRunner
|
