{-|
Module      : Control.Concurrent.Async.Timer.Internal
Description : Implementation of asynchronous Timers
Copyright   : (c) Moritz Clasmeier 2016, 2018
License     : BSD3
Maintainer  : mtesseract@silverratio.net
Stability   : experimental
Portability : POSIX

This module contains the internal implementation of asynchronous
timers.
-}

{-# LANGUAGE LambdaCase #-}

module Control.Concurrent.Async.Timer.Internal where

import qualified Control.Concurrent.Async as Async
import           Control.Exception.Safe
import           Control.Monad            (void)
import           Control.Monad.IO.Unlift
import           UnliftIO.Async
import           UnliftIO.Concurrent
import           UnliftIO.STM

-- | This is the type of timer handle, which will be provided to the
-- IO action to be executed within 'withAsyncTimer'. The user can use
-- 'timerWait' on this timer to delay execution until the next timer
-- synchronization event.
data Timer = Timer { Timer -> MVar ()
timerMVar    :: MVar ()
                   , Timer -> TBQueue TimerCommand
timerControl :: TBQueue TimerCommand }

-- | Timer commands that can be sent over a timer control channel to
-- an asynchronous timer.
data TimerCommand = TimerReset deriving (Int -> TimerCommand -> ShowS
[TimerCommand] -> ShowS
TimerCommand -> String
(Int -> TimerCommand -> ShowS)
-> (TimerCommand -> String)
-> ([TimerCommand] -> ShowS)
-> Show TimerCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimerCommand] -> ShowS
$cshowList :: [TimerCommand] -> ShowS
show :: TimerCommand -> String
$cshow :: TimerCommand -> String
showsPrec :: Int -> TimerCommand -> ShowS
$cshowsPrec :: Int -> TimerCommand -> ShowS
Show, TimerCommand -> TimerCommand -> Bool
(TimerCommand -> TimerCommand -> Bool)
-> (TimerCommand -> TimerCommand -> Bool) -> Eq TimerCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimerCommand -> TimerCommand -> Bool
$c/= :: TimerCommand -> TimerCommand -> Bool
== :: TimerCommand -> TimerCommand -> Bool
$c== :: TimerCommand -> TimerCommand -> Bool
Eq)

-- | Type of a timer configuration.
data TimerConf = TimerConf { TimerConf -> Int
_timerConfInitDelay :: Int
                           , TimerConf -> Int
_timerConfInterval  :: Int }

-- | Sleep 'dt' milliseconds.
millisleep :: MonadIO m => Int -> m ()
millisleep :: Int -> m ()
millisleep Int
dt = Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
dt Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
3)

-- | Default timer configuration specifies no initial delay and an
-- interval delay of 1s.
defaultConf :: TimerConf
defaultConf :: TimerConf
defaultConf = TimerConf :: Int -> Int -> TimerConf
TimerConf { _timerConfInitDelay :: Int
_timerConfInitDelay =    Int
0
                        , _timerConfInterval :: Int
_timerConfInterval  = Int
1000 }

-- | Set the initial delay in the provided timer configuration.
setInitDelay :: Int -> TimerConf -> TimerConf
setInitDelay :: Int -> TimerConf -> TimerConf
setInitDelay Int
n TimerConf
conf = TimerConf
conf { _timerConfInitDelay :: Int
_timerConfInitDelay = Int
n }

-- | Set the interval delay in the provided timer configuration.
setInterval :: Int -> TimerConf -> TimerConf
setInterval :: Int -> TimerConf -> TimerConf
setInterval Int
n TimerConf
conf = TimerConf
conf { _timerConfInterval :: Int
_timerConfInterval = Int
n }

-- | Timer loop to be executed within in a timer thread.
timerLoop
  :: MonadUnliftIO m
  => Int
  -> Int
  -> Timer
  -> m ()
timerLoop :: Int -> Int -> Timer -> m ()
timerLoop Int
initDelay Int
intervalDelay Timer
timer = Int -> m ()
forall b. Int -> m b
go Int
initDelay

  where go :: Int -> m b
