1 files changed, 52 insertions, 0 deletions

diff --git a/RealTimeQueue.hs b/RealTimeQueue.hs
new file mode 100644
index 0000000..dc40c84
--- /dev/null
+++ b/RealTimeQueue.hs
@@ -0,0 +1,52 @@
+module RealTimeQueue where
+import BasePrelude hiding ((<>))
+import System.Clock
+import Data.IntPSQ as Q
+import Control.Monad.IO.Class
+import Data.Semigroup
+
+scheduleEvent :: (TimeSpec, event) -> Queue event -> Queue event
+scheduleEvent (ts, ev) (Queue q i) = Queue (Q.insert i ts ev q) (i+1)
+
+instance Semigroup (Queue event) where
+    _ <> q = q
+
+extractScheduledEvents :: TimeSpec -> TimeSpec -> Queue event -> ([(TimeSpec, event)], Queue event)
+extractScheduledEvents currentTime timeSpan = getAllScheduled
+    where
+        getAllScheduled :: Queue event -> ([(TimeSpec, event)], Queue event)
+        getAllScheduled queue@(Queue q i)
+            | isNothing $ getFirstScheduled queue = ([], queue)
+            | otherwise = let (Just (_, p, v, q')) = minView q
+                              queue' = Queue q' i
+                          in ([(p, v)], queue') <> getAllScheduled queue'
+
+
+        getFirstScheduled :: Queue event -> Maybe (TimeSpec, event)
+        getFirstScheduled (Queue x _) = case findMin x of
+            Nothing -> Nothing
+            Just (_, ts, _) | ts > currentTime + timeSpan -> Nothing
+            Just (_, ts, ev) -> Just (ts - currentTime, ev)
+
+type QueueRunner m event = TimeSpec -> event -> m ()
+
+scheduleEventIO :: MonadIO m => (TimeSpec, event) -> Queue event -> m (Queue event)
+scheduleEventIO (ts, ev) queue = do
+    now <- liftIO $ getTime Monotonic
+    return $ scheduleEvent (ts + now, ev) queue
+
+runScheduledIO :: MonadIO m => TimeSpec -> QueueRunner m event -> Queue event -> m (Queue event)
+runScheduledIO timeSpan runner queue = do
+    now <- liftIO $ getTime Monotonic
+    let (events, queue') = extractScheduledEvents now timeSpan queue
+    forM_ events $ \(ts, ev) -> runner (ts - now) ev
+    return queue'
+
+
+createQueue :: Queue event
+createQueue = Queue Q.empty 0
+
+data Queue event = Queue {
+    intQueue :: IntPSQ TimeSpec event,
+    nextKey :: Int
+}