module Control.Alarm
(
Alarm ()
, AlarmWake
, newAlarm
, releaseAlarm
, withAlarm
, startAlarm
, startAlarm'
, stopAlarm
, restartAlarm
, restartAlarm'
, alarm
, alarm'
)
where
import Control.Concurrent
import Control.Monad (when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Timer
import Data.Default.Class (def)
import Data.Maybe (isJust)
import Data.Time.Interval (fromTimeUnit)
import Data.Time.Units (TimeUnit, Second)
newtype Alarm = Alarm { unAlarm :: Timer IO }
data AlarmWake = AlarmWake deriving Show
instance Exception AlarmWake
newAlarm :: (TimeUnit t, MonadIO m) => t -> m Alarm
newAlarm t = do
tid <- liftIO myThreadId
let sets = (def :: TimerSettings IO)
{ tsDelay = fromTimeUnit t
, tsRun = id
, tsAction = throwTo tid AlarmWake
}
Alarm <$> newTimer sets
releaseAlarm :: MonadIO m => Alarm -> m ()
releaseAlarm = releaseTimer . unAlarm
withAlarm
:: (TimeUnit t, MonadIO m, MonadMask m)
=> t
-> (Alarm -> m a)
-> m a
withAlarm t = bracket (newAlarm t) releaseAlarm
startAlarm :: MonadIO m => Alarm -> m ()
startAlarm = startTimer . unAlarm
startAlarm' :: (TimeUnit t, MonadIO m) => Alarm -> t -> m ()
startAlarm' = startTimer' . unAlarm
stopAlarm :: MonadIO m => Alarm -> m ()
stopAlarm = stopTimer . unAlarm
restartAlarm :: MonadIO m => Alarm -> m ()
restartAlarm = restartTimer . unAlarm
restartAlarm' :: (TimeUnit t, MonadIO m) => Alarm -> t -> m ()
restartAlarm' = restartTimer' . unAlarm
alarmImpl
:: (TimeUnit t, MonadIO m, MonadCatch m)
=> Alarm
-> Maybe t
-> m a
-> m (Maybe a)
alarmImpl alm mt action = do
case mt of
Nothing -> startAlarm alm
Just t -> startAlarm' alm t
result <- catch (Just <$> action) $ \ AlarmWake -> return Nothing
when (isJust result) $ stopAlarm alm
return result
alarm :: (MonadIO m, MonadCatch m) => Alarm -> m a -> m (Maybe a)
alarm alm action = alarmImpl alm (Nothing :: Maybe Second) action
alarm'
:: (TimeUnit t, MonadIO m, MonadCatch m)
=> Alarm
-> t
-> m a
-> m (Maybe a)
alarm' alm t action = alarmImpl alm (Just t) action