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
|
import BasePrelude hiding ((.))
import RealTimeQueue as Q
import Control.Monad.IO.Class
import Control.Monad.State
import System.Clock
data LoopState = LoopState {
_queue :: Queue String,
_lastAction :: TimeSpec,
_beforeActing :: TimeSpec
}
type Loop r = StateT LoopState IO r
main :: IO ()
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 :: (Queue String -> Loop (Queue String)) -> Loop ()
queueAction act = do
q <- gets _queue
act q >>= \q' -> modify $ \s -> s { _queue = q' }
tickTime :: TimeSpec
tickTime = TimeSpec 0 1000
threadDelay' :: TimeSpec -> IO ()
threadDelay' = threadDelay . fromIntegral . timeSpecAsNanoSecs
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
|
