Alarm.hs

{- This file is part of time-out.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- | Manage an alarm clock running in a dedicated thread.
--
-- You specify an amount of time. The alarm clock waits for that amount of
-- time, and then throws an exception back to you, to notify you the time has
-- passed. You can stop and restart it at any time.
--
-- This is simply a convenient wrapper over "Control.Timer", offered here
-- becuase a common use of timers is to run actions with a time limit
-- (timeout), and the API here makes it more straight-forward to do.
module Control.Alarm
    ( -- * Types
      Alarm ()
    , AlarmWake
      -- * Creating and destroying alarm
    , newAlarm
    , releaseAlarm
    , withAlarm
      -- * Starting an alarm
    , startAlarm
    , startAlarm'
      -- * Stopping a alarm
    , stopAlarm
      -- * Restarting a alarm
    , restartAlarm
    , restartAlarm'
      -- * Higher level functions
    , 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