Document/tweak RealTimeQueue & its example program

1 files changed, 39 insertions, 27 deletions

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