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
data Timer = Timer
{ period :: Time
, action :: IO ()
, tag :: MVar ()
}
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 ()
newTimers = do
newMVar []
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 (tt') 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
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 (tt') xs
in (timer : timers, xs')