{-| Abstraction that allows for a choice of timescale when setting alarms.
Exposed in a separate module so it can be faked for testing purposes, but
client applications should just import "Control.Concurrent.AlarmClock". -}

module Control.Concurrent.AlarmClock.TimeScale where

import           Data.Time    (UTCTime, diffUTCTime, getCurrentTime)
import           System.Clock (Clock (Monotonic), TimeSpec, diffTimeSpec,
                               getTime, toNanoSecs)

{-| Abstraction that allows for a choice between the UTC timescale and a
monotonic timescale, which differ in their handling of irregularities such as
clock adjustments and leap seconds.

Alarms set using the 'UTCTime' timescale wait for the system clock to pass the
given time before going off, and account for the clock being adjusted
backwards and for (positive) leap seconds while waiting. If the clock is set
forwards, or a negative leap second occurs, then the alarm may go off later
than expected by an amount that is roughly equal to the adjustment. It is
possible to correct for this by setting the alarm again after the adjustment
has occurred.

The 'Monotonic' timescale cannot be so adjusted, which may be more suitable for
some applications.

Note that the timeliness of the alarm going off is very much on a "best effort"
basis, and there are many environmental factors that could cause the alarm to
go off later than expected.

-}

class Eq t => TimeScale t where
  getAbsoluteTime   :: IO t
  microsecondsDiff  :: t -> t -> Integer
  earlierOf         :: t -> t -> t

instance TimeScale UTCTime where
  getAbsoluteTime :: IO UTCTime
getAbsoluteTime        = IO UTCTime
getCurrentTime
  earlierOf :: UTCTime -> UTCTime -> UTCTime
earlierOf              = UTCTime -> UTCTime -> UTCTime
forall a. Ord a => a -> a -> a
min
  microsecondsDiff :: UTCTime -> UTCTime -> Integer
microsecondsDiff UTCTime
t1 UTCTime
t2 = NominalDiffTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (NominalDiffTime -> Integer) -> NominalDiffTime -> Integer
forall a b. (a -> b) -> a -> b
$ (NominalDiffTime
1000000 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
*) (NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1 UTCTime
t2

{-| Representation of system monotonic clock. -}
newtype MonotonicTime = MonotonicTime TimeSpec deriving (Int -> MonotonicTime -> ShowS
[MonotonicTime] -> ShowS
MonotonicTime -> String
(Int -> MonotonicTime -> ShowS)
-> (MonotonicTime -> String)
-> ([MonotonicTime] -> ShowS)
-> Show MonotonicTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MonotonicTime] -> ShowS
$cshowList :: [MonotonicTime] -> ShowS
show :: MonotonicTime -> String
$cshow :: MonotonicTime -> String
showsPrec :: Int -> MonotonicTime -> ShowS
$cshowsPrec :: Int -> MonotonicTime -> ShowS
Show, MonotonicTime -> MonotonicTime -> Bool
(MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool) -> Eq MonotonicTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MonotonicTime -> MonotonicTime -> Bool
$c/= :: MonotonicTime -> MonotonicTime -> Bool
== :: MonotonicTime -> MonotonicTime -> Bool
$c== :: MonotonicTime -> MonotonicTime -> Bool
Eq, Eq MonotonicTime
Eq MonotonicTime
-> (MonotonicTime -> MonotonicTime -> Ordering)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> Ord MonotonicTime
MonotonicTime -> MonotonicTime -> Bool
MonotonicTime -> MonotonicTime -> Ordering
MonotonicTime -> MonotonicTime -> MonotonicTime
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MonotonicTime -> MonotonicTime -> MonotonicTime
$cmin :: MonotonicTime -> MonotonicTime -> MonotonicTime
max :: MonotonicTime -> MonotonicTime -> MonotonicTime
$cmax :: MonotonicTime -> MonotonicTime -> MonotonicTime
>= :: MonotonicTime -> MonotonicTime -> Bool
$c>= :: MonotonicTime -> MonotonicTime -> Bool
> :: MonotonicTime -> MonotonicTime -> Bool
$c> :: MonotonicTime -> MonotonicTime -> Bool
<= :: MonotonicTime -> MonotonicTime -> Bool
$c<= :: MonotonicTime -> MonotonicTime -> Bool
< :: MonotonicTime -> MonotonicTime -> Bool
$c< :: MonotonicTime -> MonotonicTime -> Bool
compare :: MonotonicTime -> MonotonicTime -> Ordering
$ccompare :: MonotonicTime -> MonotonicTime -> Ordering
$cp1Ord :: Eq MonotonicTime
Ord)

instance TimeScale MonotonicTime where
  getAbsoluteTime :: IO MonotonicTime
getAbsoluteTime = TimeSpec -> MonotonicTime
MonotonicTime (TimeSpec -> MonotonicTime) -> IO TimeSpec -> IO MonotonicTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clock -> IO TimeSpec
getTime Clock
Monotonic
  earlierOf :: MonotonicTime -> MonotonicTime -> MonotonicTime
earlierOf       = MonotonicTime -> MonotonicTime -> MonotonicTime
forall a. Ord a => a -> a -> a
min
  microsecondsDiff :: MonotonicTime -> MonotonicTime -> Integer
microsecondsDiff (MonotonicTime TimeSpec
t1) (MonotonicTime TimeSpec
t2)
    | TimeSpec
t1 TimeSpec -> TimeSpec -> Bool
forall a. Ord a => a -> a -> Bool
< TimeSpec
t2 = -MonotonicTime -> MonotonicTime -> Integer
forall t. TimeScale t => t -> t -> Integer
microsecondsDiff (TimeSpec -> MonotonicTime
MonotonicTime TimeSpec
t2) (TimeSpec -> MonotonicTime
MonotonicTime TimeSpec
t1)
    | Bool
otherwise = (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000) (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Integer
toNanoSecs (TimeSpec -> Integer) -> TimeSpec -> Integer
forall a b. (a -> b) -> a -> b
$ TimeSpec -> TimeSpec -> TimeSpec
diffTimeSpec TimeSpec
t1 TimeSpec
t2