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

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Distributed.Process.Extras.Time
-- Copyright   :  (c) Tim Watson, Jeff Epstein, Alan Zimmerman
-- License     :  BSD3 (see the file LICENSE)
--
-- Maintainer  :  Tim Watson
-- Stability   :  experimental
-- Portability :  non-portable (requires concurrency)
--
-- This module provides facilities for working with time delays and timeouts.
-- The type 'Timeout' and the 'timeout' family of functions provide mechanisms
-- for working with @threadDelay@-like behaviour that operates on microsecond
-- values.
--
-- The 'TimeInterval' and 'TimeUnit' related functions provide an abstraction
-- for working with various time intervals, whilst the 'Delay' type provides a
-- corrolary to 'timeout' that works with these.
-----------------------------------------------------------------------------

module Control.Distributed.Process.Extras.Time
  ( -- * Time interval handling
    microSeconds
  , milliSeconds
  , seconds
  , minutes
  , hours
  , asTimeout
  , after
  , within
  , timeToMicros
  , TimeInterval
  , TimeUnit(..)
  , Delay(..)

  -- * Conversion To/From NominalDiffTime
  , timeIntervalToDiffTime
  , diffTimeToTimeInterval
  , diffTimeToDelay
  , delayToDiffTime
  , microsecondsToNominalDiffTime

    -- * (Legacy) Timeout Handling
  , Timeout
  , TimeoutNotification(..)
  , timeout
  , infiniteWait
  , noWait
  ) where

import Control.Concurrent (threadDelay)
import Control.DeepSeq (NFData)
import Control.Distributed.Process
import Control.Distributed.Process.Extras.Internal.Types
import Control.Monad (void)
import Data.Binary
import Data.Ratio ((%))
import Data.Time.Clock
import Data.Typeable (Typeable)

import GHC.Generics

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

-- | Defines the time unit for a Timeout value
data TimeUnit = Days | Hours | Minutes | Seconds | Millis | Micros
    deriving (Typeable, (forall x. TimeUnit -> Rep TimeUnit x)
-> (forall x. Rep TimeUnit x -> TimeUnit) -> Generic TimeUnit
forall x. Rep TimeUnit x -> TimeUnit
forall x. TimeUnit -> Rep TimeUnit x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TimeUnit -> Rep TimeUnit x
from :: forall x. TimeUnit -> Rep TimeUnit x
$cto :: forall x. Rep TimeUnit x -> TimeUnit
to :: forall x. Rep TimeUnit x -> TimeUnit
Generic, TimeUnit -> TimeUnit -> Bool
(TimeUnit -> TimeUnit -> Bool)
-> (TimeUnit -> TimeUnit -> Bool) -> Eq TimeUnit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimeUnit -> TimeUnit -> Bool
== :: TimeUnit -> TimeUnit -> Bool
$c/= :: TimeUnit -> TimeUnit -> Bool
/= :: TimeUnit -> TimeUnit -> Bool
Eq, Int -> TimeUnit -> ShowS
[TimeUnit] -> ShowS
TimeUnit -> String
(Int -> TimeUnit -> ShowS)
-> (TimeUnit -> String) -> ([TimeUnit] -> ShowS) -> Show TimeUnit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeUnit -> ShowS
showsPrec :: Int -> TimeUnit -> ShowS
$cshow :: TimeUnit -> String
show :: TimeUnit -> String
$cshowList :: [TimeUnit] -> ShowS
showList :: [TimeUnit] -> ShowS
Show)

instance Binary TimeUnit where
instance NFData TimeUnit where

