module Control.Concurrent.Timer.Lifted
( Timer
, TimerIO
, oneShotTimer
, oneShotRestart
, repeatedTimer
, repeatedRestart
, newTimer
, stopTimer
) where
import Control.Applicative
import Control.Concurrent.Lifted (ThreadId, fork, killThread)
import Control.Concurrent.MVar.Lifted (newMVar, tryTakeMVar, putMVar, modifyMVar_)
import Control.Concurrent.Suspend.Lifted (Delay, suspend)
import Control.Monad
import Control.Monad.Base (MonadBase)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Concurrent.Timer.Types (Timer(..))
oneShotRestart :: MonadBaseControl IO m
=> Timer m
-> m 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 :: MonadBaseControl IO m
=> Timer m
-> m 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 :: MonadBaseControl IO m
=> Delay
-> m ()
-> m (Timer m)
oneShotTimer d action = do
tid <- oneShotAction d action >>= newMVar . Just
return Timer { timerAction = action
, timerDelay = d
, timerThreadID = tid
}
repeatedTimer :: MonadBaseControl IO m
=> Delay
-> m ()
-> m (Timer m)
repeatedTimer d action = do
tid <- repeatedAction d action >>= newMVar . Just
return Timer { timerAction = action
, timerDelay = d
, timerThreadID = tid
}
stopTimer :: MonadBaseControl IO m
=> Timer m
-> m ()
stopTimer (Timer _ _ threadID) = modifyMVar_ threadID $
maybe (return Nothing)
(\tid -> killThread tid >> return Nothing)
newTimer :: MonadBase IO m
=> Delay
-> m ()
-> m (Timer m)
newTimer d action = Timer action d <$> newMVar Nothing
type TimerIO = Timer IO
oneShotAction :: MonadBaseControl IO m
=> Delay
-> m ()
-> m ThreadId
oneShotAction d action = fork (suspend d >> action)
repeatedAction :: MonadBaseControl IO m
=> Delay
-> m ()
-> m ThreadId
repeatedAction d action = fork (forever $ suspend d >> action)