control-event-1.0.0.0: Test/Event.hs

module Main where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Event
import Text.Printf (printf)
import Data.Time
import Data.Time.Clock.POSIX

singleTimeout :: NominalDiffTime -> IO ()
singleTimeout secs = do
  sys <- initEventSystem
  a <- atomically $ newTVar 0
  startTime <- getPOSIXTime
  now <- getCurrentTime
  let newSec = truncate secs
      newPS  = truncate $ 10^12 * (secs - (fromIntegral newSec))
  addEvent sys (addUTCTime secs now) (getPOSIXTime >>= atomically . writeTVar a)
  endTime <- atomically (do
    t <- readTVar a
    if t == 0
       then retry
       else return t)
  printf "%dms sleep took: %s\n" ((truncate $ secs * 1000) :: Int) (show (endTime - startTime))

multiTimeout :: Int -> NominalDiffTime -> IO ()
multiTimeout n secs = do
  sys <- initEventSystem
  a <- atomically $ newTVar n
  now <- getCurrentTime
  startTime <- getPOSIXTime
  mapM_ (const $ addEvent sys (addUTCTime secs now) (decAndPrint a)) [1..n]
  atomically (do
    n' <- readTVar a
    if n' == 0
       then return ()
       else retry )
  endTime <- getPOSIXTime
  printf "%d timeouts for %d ms took %s\n" n ((truncate $ secs * 1000) :: Int) (show $ endTime - startTime)
  where
  decAndPrint :: TVar Int -> IO ()
  decAndPrint a =
     atomically (do
          n <- readTVar a
	  writeTVar a (n - 1) )

setAndCancelTimeout :: Int -> NominalDiffTime -> IO ()
setAndCancelTimeout n secs = do
  sys <- initEventSystem
  a <- atomically $ newTVar (0 :: Int)
  now <- getCurrentTime
  startTime <- getPOSIXTime
  tags <- mapM (const $ addEvent sys (addUTCTime secs now) (atomically $ readTVar a >>= writeTVar a . ((+) 1))) [1..n]
  mapM (cancelEvent sys) tags
  endTime <- getPOSIXTime
  expired <- atomically $ readTVar a

  printf "Setting and killing %d timeouts for %d ms took %s and %d expired\n" n ((truncate $ secs * 1000) :: Int) (show $ endTime - startTime) expired

main = do
  sequence [singleTimeout 0, singleTimeout 0.1, singleTimeout 0.5, singleTimeout 1.0]
  sequence [multiTimeout 10 0.1, multiTimeout 100 0.1, multiTimeout 1000 0.1, multiTimeout 10000 0.1]
  sequence [setAndCancelTimeout 10 0.1, setAndCancelTimeout 100 0.1, setAndCancelTimeout 1000 0.1, setAndCancelTimeout 10000 0.1, setAndCancelTimeout 100000 0.1]
  return ()