module Ticker where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Function
import Data.Time.Clock.POSIX
import Data.Typeable

data ScheduleTick = ScheduleTick Int deriving (Show, Typeable)
instance Exception ScheduleTick

newtype Ticker = Ticker ThreadId

-- | Fork a thread that will invoke an STM transaction whenever a tick event
-- occurs.  The first tick happens immediately, later ticks must be scheduled
-- with 'scheduleTick'.
forkTicker :: (POSIXTime -> STM ()) -> IO Ticker
forkTicker tick = do
    getPOSIXTime >>= atomically . tick
    tid <- forkIO $ fix $ \loop -> do
        getPOSIXTime >>= atomically . tick
        catch loop $ \(ScheduleTick interval) -> do
                        threadDelay interval
                        when (interval >= 0) loop
    return $ Ticker tid

-- | Schedule the next tick.  If you supply a negative number, the ticker
-- thread will terminate. Otherwise, the next tick will be scheduled for the
-- given number of microseconds from now.
--
-- Note: If a tick was scheduled to happen sooner, that tick will be canceled
-- in favor of this one.  Only one tick is scheduled at a time.
scheduleTick :: Ticker -> Int -> IO ()
scheduleTick (Ticker tid) usecs = throwTo tid (ScheduleTick usecs)