{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE RecordWildCards #-}

{-| Device for running an action at (i.e. shortly after) a certain time, which
can be used to implement things like time-based cache expiry.

This implementation avoids the use of polling and leans on Haskell's scheduler
to achieve low-latency without lots of computational overhead.

The alarm can be set multiple times, and in this case the alarm will go off at
the earliest requested time. If the alarm is set in the past, the action will
run immediately. When the action runs, it clears all future alarms; the action
can itself set the next alarm time.

To perform time-based cache expiry, create an 'AlarmClock' whose action flushes
any stale entries from the cache and then calls `setAlarm` for the next time
that an entry will expire (if there are any). When expiring entries are added
to the cache, call 'setAlarm' to ensure that they will expire in a timely
fashion.

-}

module Control.Concurrent.AlarmClock
  ( AlarmClock()
  , newAlarmClock
  , newAlarmClock'
  , destroyAlarmClock
  , withAlarmClock
  , setAlarm
  , setAlarmSTM
  , setAlarmNow
  , isAlarmSet
  , isAlarmSetSTM
  , TimeScale
  , MonotonicTime(..)
  ) where

import           Control.Concurrent.Async                (async, wait, waitSTM,
                                                          withAsync)
import           Control.Concurrent.STM                  (STM, TVar, atomically,
                                                          modifyTVar',
                                                          newTVarIO, orElse,
                                                          readTVar, retry,
                                                          writeTVar)
import           Control.Concurrent.Thread.Delay         (delay)
import           Control.Exception                       (bracket)
import           Control.Monad                           (join)
import           Control.Monad.Fix                       (mfix)
import           GHC.Conc                                (labelThread,
                                                          myThreadId)

import           Control.Concurrent.AlarmClock.TimeScale

data AlarmSetting t = AlarmNotSet | AlarmSet t | AlarmDestroyed

{-| An 'AlarmClock' is a device for running an action at (or shortly after) a certain time. -}
data AlarmClock t = AlarmClock
  { AlarmClock t -> IO ()
acWaitForExit :: IO ()
  , AlarmClock t -> TVar (AlarmSetting t)
acNewSetting  :: TVar (AlarmSetting t)
  }

{-| Create a new 'AlarmClock' that runs the given action. Initially, there is
no wakeup time set: you must call 'setAlarm' for anything else to happen. -}
newAlarmClock
  :: TimeScale t
  => (AlarmClock t -> IO ())
    -- ^ Action to run when the alarm goes off. The action is provided the alarm clock
    -- so it can set a new alarm if desired. Note that `setAlarm` must be called once
    -- the alarm has gone off to cause it to go off again.
  -> IO (AlarmClock t)
newAlarmClock :: (AlarmClock t -> IO ()) -> IO (AlarmClock t)
newAlarmClock AlarmClock t -> IO ()
onWakeUp = (AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
forall t.
TimeScale t =>
(AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
newAlarmClock' ((AlarmClock t -> t -> IO ()) -> IO (AlarmClock t))
-> (AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
forall a b. (a -> b) -> a -> b
$ IO () -> t -> IO ()
forall a b. a -> b -> a
const (IO () -> t -> IO ())
-> (AlarmClock t -> IO ()) -> AlarmClock t -> t -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlarmClock t -> IO ()
onWakeUp

{-| Create a new 'AlarmClock' that runs the given action. Initially, there is
no wakeup time set: you must call 'setAlarm' for anything else to happen. -}
newAlarmClock'
  :: TimeScale t
  => (AlarmClock t -> t -> IO ())
    -- ^ Action to run when the alarm goes off. The action is provided the alarm clock
    -- so it can set a new alarm if desired, and the current time.
    -- Note that `setAlarm` must be called once the alarm has gone off to cause
    -- it to go off again.
  -> IO (AlarmClock t)
newAlarmClock' :: (AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
newAlarmClock' AlarmClock t -> t -> IO ()
onWakeUp = (AlarmClock t -> IO (AlarmClock t)) -> IO (AlarmClock t)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((AlarmClock t -> IO (AlarmClock t)) -> IO (AlarmClock t))
-> (AlarmClock t -> IO (AlarmClock t)) -> IO (AlarmClock t)
forall a b. (a -> b) -> a -> b
$ \AlarmClock t
ac -> do
  Async ()
acAsync <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ AlarmClock t -> (t -> IO ()) -> IO ()
forall t. TimeScale t => AlarmClock t -> (t -> IO ()) -> IO ()
runAlarmClock AlarmClock t
ac (AlarmClock t -> t -> IO ()
onWakeUp AlarmClock t
ac)
  IO () -> TVar (AlarmSetting t) -> AlarmClock t
forall t. IO () -> TVar (AlarmSetting t) -> AlarmClock t
AlarmClock (Async () -> IO ()
forall a. Async a -> IO a
wait Async ()
acAsync) (TVar (AlarmSetting t) -> AlarmClock t)
-> IO (TVar (AlarmSetting t)) -> IO (AlarmClock t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AlarmSetting t -> IO (TVar (AlarmSetting t))
forall a. a -> IO (TVar a)
newTVarIO AlarmSetting t
forall t. AlarmSetting t
AlarmNotSet

{-| Destroy the 'AlarmClock' so no further alarms will occur. If the alarm is currently going off
then this will block until the action is finished. -}
destroyAlarmClock :: AlarmClock t -> IO ()
destroyAlarmClock :: AlarmClock t -> IO ()
destroyAlarmClock AlarmClock{IO ()
TVar (AlarmSetting t)
acNewSetting :: TVar (AlarmSetting t)
acWaitForExit :: IO ()
acNewSetting :: forall t. AlarmClock t -> TVar (AlarmSetting t)
acWaitForExit :: forall t. AlarmClock t -> IO ()
..} = STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar (AlarmSetting t) -> AlarmSetting t -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (AlarmSetting t)
acNewSetting AlarmSetting t
forall t. AlarmSetting t
AlarmDestroyed) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
acWaitForExit

{-| The action @withAlarmClock onWakeUp inner@ runs @inner@ with a new 'AlarmClock' which
is destroyed when @inner@ exits. -}
withAlarmClock :: TimeScale t
               => (AlarmClock t -> t -> IO ())
               -> (AlarmClock t -> IO a) -> IO a
withAlarmClock :: (AlarmClock t -> t -> IO ()) -> (AlarmClock t -> IO a) -> IO a
withAlarmClock AlarmClock t -> t -> IO ()
onWakeUp AlarmClock t -> IO a
inner = IO (AlarmClock t)
-> (AlarmClock t -> IO ()) -> (AlarmClock t -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket ((AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
forall t.
TimeScale t =>
(AlarmClock t -> t -> IO ()) -> IO (AlarmClock t)
newAlarmClock' AlarmClock t -> t -> IO ()
onWakeUp) AlarmClock t -> IO ()
forall t. AlarmClock t -> IO ()
destroyAlarmClock AlarmClock t -> IO a
inner

{-| Make the 'AlarmClock' go off at (or shortly after) the given time.  This
can be called more than once; in which case, the alarm will go off at the
earliest given time. -}
setAlarm :: TimeScale t => AlarmClock t -> t -> IO ()
setAlarm :: AlarmClock t -> t -> IO ()
setAlarm AlarmClock t
ac t
t = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ AlarmClock t -> t -> STM ()
forall t. TimeScale t => AlarmClock t -> t -> STM ()
setAlarmSTM AlarmClock t
ac t
t

{-| Make the 'AlarmClock' go off at (or shortly after) the given time.  This
can be called more than once; in which case, the alarm will go off at the
earliest given time. -}
setAlarmSTM :: TimeScale t => AlarmClock t -> t -> STM ()
setAlarmSTM :: AlarmClock t -> t -> STM ()
setAlarmSTM AlarmClock{IO ()
TVar (AlarmSetting t)
acNewSetting :: TVar (AlarmSetting t)
acWaitForExit :: IO ()
acNewSetting :: forall t. AlarmClock t -> TVar (AlarmSetting t)
acWaitForExit :: forall t. AlarmClock t -> IO ()
..} t
t = TVar (AlarmSetting t)
-> (AlarmSetting t -> AlarmSetting t) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (AlarmSetting t)
acNewSetting ((AlarmSetting t -> AlarmSetting t) -> STM ())
-> (AlarmSetting t -> AlarmSetting t) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
  AlarmSetting t
AlarmNotSet    -> t -> AlarmSetting t
forall t. t -> AlarmSetting t
AlarmSet t
t
  AlarmSet t
t'    -> t -> AlarmSetting t
forall t. t -> AlarmSetting t
AlarmSet (t -> AlarmSetting t) -> t -> AlarmSetting t
forall a b. (a -> b) -> a -> b
$! t -> t -> t
forall t. TimeScale t => t -> t -> t
earlierOf t
t t
t'
  AlarmSetting t
AlarmDestroyed -> AlarmSetting t
forall t. AlarmSetting t
AlarmDestroyed

{-| Make the 'AlarmClock' go off right now. -}
setAlarmNow :: TimeScale t => AlarmClock t -> IO ()
setAlarmNow :: AlarmClock t -> IO ()
setAlarmNow AlarmClock t
alarm = IO t
forall t. TimeScale t => IO t
getAbsoluteTime IO t -> (t -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AlarmClock t -> t -> IO ()
forall t. TimeScale t => AlarmClock t -> t -> IO ()
setAlarm AlarmClock t
alarm

{-| Is the alarm set - i.e. will it go off at some point in the future even if `setAlarm` is not called? -}
isAlarmSet :: AlarmClock t -> IO Bool
isAlarmSet :: AlarmClock t -> IO Bool
isAlarmSet = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool)
-> (AlarmClock t -> STM Bool) -> AlarmClock t -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlarmClock t -> STM Bool
forall t. AlarmClock t -> STM Bool
isAlarmSetSTM

{-| Is the alarm set - i.e. will it go off at some point in the future even if `setAlarm` is not called? -}
isAlarmSetSTM :: AlarmClock t -> STM Bool
isAlarmSetSTM :: AlarmClock t -> STM Bool
isAlarmSetSTM AlarmClock{IO ()
TVar (AlarmSetting t)
acNewSetting :: TVar (AlarmSetting t)
acWaitForExit :: IO ()
acNewSetting :: forall t. AlarmClock t -> TVar (AlarmSetting t)
acWaitForExit :: forall t. AlarmClock t -> IO ()
..} = TVar (AlarmSetting t) -> STM (AlarmSetting t)
forall a. TVar a -> STM a
readTVar TVar (AlarmSetting t)
acNewSetting
  STM (AlarmSetting t) -> (AlarmSetting t -> STM Bool) -> STM Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case { AlarmSet t
_ -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True; AlarmSetting t
_ -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False }

labelMyThread :: String -> IO ()
labelMyThread :: String -> IO ()
labelMyThread String
threadLabel = IO ThreadId
myThreadId IO ThreadId -> (ThreadId -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ThreadId -> String -> IO ()) -> String -> ThreadId -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ThreadId -> String -> IO ()
labelThread String
threadLabel

runAlarmClock :: TimeScale t => AlarmClock t -> (t -> IO ()) -> IO ()
runAlarmClock :: AlarmClock t -> (t -> IO ()) -> IO ()
runAlarmClock AlarmClock{IO ()
TVar (AlarmSetting t)
acNewSetting :: TVar (AlarmSetting t)
acWaitForExit :: IO ()
acNewSetting :: forall t. AlarmClock t -> TVar (AlarmSetting t)
acWaitForExit :: forall t. AlarmClock t -> IO ()
..} t -> IO ()
wakeUpAction = String -> IO ()
labelMyThread String
"alarmclock" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
  where
  loop :: IO ()
  loop :: IO ()
loop = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically STM (IO ())
whenNotSet

  whenNotSet :: STM (IO ())
  whenNotSet :: STM (IO ())
whenNotSet = TVar (AlarmSetting t) -> STM (AlarmSetting t)
forall a. TVar a -> STM a
readTVar TVar (AlarmSetting t)
acNewSetting STM (AlarmSetting t)
-> (AlarmSetting t -> STM (IO ())) -> STM (IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    AlarmSetting t
AlarmNotSet         -> STM (IO ())
forall a. STM a
retry
    AlarmSetting t
AlarmDestroyed      -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    AlarmSet t
wakeUpTime -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ t -> IO ()
whenSet t
wakeUpTime

  whenSet :: t -> IO ()
whenSet t
wakeUpTime = do
    t
now <- IO t
forall t. TimeScale t => IO t
getAbsoluteTime
    let microsecondsTimeout :: Integer
microsecondsTimeout = t -> t -> Integer
forall t. TimeScale t => t -> t -> Integer
microsecondsDiff t
wakeUpTime t
now
    if Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
microsecondsTimeout
      then IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (Async () -> IO (IO ())) -> IO (IO ())
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (Integer -> IO ()
delay Integer
microsecondsTimeout) ((Async () -> IO (IO ())) -> IO (IO ()))
-> (Async () -> IO (IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Async ()
a -> STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$
                      (Async () -> STM ()
forall a. Async a -> STM a
waitSTM Async ()
a STM () -> STM (IO ()) -> STM (IO ())
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> IO ()
whenSet t
wakeUpTime))
                    STM (IO ()) -> STM (IO ()) -> STM (IO ())
forall a. STM a -> STM a -> STM a
`orElse`
                      (TVar (AlarmSetting t) -> STM (AlarmSetting t)
forall a. TVar a -> STM a
readTVar TVar (AlarmSetting t)
acNewSetting STM (AlarmSetting t)
-> (AlarmSetting t -> STM (IO ())) -> STM (IO ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                          AlarmSet t
wakeUpTime' | t -> t -> t
forall t. TimeScale t => t -> t -> t
earlierOf t
wakeUpTime' t
wakeUpTime t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
wakeUpTime -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ t -> IO ()
whenSet t
wakeUpTime'
                          AlarmSetting t
AlarmDestroyed                                                        -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          AlarmSetting t
_                                                                     -> STM (IO ())
forall a. STM a
retry
                      )

      else do
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (AlarmSetting t)
-> (AlarmSetting t -> AlarmSetting t) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (AlarmSetting t)
acNewSetting ((AlarmSetting t -> AlarmSetting t) -> STM ())
-> (AlarmSetting t -> AlarmSetting t) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
          AlarmSet t
_ -> AlarmSetting t
forall t. AlarmSetting t
AlarmNotSet
          AlarmSetting t
setting    -> AlarmSetting t
setting
        t -> IO ()
wakeUpAction t
now
        IO ()
loop