module Control.Concurrent.Timer
( Timer
, TimerIO
, oneShotTimer
, oneShotRestart
, repeatedTimer
, repeatedRestart
, newTimer
, stopTimer
) where
import Control.Applicative
import Control.Concurrent (ThreadId, forkIO, killThread)
import Control.Concurrent.MVar (newMVar, tryTakeMVar, putMVar, modifyMVar_)
import Control.Concurrent.Suspend (Delay, suspend)
import Control.Monad
import Control.Concurrent.Timer.Types (Timer(..))
oneShotRestart :: TimerIO
-> IO Bool
oneShotRestart (Timer action delay threadID) = do
mtid <- tryTakeMVar threadID
case mtid of
Just (Just tid) -> do
killThread tid
ntid <- Just <$> oneShotAction delay action
putMVar threadID ntid
return True
Just (Nothing) -> do
ntid <- Just <$> oneShotAction delay action
putMVar threadID ntid
return True
Nothing -> return False
repeatedRestart :: TimerIO
-> IO Bool
repeatedRestart (Timer action delay threadID) = do
mtid <- tryTakeMVar threadID
case mtid of
Just (Just tid) -> do
killThread tid
ntid <- Just <$> repeatedAction delay action
putMVar threadID ntid
return True
Just (Nothing) -> do
ntid <- Just <$> repeatedAction delay action
putMVar threadID ntid
return True
Nothing -> return False
oneShotTimer :: Delay
-> IO ()
-> IO (TimerIO)
oneShotTimer d action = do
tid <- oneShotAction d action >>= newMVar . Just
return Timer { timerAction = action
, timerDelay = d
, timerThreadID = tid
}
repeatedTimer :: Delay
-> IO ()
-> IO (TimerIO)
repeatedTimer d action = do
tid <- repeatedAction d action >>= newMVar . Just
return Timer { timerAction = action
, timerDelay = d
, timerThreadID = tid
}
stopTimer :: TimerIO
-> IO ()
stopTimer (Timer _ _ threadID) = modifyMVar_ threadID $
maybe (return Nothing)
(\tid -> killThread tid >> return Nothing)
newTimer :: Delay
-> IO ()
-> IO (TimerIO)
newTimer d action = Timer action d <$> newMVar Nothing
type TimerIO = Timer IO
oneShotAction :: Delay
-> IO ()
-> IO ThreadId
oneShotAction d action = fork (suspend d >> action)
repeatedAction :: Delay
-> IO ()
-> IO ThreadId
repeatedAction d action = fork (forever $ suspend d >> action)
fork :: IO () -> IO ThreadId
fork = forkIO