module Control.Timer
(
TimerSettings ()
, tsDelay
, tsRun
, tsAction
, Timer ()
, newTimer
, releaseTimer
, withTimer
, startTimer
, startTimer'
, startTimerWith
, stopTimer
, restartTimer
, restartTimer'
, restartTimerWith
)
where
import Control.Concurrent
import Control.Monad (forever)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Default.Class
import Data.Maybe (fromMaybe)
import Data.Time.Interval hiding (time)
import Data.Time.Units
import Control.Timeout (delay)
data StopTimer = StopTimer deriving Show
instance Exception StopTimer
data TimerSettings n = TimerSettings
{ tsDelay :: TimeInterval
, tsRun :: n () -> IO ()
, tsAction :: n ()
}
instance MonadIO n => Default (TimerSettings n) where
def = TimerSettings
{ tsDelay = fromTimeUnit (3 :: Second)
, tsRun = const $ do
let msg = "You didn't tell me how to run the monad"
putStrLn msg
error msg
, tsAction = liftIO $ putStrLn "Time reached, timer has stopped!"
}
type Msg n = (Maybe TimeInterval, Maybe (n ()))
data Timer n = Timer
{ timerThread :: ThreadId
, timerMVar :: MVar (Msg n)
}
timerThreadLoop
:: (MonadIO n, MonadCatch n)
=> TimerSettings n
-> MVar (Msg n)
-> IO ()
timerThreadLoop sets mvar =
tsRun sets $ forever $ handle (\ StopTimer -> return ()) $ do
(mtime, maction) <- liftIO $ takeMVar mvar
let time = fromMaybe (tsDelay sets) mtime
action = fromMaybe (tsAction sets) maction
delay (fromMicroseconds $ microseconds time :: Microsecond)
action
newTimer
:: (MonadIO m, MonadIO n, MonadCatch n)
=> TimerSettings n
-> m (Timer n)
newTimer sets = do
mvar <- liftIO newEmptyMVar
tid <- liftIO $ forkIO $ timerThreadLoop sets mvar
return Timer
{ timerThread = tid
, timerMVar = mvar
}
releaseTimer :: MonadIO m => Timer n -> m ()
releaseTimer timer = liftIO $ killThread $ timerThread timer
withTimer
:: (MonadIO m, MonadMask m, MonadIO n, MonadCatch n)
=> TimerSettings n
-> (Timer n -> m a)
-> m a
withTimer sets = bracket (newTimer sets) releaseTimer
startTimer :: MonadIO m => Timer n -> m ()
startTimer timer = startTimerWith timer (Nothing :: Maybe Second) Nothing
startTimer' :: (TimeUnit t, MonadIO m) => Timer n -> t -> m ()
startTimer' timer t = startTimerWith timer (Just t) Nothing
startTimerWith
:: (TimeUnit t, MonadIO m)
=> Timer n
-> Maybe t
-> Maybe (n ())
-> m ()
startTimerWith timer mtime maction =
liftIO $ putMVar (timerMVar timer) (fromTimeUnit <$> mtime, maction)
stopTimer :: MonadIO m => Timer n -> m ()
stopTimer timer = liftIO $ do
_ <- tryTakeMVar $ timerMVar timer
throwTo (timerThread timer) StopTimer
restartTimer :: MonadIO m => Timer n -> m ()
restartTimer timer = restartTimerWith timer (Nothing :: Maybe Second) Nothing
restartTimer' :: (TimeUnit t, MonadIO m) => Timer n -> t -> m ()
restartTimer' timer t = restartTimerWith timer (Just t) Nothing
restartTimerWith
:: (TimeUnit t, MonadIO m)
=> Timer n
-> Maybe t
-> Maybe (n ())
-> m ()
restartTimerWith timer mtime maction = do
stopTimer timer
startTimerWith timer mtime maction