-- | A time interval.
data TimeInterval = TimeInterval TimeUnit Int
    deriving (Typeable, (forall x. TimeInterval -> Rep TimeInterval x)
-> (forall x. Rep TimeInterval x -> TimeInterval)
-> Generic TimeInterval
forall x. Rep TimeInterval x -> TimeInterval
forall x. TimeInterval -> Rep TimeInterval x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TimeInterval -> Rep TimeInterval x
from :: forall x. TimeInterval -> Rep TimeInterval x
$cto :: forall x. Rep TimeInterval x -> TimeInterval
to :: forall x. Rep TimeInterval x -> TimeInterval
Generic, TimeInterval -> TimeInterval -> Bool
(TimeInterval -> TimeInterval -> Bool)
-> (TimeInterval -> TimeInterval -> Bool) -> Eq TimeInterval
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimeInterval -> TimeInterval -> Bool
== :: TimeInterval -> TimeInterval -> Bool
$c/= :: TimeInterval -> TimeInterval -> Bool
/= :: TimeInterval -> TimeInterval -> Bool
Eq, Int -> TimeInterval -> ShowS
[TimeInterval] -> ShowS
TimeInterval -> String
(Int -> TimeInterval -> ShowS)
-> (TimeInterval -> String)
-> ([TimeInterval] -> ShowS)
-> Show TimeInterval
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeInterval -> ShowS
showsPrec :: Int -> TimeInterval -> ShowS
$cshow :: TimeInterval -> String
show :: TimeInterval -> String
$cshowList :: [TimeInterval] -> ShowS
showList :: [TimeInterval] -> ShowS
Show)

instance Binary TimeInterval where
instance NFData TimeInterval where

-- | Represents either a delay of 'TimeInterval', an infinite wait or no delay
-- (i.e., non-blocking).
data Delay = Delay TimeInterval | Infinity | NoDelay
    deriving (Typeable, (forall x. Delay -> Rep Delay x)
-> (forall x. Rep Delay x -> Delay) -> Generic Delay
forall x. Rep Delay x -> Delay
forall x. Delay -> Rep Delay x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Delay -> Rep Delay x
from :: forall x. Delay -> Rep Delay x
$cto :: forall x. Rep Delay x -> Delay
to :: forall x. Rep Delay x -> Delay
Generic, Delay -> Delay -> Bool
(Delay -> Delay -> Bool) -> (Delay -> Delay -> Bool) -> Eq Delay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Delay -> Delay -> Bool
== :: Delay -> Delay -> Bool
$c/= :: Delay -> Delay -> Bool
/= :: Delay -> Delay -> Bool
Eq, Int -> Delay -> ShowS
[Delay] -> ShowS
Delay -> String
(Int -> Delay -> ShowS)
-> (Delay -> String) -> ([Delay] -> ShowS) -> Show Delay
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Delay -> ShowS
showsPrec :: Int -> Delay -> ShowS
$cshow :: Delay -> String
show :: Delay -> String
$cshowList :: [Delay] -> ShowS
showList :: [Delay] -> ShowS
Show)

instance Binary Delay where
instance NFData Delay where

-- | Represents a /timeout/ in terms of microseconds, where 'Nothing' stands for
-- infinity and @Just 0@, no-delay.
type Timeout = Maybe Int

-- | Send to a process when a timeout expires.
data TimeoutNotification = TimeoutNotification Tag
       deriving (Typeable)

instance Binary TimeoutNotification where
  get :: Get TimeoutNotification
get = (Int -> TimeoutNotification) -> Get Int -> Get TimeoutNotification
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> TimeoutNotification
TimeoutNotification (Get Int -> Get TimeoutNotification)
-> Get Int -> Get TimeoutNotification
forall a b. (a -> b) -> a -> b
$ Get Int
forall t. Binary t => Get t
get
  put :: TimeoutNotification -> Put
put (TimeoutNotification Int
n) = Int -> Put
forall t. Binary t => t -> Put
put Int
n

-- time interval/unit handling

-- | converts the supplied @TimeInterval@ to microseconds
asTimeout :: TimeInterval -> Int
asTimeout :: TimeInterval -> Int
asTimeout (TimeInterval TimeUnit
u Int
v) = TimeUnit -> Int -> Int
timeToMicros TimeUnit
u Int
v

