Document/tweak RealTimeQueue & its example program

2 files changed, 114 insertions, 53 deletions

diff --git a/RealTimeQueue.hs b/RealTimeQueue.hs
index dc40c84..78314b1 100644
--- a/RealTimeQueue.hs
+++ b/RealTimeQueue.hs
@@ -1,16 +1,88 @@
-module RealTimeQueue where
+module RealTimeQueue (Queue, createQueue, RealTimeQueue.null, scheduleEvent, extractScheduledEvents, scheduleEventIO, runScheduledIO) 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)
+-- The intended interface of this library is mainly the three functions
+-- ''createQueue'', ''scheduleEventIO'' and ''runScheduledIO''.
+
+createQueue :: Queue event
+createQueue = Queue Q.empty 0
+
+-- The IO commands wrap pure code alternatives (which are also exported), using
+-- MonadIO to add management of the clock and the ability to run a user-supplied
+-- handler. The ''Monotonic'' clock type from ''System.Clock'' is used to define
+-- scheduling priorities internally, but these functions expect time to be
+-- specified relative to the present.
+
+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'
+
+null :: Queue event -> Bool
+null (Queue q _) = Q.null q
+
+
+
+
+-- The queue runner receives a time, relative to the present, at which the event
+-- is scheduled to occur. Thus, it can wait for this amount of time if desired
+-- (or, in the case of ALSA, push the event onto the kernel queue with this
+-- amount of delay).
+
+-- It is possible for this time to be negative, in which case the event was
+-- scheduled to happen in the past.
 
+type QueueRunner m event = (TimeSpec, event) -> m ()
+
+
+
+
+-- It is important that the keys are never re-used. Therefore the constructor is
+-- not exported.
+
+-- (Yes, the keys can wrap around, but if your usage is anything remotely like a
+-- FIFO, the earlier keys will be removed before they get reused. In order to
+-- ensure that the keys _never_ wrap, IntPSQ could be replaced with HashPSQ and
+-- the key type made Integer, but then the size of the keys would increase over
+-- time.)
+
+data Queue event = Queue {
+    _intQueue :: IntPSQ TimeSpec event,
+    _nextKey :: Int
+}
 instance Semigroup (Queue event) where
     _ <> q = q
 
+
+
+
+
+-- These three functions provide a pure interface to the schedule queue. They
+-- are agnostic as to the definition of time, but the IO versions below expect
+-- that time should always be defined by the ''Monotonic'' clock in
+-- System.Clock.
+
+-- Schedule an event using absolute time.
+scheduleEvent :: (TimeSpec, event) -> Queue event -> Queue event
+scheduleEvent (ts, ev) (Queue q i) = Queue (Q.insert i ts ev q) (i+1)
+
+-- Given an absolute current time and a timespan (relative to current) into the
+-- future, remove and return all events from the queue that are scheduled
+-- earlier than the end of the timespan.
+
+-- The returned events specify their time as relative to the supplied absolute
+-- current time.
 extractScheduledEvents :: TimeSpec -> TimeSpec -> Queue event -> ([(TimeSpec, event)], Queue event)
 extractScheduledEvents currentTime timeSpan = getAllScheduled
     where
@@ -27,26 +99,3 @@ extractScheduledEvents currentTime timeSpan = getAllScheduled
             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
-}
diff --git a/rtq.hs b/rtq.hs
index a47491a..83f97a6 100644
--- a/rtq.hs
+++ b/rtq.hs
@@ -1,46 +1,58 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE KindSignatures #-}
-
 import BasePrelude hiding ((.))
-import RealTimeQueue
+import RealTimeQueue as Q
 import Control.Monad.IO.Class
 import Control.Monad.State
 import System.Clock
 
 data LoopState = LoopState {
-      _queue :: Queue String
+  _queue :: Queue String,
+  _lastAction :: TimeSpec,
+  _beforeActing :: TimeSpec
 }
 
+type Loop r = StateT LoopState IO r
+
 main :: IO ()
-main = void $ runStateT main' (LoopState createQueue)
-
-main' :: StateT LoopState IO ()
-main' = do
-    queueAction $ scheduleEventIO (TimeSpec 1 0, "hello world")
-    queueAction $ scheduleEventIO (TimeSpec 2 0, "hello world")
-    queueAction $ scheduleEventIO (TimeSpec 3 0, "hello world")
-    queueAction $ scheduleEventIO (TimeSpec 4 0, "hello world")
+main = void $ runStateT (queueSomeStuff >> mainLoop) (LoopState createQueue (TimeSpec 0 0) (TimeSpec 0 0))
+  where
+    queueSomeStuff = do
+      now <- liftIO $ getTime Monotonic
+      modify $ \s -> s { _beforeActing = now, _lastAction = now }
+      forM_ [1,2,4,8,9,10,11,12] $ \i -> queueAction $ scheduleEventIO (TimeSpec i 0, "hello world " ++ show i)
+
+mainLoop :: Loop ()
+mainLoop = do
+  queueAction $ runScheduledIO tickTime runner
+  unlessEmptyQueue $ do
+    liftIO $ threadDelay' tickTime
     mainLoop
 
-queueAction :: forall (m :: * -> *). MonadState LoopState m => (Queue String -> m (Queue String)) -> m ()
+queueAction :: (Queue String -> Loop (Queue String)) -> Loop ()
 queueAction act = do
     q <- gets _queue
-    act q >>= modify . const . LoopState
+    act q >>= \q' -> modify $ \s -> s { _queue = q' }
 
 tickTime :: TimeSpec
-tickTime = TimeSpec 0 15000
+tickTime = TimeSpec 0 1000
 
 threadDelay' :: TimeSpec -> IO ()
 threadDelay' = threadDelay . fromIntegral . timeSpecAsNanoSecs
 
-runner :: TimeSpec -> String -> StateT LoopState IO ()
-runner delay str = liftIO $ do
-                        threadDelay' delay
-                        putStrLn str
-
-mainLoop :: StateT LoopState IO ()
-mainLoop = do
-  queueAction $ runScheduledIO tickTime runner
-  liftIO $ threadDelay' tickTime
-  mainLoop
+timeSpecAsDouble :: TimeSpec -> Double
+timeSpecAsDouble ts = x / (10^(9::Int)) where x = fromIntegral $ timeSpecAsNanoSecs ts
+
+runner :: (TimeSpec, String) -> Loop ()
+runner (delay, str) = do
+  before <- gets _lastAction
+  muchBefore <- gets _beforeActing
+  after <- liftIO $ do
+    threadDelay' delay
+    now <- liftIO $ getTime Monotonic
+    print (now, str, timeSpecAsDouble $ now - before, timeSpecAsDouble $ now - muchBefore)
+    return now
+  modify $ \s -> s { _lastAction = after }
+
+unlessEmptyQueue :: Loop () -> Loop ()
+unlessEmptyQueue f = do
+  q <- gets _queue
+  unless (Q.null q) f