{- 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 a timer running in a dedicated thread. You specify an amount of
-- time an and action. The timer waits for that amount of time, and then runs
-- the action. You can stop and restart it at any time.
module Control.Timer
    ( -- * Settings
      TimerSettings ()
    , tsDelay
    , tsRun
    , tsAction
      -- * Timer type
    , Timer ()
      -- * Creating and destroying timers
    , newTimer
    , releaseTimer
    , withTimer
      -- * Starting a timer
    , startTimer
    , startTimer'
    , startTimerWith
      -- * Stopping a timer
    , stopTimer
      -- * Restarting a timer
    , 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
        -- wait until we need to start the timeout
        (mtime, maction) <- liftIO $ takeMVar mvar
        let time = fromMaybe (tsDelay sets) mtime
            action = fromMaybe (tsAction sets) maction
        -- wait the timeout time
        delay (fromMicroseconds $ microseconds time :: Microsecond)
        -- run the action
        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