blob: 83a704c5097b3e36d3e3405c676aa6bcf5159c1c (
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
|
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 $ 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
|
