summaryrefslogtreecommitdiff
path: root/rtq.hs
blob: 83f97a6b7f0d86edc9a9e3a54e3e297cb6ae1565 (plain)
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