    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.HGL.X11.Timer
    -- Copyright   :  (c) Alastair Reid, 1999-2003
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  libraries@haskell.org
    -- Stability   :  internal
    -- Portability :  non-portable (requires concurrency)
    --
    -- A simple graphics library.
    --
    -----------------------------------------------------------------------------

    -- #hide
    module Graphics.HGL.X11.Timer
    	( Timer, new, stop
            , Timers, newTimers, clearTimers, nextTick, fireTimers
    	) where

    import Control.Concurrent
    	( MVar, newMVar, takeMVar, putMVar, readMVar )
    import Graphics.HGL.Internals.Utilities( modMVar_ )
    import Graphics.HGL.Internals.Types

    ----------------------------------------------------------------
    -- Interface
    ----------------------------------------------------------------

    data Timer = Timer
      { period :: Time           -- how often does it fire
      , action :: IO ()          -- what to do when it does
      , tag    :: MVar ()        -- something that supports an equality test
      }

    -- A standard timer implementation using a list of (delta-time,timer) pairs.
    type Timers = MVar [(Time, Timer)]

    newTimers   :: IO Timers
    clearTimers :: Timers -> IO ()
    nextTick    :: Timers -> IO (Maybe Time)
    fireTimers  :: Timers -> Time -> IO ()

    new  :: Timers -> Time -> IO () -> IO Timer
    stop :: Timers -> Timer -> IO ()

    ----------------------------------------------------------------
    -- Implementation
    ----------------------------------------------------------------

    newTimers = do
      newMVar []

    -- This will only work if the mvar is non-empty.
    -- Fortunately, all operations on timers do atomic updates (modMVar)
    -- so this should be true.
    clearTimers ts = do
      modMVar_ ts (const [])

    fireTimers timers t = do
      xs <- takeMVar timers
      let (ts,xs') = firedTimers t xs
          xs''     = foldr insert xs' ts
      putMVar timers xs''
      mapM_ action ts
     where
      insert :: Timer -> [(Time,Timer)] -> [(Time,Timer)]
      insert timer = insertTimer (period timer) timer

    nextTick timers = do
      ts <- readMVar timers
      case ts of
        ((t,_):_) -> return (Just t)
        _         -> return Nothing

    new timers t a = do
      tag <- newMVar ()
      let timer = Timer{period=t, action=a, tag=tag}
      modMVar_ timers (insertTimer t timer)
      return timer

    stop timers timer = do
      modMVar_ timers (deleteTimer timer)

    instance Eq Timer where
      t1 == t2 = tag t1 == tag t2

    insertTimer :: Time -> Timer -> [(Time,Timer)] -> [(Time,Timer)]
    insertTimer t timer []     = [(t,timer)]
    insertTimer t timer (x@(t',timer'):xs)
      | t <= t'
      = (t,timer) : (t'-t, timer') : xs
      | otherwise
      = x : insertTimer (t-t') timer xs

    deleteTimer :: Timer -> [(Time,Timer)] -> [(Time,Timer)]
    deleteTimer timer [] = []
    deleteTimer timer (x@(t',timer'):xs)
      | timer == timer'
      = case xs of
          []                 -> []
          (t'', timer''):xs' -> (t'+t'', timer''):xs'
      | otherwise
      = x : deleteTimer timer xs

    -- we could try to avoid timer drift by returning how "late" we are
    -- in firing the timer
    -- Maybe a better approach is to make use of the real-time clock provided
    -- by the OS and stay in sync with that?
    firedTimers :: Time -> [(Time,Timer)] -> ([Timer],[(Time,Timer)])
    firedTimers t [] = ([],[])
    firedTimers t ((t',timer):xs)
      | t < t'
      = ([], (t'-t,timer):xs)
      | otherwise
      = let (timers, xs') = firedTimers (t-t') xs
        in (timer : timers, xs')

    ----------------------------------------------------------------
    -- End
    ----------------------------------------------------------------