1 files changed, 40 insertions, 0 deletions
diff --git a/src/BatchedRunner.hs b/src/BatchedRunner.hs
new file mode 100644
index 0000000..83a704c
--- /dev/null
+++ b/src/BatchedRunner.hs
@@ -0,0 +1,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