-- |This module is a shim, providing the control-timeout api using
-- control-event to run the show

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

import System.IO.Unsafe
import Control.Concurrent.STM
import Control.Event
import System.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 (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