-- | Convenience for making timeouts; e.g.,
--
-- > receiveTimeout (after 3 Seconds) [ match (\"ok" -> return ()) ]
--
after :: Int -> TimeUnit -> Int
after :: Int -> TimeUnit -> Int
after Int
n TimeUnit
m = TimeUnit -> Int -> Int
timeToMicros TimeUnit
m Int
n

-- | Convenience for making 'TimeInterval'; e.g.,
--
-- > let ti = within 5 Seconds in .....
--
within :: Int -> TimeUnit -> TimeInterval
within :: Int -> TimeUnit -> TimeInterval
within Int
n TimeUnit
m = TimeUnit -> Int -> TimeInterval
TimeInterval TimeUnit
m Int
n

-- | given a number, produces a @TimeInterval@ of microseconds
microSeconds :: Int -> TimeInterval
microSeconds :: Int -> TimeInterval
microSeconds = TimeUnit -> Int -> TimeInterval
TimeInterval TimeUnit
Micros

-- | given a number, produces a @TimeInterval@ of milliseconds
milliSeconds :: Int -> TimeInterval
milliSeconds :: Int -> TimeInterval
milliSeconds = TimeUnit -> Int -> TimeInterval
TimeInterval TimeUnit
Millis

-- | given a number, produces a @TimeInterval@ of seconds
seconds :: Int -> TimeInterval
seconds :: Int -> TimeInterval
seconds = TimeUnit -> Int -> TimeInterval
TimeInterval TimeUnit
Seconds

-- | given a number, produces a @TimeInterval@ of minutes
minutes :: Int -> TimeInterval
minutes :: Int -> TimeInterval
minutes = TimeUnit -> Int -> TimeInterval
TimeInterval TimeUnit
Minutes

-- | given a number, produces a @TimeInterval@ of hours
hours :: Int -> TimeInterval
hours :: Int -> TimeInterval
hours = TimeUnit -> Int -> TimeInterval
TimeInterval TimeUnit
Hours

-- TODO: is timeToMicros efficient enough?

-- | converts the supplied @TimeUnit@ to microseconds
{-# INLINE timeToMicros #-}
timeToMicros :: TimeUnit -> Int -> Int
timeToMicros :: TimeUnit -> Int -> Int
timeToMicros TimeUnit
Micros  Int
us   = Int
us
timeToMicros TimeUnit
Millis  Int
ms   = Int
ms  Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
10 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
3 :: Int)) -- (1000µs == 1ms)
timeToMicros TimeUnit
Seconds Int
secs = TimeUnit -> Int -> Int
timeToMicros TimeUnit
Millis  (Int
secs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
milliSecondsPerSecond)
timeToMicros TimeUnit
Minutes Int
mins = TimeUnit -> Int -> Int
timeToMicros TimeUnit
Seconds (Int
mins Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
secondsPerMinute)
timeToMicros TimeUnit
Hours   Int
hrs  = TimeUnit -> Int -> Int
timeToMicros TimeUnit
Minutes (Int
hrs  Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
minutesPerHour)
timeToMicros TimeUnit
Days    Int
days = TimeUnit -> Int -> Int
timeToMicros TimeUnit
Hours   (Int
days Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hoursPerDay)

