rtq.hs


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

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE KindSignatures #-}

import BasePrelude hiding ((.))
import RealTimeQueue
import Control.Monad.IO.Class
import Control.Monad.State
import System.Clock

data LoopState = LoopState {
      _queue :: Queue String
}

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")
    mainLoop

queueAction :: forall (m :: * -> *). MonadState LoopState m => (Queue String -> m (Queue String)) -> m ()
queueAction act = do
    q <- gets _queue
    act q >>= modify . const . LoopState

tickTime :: TimeSpec
tickTime = TimeSpec 0 15000

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