go Int
delay = do
          m () -> m TimerCommand -> m (Either () TimerCommand)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
millisleep Int
delay) m TimerCommand
readCmd m (Either () TimerCommand)
-> (Either () TimerCommand -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
            Left () -> do
              m ()
wakeUp
              Int -> m b
go Int
intervalDelay
            Right TimerCommand
cmd ->
              case TimerCommand
cmd of
                TimerCommand
TimerReset ->
                  Int -> m b
go Int
intervalDelay

        wakeUp :: m ()
wakeUp   = MVar () -> () -> m ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar (Timer -> MVar ()
timerMVar Timer
timer) ()
        readCmd :: m TimerCommand
readCmd  = STM TimerCommand -> m TimerCommand
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM TimerCommand -> m TimerCommand)
-> STM TimerCommand -> m TimerCommand
forall a b. (a -> b) -> a -> b
$ TBQueue TimerCommand -> STM TimerCommand
forall a. TBQueue a -> STM a
readTBQueue (Timer -> TBQueue TimerCommand
timerControl Timer
timer)

-- | Wait for the next synchronization event on the givem timer.
wait
  :: MonadUnliftIO m
  => Timer
  -> m ()
wait :: Timer -> m ()
wait = m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> (Timer -> m ()) -> Timer -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar () -> m ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar (MVar () -> m ()) -> (Timer -> MVar ()) -> Timer -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timer -> MVar ()
timerMVar

-- | Reset the provided timer.
reset
  :: MonadUnliftIO m
  => Timer
  -> m ()
reset :: Timer -> m ()
reset Timer
timer =
  STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ TBQueue TimerCommand -> TimerCommand -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue (Timer -> TBQueue TimerCommand
timerControl Timer
timer) TimerCommand
TimerReset

-- | Spawn a timer thread based on the provided timer configuration
-- and then run the provided IO action, which receives the new timer
-- as an argument and call 'timerWait' on it for synchronization. When
-- the provided IO action has terminated, the timer thread will be
-- terminated also.
withAsyncTimer
  :: (MonadUnliftIO m, MonadMask m)
  => TimerConf
  -> (Timer -> m b)
  -> m b
withAsyncTimer :: TimerConf -> (Timer -> m b) -> m b
withAsyncTimer TimerConf
conf Timer -> m b
io = do
  -- This MVar will be our synchronization mechanism.
  MVar ()
mVar <- m (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  TBQueue TimerCommand
controlChannel <- STM (TBQueue TimerCommand) -> m (TBQueue TimerCommand)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (TBQueue TimerCommand) -> m (TBQueue TimerCommand))
-> STM (TBQueue TimerCommand) -> m (TBQueue TimerCommand)
forall a b. (a -> b) -> a -> b
$ Natural -> STM (TBQueue TimerCommand)
forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
1
  let timer :: Timer
timer         = Timer :: MVar () -> TBQueue TimerCommand -> Timer
Timer { timerMVar :: MVar ()
timerMVar = MVar ()
mVar
                            , timerControl :: TBQueue TimerCommand
timerControl = TBQueue TimerCommand
controlChannel }
      initDelay :: Int
initDelay     = TimerConf -> Int
_timerConfInitDelay TimerConf
conf
      intervalDelay :: Int
intervalDelay = TimerConf -> Int
_timerConfInterval  TimerConf
conf
  m () -> (Async () -> m b) -> m b
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (Int -> Int -> Timer -> m ()
forall (m :: * -> *).
MonadUnliftIO m =>
Int -> Int -> Timer -> m ()
timerLoop Int
initDelay Int
intervalDelay Timer
timer) ((Async () -> m b) -> m b) -> (Async () -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \ Async ()
asyncTimer -> do
    -- This guarantees that we will be informed right away if our
    -- timer thread disappears, for example because of an async
    -- exception:
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO ()
forall a. Async a -> IO ()
Async.link Async ()
asyncTimer
    Timer -> m b
io Timer
timer