{-# INLINE hoursPerDay #-}
hoursPerDay :: Int
hoursPerDay :: Int
hoursPerDay = Int
24

{-# INLINE minutesPerHour #-}
minutesPerHour :: Int
minutesPerHour :: Int
minutesPerHour = Int
60

{-# INLINE secondsPerMinute #-}
secondsPerMinute :: Int
secondsPerMinute :: Int
secondsPerMinute = Int
60

{-# INLINE milliSecondsPerSecond #-}
milliSecondsPerSecond :: Int
milliSecondsPerSecond :: Int
milliSecondsPerSecond = Int
1000

{-# INLINE microSecondsPerSecond #-}
microSecondsPerSecond :: Int
microSecondsPerSecond :: Int
microSecondsPerSecond = Int
1000000

-- timeouts/delays (microseconds)

-- | Constructs an inifinite 'Timeout'.
infiniteWait :: Timeout
infiniteWait :: Timeout
infiniteWait = Timeout
forall a. Maybe a
Nothing

-- | Constructs a no-wait 'Timeout'
noWait :: Timeout
noWait :: Timeout
noWait = Int -> Timeout
forall a. a -> Maybe a
Just Int
0

-- | Sends the calling process @TimeoutNotification tag@ after @time@ microseconds
timeout :: Int -> Tag -> ProcessId -> Process ()
timeout :: Int -> Int -> ProcessId -> Process ()
timeout Int
time Int
tag ProcessId
p =
  Process ProcessId -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process ProcessId -> Process ())
-> Process ProcessId -> Process ()
forall a b. (a -> b) -> a -> b
$ Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$
               do IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
time
                  ProcessId -> TimeoutNotification -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p (Int -> TimeoutNotification
TimeoutNotification Int
tag)

-- Converting to/from Data.Time.Clock NominalDiffTime

-- | given a @TimeInterval@, provide an equivalent @NominalDiffTim@
timeIntervalToDiffTime :: TimeInterval -> NominalDiffTime
timeIntervalToDiffTime :: TimeInterval -> NominalDiffTime
timeIntervalToDiffTime TimeInterval
ti = Integer -> NominalDiffTime
microsecondsToNominalDiffTime (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ TimeInterval -> Int
asTimeout TimeInterval
ti)

-- | given a @NominalDiffTim@@, provide an equivalent @TimeInterval@
diffTimeToTimeInterval :: NominalDiffTime -> TimeInterval
diffTimeToTimeInterval :: NominalDiffTime -> TimeInterval
diffTimeToTimeInterval NominalDiffTime
dt = Int -> TimeInterval
microSeconds (Int -> TimeInterval) -> Int -> TimeInterval
forall a b. (a -> b) -> a -> b
$ (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NominalDiffTime -> Integer
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime
dt NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000000) :: Integer))

-- | given a @Delay@, provide an equivalent @NominalDiffTim@
delayToDiffTime :: Delay -> NominalDiffTime
delayToDiffTime :: Delay -> NominalDiffTime
delayToDiffTime (Delay TimeInterval
ti) = TimeInterval -> NominalDiffTime
timeIntervalToDiffTime TimeInterval
ti
delayToDiffTime Delay
Infinity   = String -> NominalDiffTime
forall a. HasCallStack => String -> a
error String
"trying to convert Delay.Infinity to a NominalDiffTime"
delayToDiffTime (Delay
NoDelay)  = Integer -> NominalDiffTime
microsecondsToNominalDiffTime Integer
0

-- | given a @NominalDiffTim@@, provide an equivalent @Delay@
diffTimeToDelay :: NominalDiffTime -> Delay
diffTimeToDelay :: NominalDiffTime -> Delay
diffTimeToDelay NominalDiffTime
dt = TimeInterval -> Delay
Delay (TimeInterval -> Delay) -> TimeInterval -> Delay
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> TimeInterval
diffTimeToTimeInterval NominalDiffTime
dt

-- | Create a 'NominalDiffTime' from a number of microseconds.
microsecondsToNominalDiffTime :: Integer -> NominalDiffTime
microsecondsToNominalDiffTime :: Integer -> NominalDiffTime
microsecondsToNominalDiffTime Integer
x = Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Integer
x Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
microSecondsPerSecond))

-- tenYearsAsMicroSeconds :: Integer
-- tenYearsAsMicroSeconds = 10 * 365 * 24 * 60 * 60 * 1000000

-- | Allow @(+)@ and @(-)@ operations on @TimeInterval@s
instance Num TimeInterval where
  TimeInterval
t1 + :: TimeInterval -> TimeInterval -> TimeInterval
+ TimeInterval
t2 = Int -> TimeInterval
microSeconds (Int -> TimeInterval) -> Int -> TimeInterval
forall a b. (a -> b) -> a -> b
$ TimeInterval -> Int
asTimeout TimeInterval
t1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ TimeInterval -> Int
asTimeout TimeInterval
t2
  TimeInterval
