From 38b6cd686acd70b0d94271e8256cd573ecc52ced Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sun, 6 Dec 2015 03:07:52 -0500 Subject: Document/tweak RealTimeQueue & its example program --- RealTimeQueue.hs | 101 +++++++++++++++++++++++++++++++++++++++++-------------- rtq.hs | 66 +++++++++++++++++++++--------------- 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 -- cgit v1.2.3