control-event-0.1: Test/Test.hs

module Main where

import Control.Event
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM
import System.Time


secDelay :: Integer
secDelay = 5

waitForEvents :: Int
waitForEvents = 7

tol :: Int
tol = 2 -- seconds

main = do
--    runTest "testOneEvent" testOneEvent
--    runTest "testManyEvents 50" (testManyEvents 50)
--    runTest "testDeletingEvents 50" (testDeletingEvents 50)
--    runTest "testOnTime [8,1]" (testOnTime [8,1])
    runTest "testOnTime [8,4,2]" (testOnTime [8,4,2])
--    runTest "testOnTime [2,4,8]" (testOnTime [2,4,8])
--    runTest "testOnTime [1,1,1,1...]" (testOnTime (take 20 (repeat 1)))

runTest :: String -> (IO Bool) -> IO ()
runTest label test = do
	putStrLn $ "Running test '" ++ label ++ "'"
	res <- test
	putStrLn $ "Test completed: " ++ (show res)

testOneEvent :: IO Bool
testOneEvent = do
    tv <- newTVarIO False
    sys <- initEventSystem
    (TOD sec picosec) <- getClockTime
    let clk = TOD (sec + secDelay) picosec
    addEvent sys clk (atomically (writeTVar tv True))
    threadDelay $ waitForEvents * 10^6
    atomically (readTVar tv >>= return)

testManyEvents :: Int -> IO Bool
testManyEvents nrEvts = do
    tv <- newTVarIO nrEvts
    sys <- initEventSystem
    (TOD sec picosec) <- getClockTime
    let clks = map (\_ -> TOD (sec + secDelay) picosec) [1..nrEvts]
    mapM_ (\clk -> addEvent sys clk (atomically (readTVar tv >>= \x ->writeTVar tv (x - 1)))) clks
    threadDelay $ waitForEvents*10^6
    atomically (readTVar tv >>= return . (==0))

testDeletingEvents :: Int -> IO Bool
testDeletingEvents nrEvents = do
    tv <- newTVarIO nrEvents
    sys <- initEventSystem
    (TOD sec picosec) <- getClockTime
    let clks = map (\_ -> TOD (sec + secDelay) picosec) [1..nrEvents]
    ids <- mapM (\clk -> addEvent sys clk (atomically (readTVar tv >>= \x ->writeTVar tv (x - 1)))) clks
    mapM_ (cancelEvent sys) ids
    threadDelay $ waitForEvents*10^6
    atomically (readTVar tv >>= return . (==nrEvents))

testOnTime :: [Integer] -> IO Bool
testOnTime delays = do
    tv <- newTVarIO (length delays)
    sys <- initEventSystem
--    atomically (setEventPreprocessing sys neverForkEvents)
    (TOD sec picosec) <- getClockTime
    let clks = map (\d -> TOD (sec + d) picosec) delays
    mapM_ (\clk -> addEvent sys clk (theTimeIsNow clk tv)) clks
    threadDelay $ fromIntegral $ (maximum delays + fromIntegral tol)*10^6
    atomically (readTVar tv >>= return . (==length delays))

theTimeIsNow :: ClockTime -> TVar Int -> IO ()
theTimeIsNow clk tv = do
	now <- getClockTime
	let (TimeDiff _ _ _ _ _ sec _) = diffClockTimes now clk
	if sec > tol
		then do putStrLn ("Time error of " ++ (show sec) ++ " seconds")
		        atomically (readTVar tv >>= \x -> writeTVar tv (x-1))
		else return ()