t1 - :: TimeInterval -> TimeInterval -> TimeInterval
- TimeInterval
t2 = Int -> TimeInterval
microSeconds (Int -> TimeInterval) -> Int -> TimeInterval
forall a b. (a -> b) -> a -> b
$ TimeInterval -> Int
asTimeout TimeInterval
t1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- TimeInterval -> Int
asTimeout TimeInterval
t2
  TimeInterval
_ * :: TimeInterval -> TimeInterval -> TimeInterval
* TimeInterval
_ = String -> TimeInterval
forall a. HasCallStack => String -> a
error String
"trying to multiply two TimeIntervals"
  abs :: TimeInterval -> TimeInterval
abs TimeInterval
t = Int -> TimeInterval
microSeconds (Int -> TimeInterval) -> Int -> TimeInterval
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs (TimeInterval -> Int
asTimeout TimeInterval
t)
  signum :: TimeInterval -> TimeInterval
signum TimeInterval
t = if (TimeInterval -> Int
asTimeout TimeInterval
t) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
              then TimeInterval
0
              else if (TimeInterval -> Int
asTimeout TimeInterval
t) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then -TimeInterval
1
                                        else TimeInterval
1
  fromInteger :: Integer -> TimeInterval
fromInteger Integer
_ = String -> TimeInterval
forall a. HasCallStack => String -> a
error String
"trying to call fromInteger for a TimeInterval. Cannot guess units"

-- | Allow @(+)@ and @(-)@ operations on @Delay@s
instance Num Delay where
  Delay
NoDelay     + :: Delay -> Delay -> Delay
+ Delay
x          = Delay
x
  Delay
Infinity    + Delay
_          = Delay
Infinity
  Delay
x           + Delay
NoDelay    = Delay
x
  Delay
_           + Delay
Infinity   = Delay
Infinity
  (Delay TimeInterval
t1 ) + (Delay TimeInterval
t2) = TimeInterval -> Delay
Delay (TimeInterval
t1 TimeInterval -> TimeInterval -> TimeInterval
forall a. Num a => a -> a -> a
+ TimeInterval
t2)

  Delay
NoDelay     - :: Delay -> Delay -> Delay
- Delay
x          = Delay
x
  Delay
Infinity    - Delay
_          = Delay
Infinity
  Delay
x           - Delay
NoDelay    = Delay
x
  Delay
_           - Delay
Infinity   = Delay
Infinity
  (Delay TimeInterval
t1 ) - (Delay TimeInterval
t2) = TimeInterval -> Delay
Delay (TimeInterval
t1 TimeInterval -> TimeInterval -> TimeInterval
forall a. Num a => a -> a -> a
- TimeInterval
t2)

  Delay
_ * :: Delay -> Delay -> Delay
* Delay
_ = String -> Delay
forall a. HasCallStack => String -> a
error String
"trying to multiply two Delays"

  abs :: Delay -> Delay
abs Delay
NoDelay   = Delay
NoDelay
  abs Delay
Infinity  = Delay
Infinity
  abs (Delay TimeInterval
t) = TimeInterval -> Delay
Delay (TimeInterval -> TimeInterval
forall a. Num a => a -> a
abs TimeInterval
t)

  signum :: Delay -> Delay
signum (Delay
NoDelay) = Delay
0
  signum Delay
Infinity  = Delay
1
  signum (Delay TimeInterval
t) = TimeInterval -> Delay
Delay (TimeInterval -> TimeInterval
forall a. Num a => a -> a
signum TimeInterval
t)

  fromInteger :: Integer -> Delay
fromInteger Integer
0 = Delay
NoDelay
  fromInteger Integer
_ = String -> Delay
forall a. HasCallStack => String -> a
error String
"trying to call fromInteger for a Delay. Cannot guess units"