module Control.Event.Timeout (
addTimeout
, addTimeoutAtomic
, cancelTimeout
, TimeoutTag) where
import System.IO.Unsafe
import Control.Concurrent.STM
import Control.Event
import System.Time
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 (STM TimeoutTag)
addTimeoutAtomic delay 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 ClockTime
getExpireTime delay = do
(TOD sec ps) <- getClockTime
let dSec = truncate delay
dPS = truncate $ (delay fromIntegral dSec) * 10^12
clk = TOD (sec + dSec) (ps + dPS)
return clk