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
|
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
}
|
