{-# LANGUAGE FlexibleContexts #-}
module Control.Concurrent.Timer.Lifted
( Timer
, TimerIO
, oneShotTimer
, oneShotStart
, oneShotRestart
, repeatedTimer
, repeatedStart
, 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(..), TimerImmutable(..))
oneShotStart :: MonadBaseControl IO m
=> Timer m
-> m ()
-> Delay
-> m Bool
oneShotStart (Timer mvmtim) a d = do
mtim <- tryTakeMVar mvmtim
case mtim of
Just (Just (TimerImmutable _ _ tid)) -> do
killThread tid
oneShotTimerImmutable a d >>= putMVar mvmtim . Just
return True
Just (Nothing) -> do
oneShotTimerImmutable a d >>= putMVar mvmtim . Just
return True
Nothing -> return False
{-# INLINEABLE oneShotStart #-}
repeatedStart :: MonadBaseControl IO m
=> Timer m
-> m ()
-> Delay
-> m Bool
repeatedStart (Timer mvmtim) a d = do
mtim <- tryTakeMVar mvmtim
case mtim of
Just (Just (TimerImmutable _ _ tid)) -> do
killThread tid
repeatedTimerImmutable a d >>= putMVar mvmtim . Just
return True
Just (Nothing) -> do
repeatedTimerImmutable a d >>= putMVar mvmtim . Just
return True
Nothing -> return False
{-# INLINEABLE repeatedStart #-}
oneShotRestart :: MonadBaseControl IO m
=> Timer m
-> m Bool
oneShotRestart (Timer mvmtim) = do
mtim <- tryTakeMVar mvmtim
case mtim of
Just (Just (TimerImmutable a d tid)) -> do
killThread tid
oneShotTimerImmutable a d >>= putMVar mvmtim . Just
return True
_ -> return False
{-# INLINEABLE oneShotRestart #-}
repeatedRestart :: MonadBaseControl IO m
=> Timer m
-> m Bool
repeatedRestart (Timer mvmtim) = do
mtim <- tryTakeMVar mvmtim
case mtim of
Just (Just (TimerImmutable a d tid)) -> do
killThread tid
repeatedTimerImmutable a d >>= putMVar mvmtim . Just
return True
_ -> return False
{-# INLINEABLE repeatedRestart #-}
oneShotTimer :: MonadBaseControl IO m
=> m ()
-> Delay
-> m (Timer m)
oneShotTimer a d = Timer <$> (oneShotTimerImmutable a d >>= newMVar . Just)
{-# INLINE oneShotTimer #-}
repeatedTimer :: MonadBaseControl IO m
=> m ()
-> Delay
-> m (Timer m)
repeatedTimer a d = Timer <$> (repeatedTimerImmutable a d >>= newMVar . Just)
{-# INLINE repeatedTimer #-}
stopTimer :: MonadBaseControl IO m
=> Timer m
-> m ()
stopTimer (Timer mvmtim) = modifyMVar_ mvmtim $
maybe (return Nothing)
(\(TimerImmutable _ _ tid) -> killThread tid >> return Nothing)
{-# INLINE stopTimer #-}
newTimer :: MonadBase IO m
=> m (Timer m)
newTimer = Timer <$> newMVar Nothing
{-# INLINE newTimer #-}
type TimerIO = Timer IO
oneShotTimerImmutable :: MonadBaseControl IO m
=> m ()
-> Delay
-> m (TimerImmutable m)
oneShotTimerImmutable a d = TimerImmutable a d <$> oneShotAction a d
{-# INLINE oneShotTimerImmutable #-}
repeatedTimerImmutable :: MonadBaseControl IO m
=> m ()
-> Delay
-> m (TimerImmutable m)
repeatedTimerImmutable a d = TimerImmutable a d <$> repeatedAction a d
{-# INLINE repeatedTimerImmutable #-}
oneShotAction :: MonadBaseControl IO m
=> m ()
-> Delay
-> m ThreadId
oneShotAction action delay = fork (suspend delay >> action)
{-# INLINE oneShotAction #-}
repeatedAction :: MonadBaseControl IO m
=> m ()
-> Delay
-> m ThreadId
repeatedAction action delay = fork (forever $ suspend delay >> action)
{-# INLINE repeatedAction #-}