Timeout.hs

-- |This module is a shim, providing the control-timeout api using
-- control-event to run the show.  See the control-timeout package
-- for documentation.  If you do not need compatability with
-- the control-timeout api then do not use this module!

module Control.Event.Timeout (
      addTimeout
    , addTimeoutAtomic
    , cancelTimeout
    , TimeoutTag) where

import System.IO.Unsafe
import Control.Concurrent.STM
import Control.Event
import Data.Time

{-# NOINLINE evtSys #-}
evtSys = unsafePerformIO initEventSystem

newtype TimeoutTag = TTag EventId

addTimeout :: Float -> IO () -> IO TimeoutTag
addTimeout delay act = do
    clk <- getExpireTime delay
    i <- addEvent evtSys clk act
    return $ TTag i

addTimeoutAtomic :: Float -> IO (IO () -> IO (STM TimeoutTag))
addTimeoutAtomic delay = return $ \act -> do
    clk <- getExpireTime delay
    return $ addEventSTM evtSys clk act >>= return . TTag

cancelTimeout :: TimeoutTag -> STM Bool
cancelTimeout (TTag eid) = cancelEventSTM evtSys eid

getExpireTime :: Float -> IO UTCTime
getExpireTime delay = do
    now <- getCurrentTime
    return (addUTCTime (fromRational $ toRational delay) now)