[Haskell-cafe] Re: Timers

[Joel Reymont]

Here's the latest and greatest version put together with Einar's help.

The seconds portion of ClockTime and a counter are used as the key  
now and the counter wraps around. This would make two distinct timers  
even if there expiration times were the same.

{-# OPTIONS_GHC -fglasgow-exts -fno-cse #-}
module Timer
(
startTimer,
stopTimer
)
where

import qualified Data.Map as M
import Data.IORef
import System.Time
import System.IO.Unsafe
import Control.Exception
import Control.Concurrent

type Timers = M.Map (Integer, Int) (IO ())

timeout :: Int
timeout = 5000000 -- 1 second

{-# NOINLINE timers #-}
{-# NOINLINE counter #-}
timers :: MVar Timers
counter :: IORef Int
(timers, counter) = unsafePerformIO $ do mv <- newMVar M.empty
                                          c <- newIORef 0
                                          forkIO $ checkTimers
                                          return (mv, c)

startTimer :: Integer -> (IO ()) -> IO (Integer, Int)
startTimer seconds io =
     do TOD now _ <- getClockTime
        let expiration = now + seconds
        id <- atomicModifyIORef counter $ \x -> (x + 1, x)
        modifyMVar_ timers $ \a ->
            return $! M.insert (expiration, id) io a
        return (expiration, id)

stopTimer :: (Integer, Int) -> IO ()
stopTimer key = modifyMVar_ timers $ \a ->
                 return $! M.delete key a

checkTimers :: IO ()
checkTimers =
     do t <- readMVar timers -- takes it and puts it back
        case M.size t of
          -- no timers
          0 -> threadDelay timeout
          -- some timers
          _ -> do let (key@(time, _), io) = M.findMin t
                  TOD now _ <- getClockTime
                  if (time <= now)
                     then do stopTimer key
                             try $ io -- don't think we care
                             return ()
                     else threadDelay timeout
        checkTimers



--
http://wagerlabs.com/