control-event-0.3.0: Test/Timeout.hs

module Main where

import Control.Concurrent
import Control.Concurrent.STM

import Data.Time.Clock.POSIX
import Control.Event.Timeout

import Text.Printf (printf)

singleTimeout secs = do
  a <- atomically $ newTVar 0
  startTime <- getPOSIXTime
  addTimeout secs (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 -> Float -> IO ()
multiTimeout n secs = do
  a <- atomically $ newTVar n
  startTime <- getPOSIXTime
  mapM_ (const $ addTimeout secs (atomically $ readTVar a >>= writeTVar a . ((flip (-)) 1))) [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)

setAndCancelTimeout :: Int -> Float -> IO ()
setAndCancelTimeout n secs = do
  a <- atomically $ newTVar (0 :: Int)
  startTime <- getPOSIXTime
  tags <- mapM (const $ addTimeout secs (atomically $ readTVar a >>= writeTVar a . ((+) 1))) [1..n]
  mapM (atomically . cancelTimeout) 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, multiTimeout 100000 0.1]
  sequence [setAndCancelTimeout 10 0.1, setAndCancelTimeout 100 0.1, setAndCancelTimeout 1000 0.1, setAndCancelTimeout 10000 0.1, setAndCancelTimeout 100000 0.1]
  return ()