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/>.
 -}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Monad transformer for managing an alarm clock.
module Control.Monad.Trans.Alarm
    ( -- * Transformer
      AlarmT ()
    , runAlarmT
      -- * Starting an alarm
    , startAlarm
    , startAlarm'
      -- * Stopping an alarm
    , stopAlarm
      -- * Restarting an alarm
    , restartAlarm
    , restartAlarm'
      -- * Higher level functions
    , alarm
    , alarm'
    )
where

import Control.Monad.Catch
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.Time.Units (TimeUnit)

import qualified Control.Alarm as A

newtype AlarmT m a = AlarmT
    { unAT :: ReaderT A.Alarm m a
    }
    deriving
        ( -- Basics
          Functor
        , Applicative
        , Monad
          -- Extra monads from base
        , MonadFix
          -- Thread operations are IO
        , MonadIO
          -- This is a transformer after all
        , MonadTrans
          -- Exceptions
        , MonadCatch
        , MonadThrow
        , MonadMask
        )

askAlarm :: Monad m => AlarmT m A.Alarm
askAlarm = AlarmT ask

runAlarmT :: (TimeUnit t, MonadIO m, MonadMask m) => AlarmT m a -> t -> m a
runAlarmT act t = A.withAlarm t $ runReaderT $ unAT act

startAlarm :: MonadIO m => AlarmT m ()
startAlarm = askAlarm >>= A.startAlarm

startAlarm' :: (TimeUnit t, MonadIO m) => t -> AlarmT m ()
startAlarm' t = askAlarm >>= flip A.startAlarm' t

stopAlarm :: MonadIO m => AlarmT m ()
stopAlarm = askAlarm >>= A.stopAlarm

restartAlarm :: MonadIO m => AlarmT m ()
restartAlarm = askAlarm >>= A.restartAlarm

restartAlarm' :: (TimeUnit t, MonadIO m) => t -> AlarmT m ()
restartAlarm' t = askAlarm >>= flip A.restartAlarm' t

alarm :: (MonadIO m, MonadCatch m) => m a -> AlarmT m (Maybe a)
alarm action = do
    alm <- askAlarm
    lift $ A.alarm alm action

alarm'
    :: (TimeUnit t, MonadIO m, MonadCatch m)
    => t
    -> m a
    -> AlarmT m (Maybe a)
alarm' t action = do
    alm <- askAlarm
    lift $ A.alarm' alm t action