{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Distributed.Process.Extras.Timer
-- Copyright   :  (c) Tim Watson 2012 - 2017
-- License     :  BSD3 (see the file LICENSE)
--
-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (requires concurrency)
--
-- Provides an API for running code or sending messages, either after some
-- initial delay or periodically, and for cancelling, re-setting and/or
-- flushing pending /timers/.
-----------------------------------------------------------------------------

module Control.Distributed.Process.Extras.Timer
  (
    TimerRef
  , Tick(Tick)
  , sleep
  , sleepFor
  , sendAfter
  , runAfter
  , exitAfter
  , killAfter
  , startTimer
  , ticker
  , periodically
  , resetTimer
  , cancelTimer
  , flushTimer
  ) where

import Control.DeepSeq (NFData(..))
import Control.Distributed.Process hiding (send)
import Control.Distributed.Process.Serializable
import Control.Distributed.Process.Extras.UnsafePrimitives (send)
import Control.Distributed.Process.Extras.Internal.Types (NFSerializable)
import Control.Distributed.Process.Extras.Time
import Control.Monad (unless, void)
import Data.Binary
import Data.Typeable (Typeable)
import Prelude hiding (init)

import GHC.Generics

-- | an opaque reference to a timer
type TimerRef = ProcessId

-- | cancellation message sent to timers
data TimerConfig = Reset | Cancel
    deriving (Typeable, (forall x. TimerConfig -> Rep TimerConfig x)
-> (forall x. Rep TimerConfig x -> TimerConfig)
-> Generic TimerConfig
forall x. Rep TimerConfig x -> TimerConfig
forall x. TimerConfig -> Rep TimerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TimerConfig -> Rep TimerConfig x
from :: forall x. TimerConfig -> Rep TimerConfig x
$cto :: forall x. Rep TimerConfig x -> TimerConfig
to :: forall x. Rep TimerConfig x -> TimerConfig
Generic, TimerConfig -> TimerConfig -> Bool
(TimerConfig -> TimerConfig -> Bool)
-> (TimerConfig -> TimerConfig -> Bool) -> Eq TimerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimerConfig -> TimerConfig -> Bool
== :: TimerConfig -> TimerConfig -> Bool
$c/= :: TimerConfig -> TimerConfig -> Bool
/= :: TimerConfig -> TimerConfig -> Bool
Eq, Int -> TimerConfig -> ShowS
[TimerConfig] -> ShowS
TimerConfig -> String
(Int -> TimerConfig -> ShowS)
-> (TimerConfig -> String)
-> ([TimerConfig] -> ShowS)
-> Show TimerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimerConfig -> ShowS
showsPrec :: Int -> TimerConfig -> ShowS
$cshow :: TimerConfig -> String
show :: TimerConfig -> String
$cshowList :: [TimerConfig] -> ShowS
showList :: [TimerConfig] -> ShowS
Show)
instance Binary TimerConfig where
instance NFData TimerConfig where
  rnf :: TimerConfig -> ()
rnf TimerConfig
tc = TimerConfig
tc TimerConfig -> () -> ()
forall a b. a -> b -> b
`seq` ()

-- | represents a 'tick' event that timers can generate
data Tick = Tick
    deriving (Typeable, (forall x. Tick -> Rep Tick x)
-> (forall x. Rep Tick x -> Tick) -> Generic Tick
forall x. Rep Tick x -> Tick
forall x. Tick -> Rep Tick x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Tick -> Rep Tick x
from :: forall x. Tick -> Rep Tick x
$cto :: forall x. Rep Tick x -> Tick
to :: forall x. Rep Tick x -> Tick
Generic, Tick -> Tick -> Bool
(Tick -> Tick -> Bool) -> (Tick -> Tick -> Bool) -> Eq Tick
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tick -> Tick -> Bool
== :: Tick -> Tick -> Bool
$c/= :: Tick -> Tick -> Bool
/= :: Tick -> Tick -> Bool
Eq, Int -> Tick -> ShowS
[Tick] -> ShowS
Tick -> String
(Int -> Tick -> ShowS)
-> (Tick -> String) -> ([Tick] -> ShowS) -> Show Tick
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tick -> ShowS
showsPrec :: Int -> Tick -> ShowS
$cshow :: Tick -> String
show :: Tick -> String
$cshowList :: [Tick] -> ShowS
showList :: [Tick] -> ShowS
Show)
instance Binary Tick where
instance NFData Tick where
  rnf :: Tick -> ()
rnf Tick
t = Tick
t Tick -> () -> ()
forall a b. a -> b -> b
`seq` ()

data SleepingPill = SleepingPill
    deriving (Typeable, (forall x. SleepingPill -> Rep SleepingPill x)
-> (forall x. Rep SleepingPill x -> SleepingPill)
-> Generic SleepingPill
forall x. Rep SleepingPill x -> SleepingPill
forall x. SleepingPill -> Rep SleepingPill x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SleepingPill -> Rep SleepingPill x
from :: forall x. SleepingPill -> Rep SleepingPill x
$cto :: forall x. Rep SleepingPill x -> SleepingPill
to :: forall x. Rep SleepingPill x -> SleepingPill
Generic, SleepingPill -> SleepingPill -> Bool
(SleepingPill -> SleepingPill -> Bool)
-> (SleepingPill -> SleepingPill -> Bool) -> Eq SleepingPill
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SleepingPill -> SleepingPill -> Bool
== :: SleepingPill -> SleepingPill -> Bool
$c/= :: SleepingPill -> SleepingPill -> Bool
/= :: SleepingPill -> SleepingPill -> Bool
Eq, Int -> SleepingPill -> ShowS
[SleepingPill] -> ShowS
SleepingPill -> String
(Int -> SleepingPill -> ShowS)
-> (SleepingPill -> String)
-> ([SleepingPill] -> ShowS)
-> Show SleepingPill
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SleepingPill -> ShowS
showsPrec :: Int -> SleepingPill -> ShowS
$cshow :: SleepingPill -> String
show :: SleepingPill -> String
$cshowList :: [SleepingPill] -> ShowS
showList :: [SleepingPill] -> ShowS
Show)
instance Binary SleepingPill where
instance NFData SleepingPill where

--------------------------------------------------------------------------------
-- API                                                                        --
--------------------------------------------------------------------------------

-- | blocks the calling Process for the specified TimeInterval. Note that this
-- function assumes that a blocking receive is the most efficient approach to
-- acheiving this, however the runtime semantics (particularly with regards
-- scheduling) should not differ from threadDelay in practise.
sleep :: TimeInterval -> Process ()
sleep :: TimeInterval -> Process ()
sleep TimeInterval
t =
  let ms :: Int
ms = TimeInterval -> Int
asTimeout TimeInterval
t in do
  Maybe ()
_ <- Int -> [Match ()] -> Process (Maybe ())
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout Int
ms [(SleepingPill -> Bool) -> (SleepingPill -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\SleepingPill
SleepingPill -> Bool
True)
                                  (\SleepingPill
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())]
  () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Literate way of saying @sleepFor 3 Seconds@.
sleepFor :: Int -> TimeUnit -> Process ()
sleepFor :: Int -> TimeUnit -> Process ()
sleepFor Int
i TimeUnit
u = TimeInterval -> Process ()
sleep (Int -> TimeUnit -> TimeInterval
within Int
i TimeUnit
u)

-- | starts a timer which sends the supplied message to the destination
-- process after the specified time interval.
sendAfter :: (NFSerializable a)
          => TimeInterval
          -> ProcessId
          -> a
          -> Process TimerRef
sendAfter :: forall a.
NFSerializable a =>
TimeInterval -> ProcessId -> a -> Process ProcessId
sendAfter TimeInterval
t ProcessId
pid a
msg = TimeInterval -> Process () -> Process ProcessId
runAfter TimeInterval
t Process ()
proc
  where proc :: Process ()
proc = ProcessId -> a -> Process ()
forall m. NFSerializable m => ProcessId -> m -> Process ()
send ProcessId
pid a
msg

-- | runs the supplied process action(s) after @t@ has elapsed
runAfter :: TimeInterval -> Process () -> Process TimerRef
runAfter :: TimeInterval -> Process () -> Process ProcessId
runAfter TimeInterval
t Process ()
p = Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ TimeInterval -> Process () -> Bool -> Process ()
runTimer TimeInterval
t Process ()
p Bool
True

-- | calls @exit pid reason@ after @t@ has elapsed
exitAfter :: (Serializable a)
             => TimeInterval
             -> ProcessId
             -> a
             -> Process TimerRef
exitAfter :: forall a.
Serializable a =>
TimeInterval -> ProcessId -> a -> Process ProcessId
exitAfter TimeInterval
delay ProcessId
pid a
reason = TimeInterval -> Process () -> Process ProcessId
runAfter TimeInterval
delay (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ ProcessId -> a -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
exit ProcessId
pid a
reason

-- | kills the specified process after @t@ has elapsed
killAfter :: TimeInterval -> ProcessId -> String -> Process TimerRef
killAfter :: TimeInterval -> ProcessId -> String -> Process ProcessId
killAfter TimeInterval
delay ProcessId
pid String
why = TimeInterval -> Process () -> Process ProcessId
runAfter TimeInterval
delay (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ ProcessId -> String -> Process ()
kill ProcessId
pid String
why

-- | starts a timer that repeatedly sends the supplied message to the destination
-- process each time the specified time interval elapses. To stop messages from
-- being sent in future, 'cancelTimer' can be called.
startTimer :: (NFSerializable a)
           => TimeInterval
           -> ProcessId
           -> a
           -> Process TimerRef
startTimer :: forall a.
NFSerializable a =>
TimeInterval -> ProcessId -> a -> Process ProcessId
startTimer TimeInterval
t ProcessId
pid a
msg = TimeInterval -> Process () -> Process ProcessId
periodically TimeInterval
t (ProcessId -> a -> Process ()
forall m. NFSerializable m => ProcessId -> m -> Process ()
send ProcessId
pid a
msg)

-- | runs the supplied process action(s) repeatedly at intervals of @t@
periodically :: TimeInterval -> Process () -> Process TimerRef
periodically :: TimeInterval -> Process () -> Process ProcessId
periodically TimeInterval
t Process ()
p = Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ TimeInterval -> Process () -> Bool -> Process ()
runTimer TimeInterval
t Process ()
p Bool
False

-- | resets a running timer. Note: Cancelling a timer does not guarantee that
-- all its messages are prevented from being delivered to the target process.
-- Also note that resetting an ongoing timer (started using the 'startTimer' or
-- 'periodically' functions) will only cause the current elapsed period to time
-- out, after which the timer will continue running. To stop a long-running
-- timer permanently, you should use 'cancelTimer' instead.
resetTimer :: TimerRef -> Process ()
resetTimer :: ProcessId -> Process ()
resetTimer = (ProcessId -> TimerConfig -> Process ())
-> TimerConfig -> ProcessId -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProcessId -> TimerConfig -> Process ()
forall m. NFSerializable m => ProcessId -> m -> Process ()
send TimerConfig
Reset

-- | permanently cancels a timer
cancelTimer :: TimerRef -> Process ()
cancelTimer :: ProcessId -> Process ()
cancelTimer = (ProcessId -> TimerConfig -> Process ())
-> TimerConfig -> ProcessId -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProcessId -> TimerConfig -> Process ()
forall m. NFSerializable m => ProcessId -> m -> Process ()
send TimerConfig
Cancel

-- | cancels a running timer and flushes any viable timer messages from the
-- process' message queue. This function should only be called by the process
-- expecting to receive the timer's messages!
flushTimer :: (Serializable a, Eq a) => TimerRef -> a -> Delay -> Process ()
flushTimer :: forall a.
(Serializable a, Eq a) =>
ProcessId -> a -> Delay -> Process ()
flushTimer ProcessId
ref a
ignore Delay
t = do
    MonitorRef
mRef <- ProcessId -> Process MonitorRef
monitor ProcessId
ref
    ProcessId -> Process ()
cancelTimer ProcessId
ref
    MonitorRef -> Delay -> Process ()
performFlush MonitorRef
mRef Delay
t
    () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where performFlush :: MonitorRef -> Delay -> Process ()
performFlush MonitorRef
mRef Delay
Infinity  = [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait ([Match ()] -> Process ()) -> [Match ()] -> Process ()
forall a b. (a -> b) -> a -> b
$ MonitorRef -> [Match ()]
filters MonitorRef
mRef
        performFlush MonitorRef
mRef Delay
NoDelay   = MonitorRef -> Delay -> Process ()
performFlush MonitorRef
mRef (TimeInterval -> Delay
Delay (TimeInterval -> Delay) -> TimeInterval -> Delay
forall a b. (a -> b) -> a -> b
$ Int -> TimeInterval
microSeconds Int
0)
        performFlush MonitorRef
mRef (Delay TimeInterval
i) = Process (Maybe ()) -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int -> [Match ()] -> Process (Maybe ())
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout (TimeInterval -> Int
asTimeout TimeInterval
i) (MonitorRef -> [Match ()]
filters MonitorRef
mRef))
        filters :: MonitorRef -> [Match ()]
filters MonitorRef
mRef = [
                (a -> Bool) -> (a -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ignore)
                        (\a
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , (ProcessMonitorNotification -> Bool)
-> (ProcessMonitorNotification -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(ProcessMonitorNotification MonitorRef
mRef' ProcessId
_ DiedReason
_) -> MonitorRef
mRef MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
mRef')
                        (\ProcessMonitorNotification
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]

-- | sets up a timer that sends 'Tick' repeatedly at intervals of @t@
ticker :: TimeInterval -> ProcessId -> Process TimerRef
ticker :: TimeInterval -> ProcessId -> Process ProcessId
ticker TimeInterval
t ProcessId
pid = TimeInterval -> ProcessId -> Tick -> Process ProcessId
forall a.
NFSerializable a =>
TimeInterval -> ProcessId -> a -> Process ProcessId
startTimer TimeInterval
t ProcessId
pid Tick
Tick

--------------------------------------------------------------------------------
-- Implementation                                                             --
--------------------------------------------------------------------------------

-- runs the timer process
runTimer :: TimeInterval -> Process () -> Bool -> Process ()
runTimer :: TimeInterval -> Process () -> Bool -> Process ()
runTimer TimeInterval
t Process ()
proc Bool
cancelOnReset = do
    Maybe TimerConfig
cancel <- Int -> Process (Maybe TimerConfig)
forall a. Serializable a => Int -> Process (Maybe a)
expectTimeout (TimeInterval -> Int
asTimeout TimeInterval
t)
    -- say $ "cancel = " ++ (show cancel) ++ "\n"
    case Maybe TimerConfig
cancel of
        Maybe TimerConfig
Nothing     -> Bool -> Process ()
runProc Bool
cancelOnReset
        Just TimerConfig
Cancel -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just TimerConfig
Reset  -> Bool -> Process () -> Process ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cancelOnReset (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ TimeInterval -> Process () -> Bool -> Process ()
runTimer TimeInterval
t Process ()
proc Bool
cancelOnReset
  where runProc :: Bool -> Process ()
runProc Bool
True  = Process ()
proc
        runProc Bool
False = Process ()
proc Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TimeInterval -> Process () -> Bool -> Process ()
runTimer TimeInterval
t Process ()
proc Bool
cancelOnReset