1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
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
-- 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
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)
|
