module Nanotime
  ( Sign (..)
  , TimeDelta (..)
  , timeDeltaFromFracSecs
  , timeDeltaFromNanos
  , timeDeltaToFracSecs
  , timeDeltaToNanos
  , threadDelayDelta
  , TimeLike (..)
  , awaitDelta
  , PosixTime (..)
  , MonoTime (..)
  , monoTimeToFracSecs
  , monoTimeToNanos
  , monoTimeFromFracSecs
  , monoTimeFromNanos
  , NtpTime (..)
  , posixToNtp
  , ntpToPosix
  )
where

import Control.Concurrent (threadDelay)
import Data.Bits (Bits (..))
import Data.Fixed (Fixed (..), Pico)
import Data.Time.Clock (nominalDiffTimeToSeconds)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Word (Word32, Word64)
import GHC.Clock (getMonotonicTimeNSec)
import GHC.Stack (HasCallStack)

-- | Sign (negative or positive) of a magnitude of time difference
data Sign = SignNeg | SignPos
  deriving stock (Sign -> Sign -> Bool
(Sign -> Sign -> Bool) -> (Sign -> Sign -> Bool) -> Eq Sign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Sign -> Sign -> Bool
== :: Sign -> Sign -> Bool
$c/= :: Sign -> Sign -> Bool
/= :: Sign -> Sign -> Bool
Eq, Eq Sign
Eq Sign =>
(Sign -> Sign -> Ordering)
-> (Sign -> Sign -> Bool)
-> (Sign -> Sign -> Bool)
-> (Sign -> Sign -> Bool)
-> (Sign -> Sign -> Bool)
-> (Sign -> Sign -> Sign)
-> (Sign -> Sign -> Sign)
-> Ord Sign
Sign -> Sign -> Bool
Sign -> Sign -> Ordering
Sign -> Sign -> Sign
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
$ccompare :: Sign -> Sign -> Ordering
compare :: Sign -> Sign -> Ordering
$c< :: Sign -> Sign -> Bool
< :: Sign -> Sign -> Bool
$c<= :: Sign -> Sign -> Bool
<= :: Sign -> Sign -> Bool
$c> :: Sign -> Sign -> Bool
> :: Sign -> Sign -> Bool
$c>= :: Sign -> Sign -> Bool
>= :: Sign -> Sign -> Bool
$cmax :: Sign -> Sign -> Sign
max :: Sign -> Sign -> Sign
$cmin :: Sign -> Sign -> Sign
min :: Sign -> Sign -> Sign
Ord, Int -> Sign -> ShowS
[Sign] -> ShowS
Sign -> String
(Int -> Sign -> ShowS)
-> (Sign -> String) -> ([Sign] -> ShowS) -> Show Sign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Sign -> ShowS
showsPrec :: Int -> Sign -> ShowS
$cshow :: Sign -> String
show :: Sign -> String
$cshowList :: [Sign] -> ShowS
showList :: [Sign] -> ShowS
Show, Int -> Sign
Sign -> Int
Sign -> [Sign]
Sign -> Sign
Sign -> Sign -> [Sign]
Sign -> Sign -> Sign -> [Sign]
(Sign -> Sign)
-> (Sign -> Sign)
-> (Int -> Sign)
-> (Sign -> Int)
-> (Sign -> [Sign])
-> (Sign -> Sign -> [Sign])
-> (Sign -> Sign -> [Sign])
-> (Sign -> Sign -> Sign -> [Sign])
-> Enum Sign
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Sign -> Sign
succ :: Sign -> Sign
$cpred :: Sign -> Sign
pred :: Sign -> Sign
$ctoEnum :: Int -> Sign
toEnum :: Int -> Sign
$cfromEnum :: Sign -> Int
fromEnum :: Sign -> Int
$cenumFrom :: Sign -> [Sign]
enumFrom :: Sign -> [Sign]
$cenumFromThen :: Sign -> Sign -> [Sign]
enumFromThen :: Sign -> Sign -> [Sign]
$cenumFromTo :: Sign -> Sign -> [Sign]
enumFromTo :: Sign -> Sign -> [Sign]
$cenumFromThenTo :: Sign -> Sign -> Sign -> [Sign]
enumFromThenTo :: Sign -> Sign -> Sign -> [Sign]
Enum, Sign
Sign -> Sign -> Bounded Sign
forall a. a -> a -> Bounded a
$cminBound :: Sign
minBound :: Sign
$cmaxBound :: Sign
maxBound :: Sign
Bounded)

-- | Signed time difference in nanoseconds since last event
-- Like a 'Nano' (`Fixed E9`) but using a machine word with explicit sign.
data TimeDelta = TimeDelta
  { TimeDelta -> Sign
tdSign :: !Sign
  , TimeDelta -> Word64
tdMag :: !Word64
  }
  deriving stock (Int -> TimeDelta -> ShowS
[TimeDelta] -> ShowS
TimeDelta -> String
(Int -> TimeDelta -> ShowS)
-> (TimeDelta -> String)
-> ([TimeDelta] -> ShowS)
-> Show TimeDelta
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeDelta -> ShowS
showsPrec :: Int -> TimeDelta -> ShowS
$cshow :: TimeDelta -> String
show :: TimeDelta -> String
$cshowList :: [TimeDelta] -> ShowS
showList :: [TimeDelta] -> ShowS
Show)

instance Eq TimeDelta where
  TimeDelta Sign
s1 Word64
m1 == :: TimeDelta -> TimeDelta -> Bool
== TimeDelta Sign
s2 Word64
m2 =
    (Word64
m1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 Bool -> Bool -> Bool
&& Word64
m2 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0) Bool -> Bool -> Bool
|| (Sign
s1 Sign -> Sign -> Bool
forall a. Eq a => a -> a -> Bool
== Sign
s2 Bool -> Bool -> Bool
&& Word64
m1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
m2)

instance Ord TimeDelta where
  compare :: TimeDelta -> TimeDelta -> Ordering
compare (TimeDelta Sign
s1 Word64
m1) (TimeDelta Sign
s2 Word64
m2) =
    if Word64
m1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 Bool -> Bool -> Bool
&& Word64
m2 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
      then Ordering
EQ
      else case Sign
s1 of
        Sign
SignPos ->
          case Sign
s2 of
            Sign
SignPos -> Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
m1 Word64
m2
            Sign
SignNeg -> Ordering
GT
        Sign
SignNeg ->
          case Sign
s2 of
            Sign
SignPos -> Ordering
LT
            Sign
SignNeg -> Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
m2 Word64
m1

instance Bounded TimeDelta where
  minBound :: TimeDelta
minBound = Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignNeg Word64
forall a. Bounded a => a
maxBound
  maxBound :: TimeDelta
maxBound = Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignPos Word64
forall a. Bounded a => a
maxBound

instance Semigroup TimeDelta where
  td1 :: TimeDelta
td1@(TimeDelta Sign
s1 Word64
m1) <> :: TimeDelta -> TimeDelta -> TimeDelta
<> td2 :: TimeDelta
td2@(TimeDelta Sign
s2 Word64
m2) =
    if
      | Word64
m1 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 -> TimeDelta
td2
      | Word64
m2 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 -> TimeDelta
td1
      | Sign
s1 Sign -> Sign -> Bool
forall a. Eq a => a -> a -> Bool
== Sign
s2 -> Sign -> Word64 -> TimeDelta
mkTimeDelta Sign
s1 (Word64
m1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
m2)
      | Bool
otherwise ->
          if Word64
m1 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
m2
            then Sign -> Word64 -> TimeDelta
mkTimeDelta Sign
s1 (Word64
m1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
m2)
            else Sign -> Word64 -> TimeDelta
mkTimeDelta Sign
s2 (Word64
m2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
m1)

instance Monoid TimeDelta where
  mempty :: TimeDelta
mempty = Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignPos Word64
0

instance Num TimeDelta where
  + :: TimeDelta -> TimeDelta -> TimeDelta
(+) = TimeDelta -> TimeDelta -> TimeDelta
forall a. Semigroup a => a -> a -> a
(<>)
  * :: TimeDelta -> TimeDelta -> TimeDelta
(*) = String -> TimeDelta -> TimeDelta -> TimeDelta
forall a. HasCallStack => String -> a
error String
"TimeDelta multiplication has no meaning"
  abs :: TimeDelta -> TimeDelta
abs (TimeDelta Sign
_ Word64
m) = Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignPos Word64
m
  signum :: TimeDelta -> TimeDelta
signum (TimeDelta Sign
s Word64
m) =
    if Word64
m Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
      then TimeDelta
0
      else case Sign
s of
        Sign
SignPos -> TimeDelta
1
        Sign
SignNeg -> -TimeDelta
1
  fromInteger :: Integer -> TimeDelta
fromInteger Integer
i =
    if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0
      then Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignPos (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
i)
      else Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignNeg (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer
forall a. Num a => a -> a
negate Integer
i))
  negate :: TimeDelta -> TimeDelta
negate td :: TimeDelta
td@(TimeDelta Sign
s Word64
m) =
    if Word64
m Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 Bool -> Bool -> Bool
&& Sign
s Sign -> Sign -> Bool
forall a. Eq a => a -> a -> Bool
== Sign
SignPos
      then TimeDelta
td
      else case Sign
s of
        Sign
SignPos -> Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignNeg Word64
m
        Sign
SignNeg -> Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignPos Word64
m

-- private
mkTimeDelta :: Sign -> Word64 -> TimeDelta
mkTimeDelta :: Sign -> Word64 -> TimeDelta
mkTimeDelta Sign
s Word64
m =
  if Word64
m Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
    then Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignPos Word64
m
    else Sign -> Word64 -> TimeDelta
TimeDelta Sign
s Word64
m

-- | Return a 'TimeDelta' corresponding the the given number of fractional seconds.
-- (For example, 1.5 represents one and a half seconds.)
timeDeltaFromFracSecs :: (Real a) => a -> TimeDelta
timeDeltaFromFracSecs :: forall a. Real a => a -> TimeDelta
timeDeltaFromFracSecs a
d =
  if a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0
    then Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignPos (Rational -> Word64
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational
1000000000 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* a -> Rational
forall a. Real a => a -> Rational
toRational a
d))
    else Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignNeg (Rational -> Word64
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational
1000000000 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* a -> Rational
forall a. Real a => a -> Rational
toRational (a -> a
forall a. Num a => a -> a
negate a
d)))

-- | Return a 'TimeDelta' corresponding the the given number of nanoseconds.
-- (For example, 1000000000 represends one second.)
timeDeltaFromNanos :: (Integral a) => a -> TimeDelta
timeDeltaFromNanos :: forall a. Integral a => a -> TimeDelta
timeDeltaFromNanos = a -> TimeDelta
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- private
timeDeltaFromDiff :: Word64 -> Word64 -> TimeDelta
timeDeltaFromDiff :: Word64 -> Word64 -> TimeDelta
timeDeltaFromDiff Word64
end Word64
start =
  if Word64
end Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
start
    then Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignPos (Word64
end Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
start)
    else Sign -> Word64 -> TimeDelta
TimeDelta Sign
SignNeg (Word64
start Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
end)

-- private
timeDeltaAdd :: Word64 -> TimeDelta -> Word64
timeDeltaAdd :: Word64 -> TimeDelta -> Word64
timeDeltaAdd Word64
t (TimeDelta Sign
s Word64
m) =
  case Sign
s of
    Sign
SignPos -> Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
m
    Sign
SignNeg -> Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
m

timeDeltaToFracSecs :: (Fractional a) => TimeDelta -> a
timeDeltaToFracSecs :: forall a. Fractional a => TimeDelta -> a
timeDeltaToFracSecs (TimeDelta Sign
s Word64
m) =
  let a :: a
a = Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
m a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
1000000000
  in  case Sign
s of
        Sign
SignPos -> a
a
        Sign
SignNeg -> a -> a
forall a. Num a => a -> a
negate a
a

timeDeltaToNanos :: TimeDelta -> (Sign, Word64)
timeDeltaToNanos :: TimeDelta -> (Sign, Word64)
timeDeltaToNanos (TimeDelta Sign
s Word64
m) = (Sign
s, Word64
m)

threadDelayDelta :: TimeDelta -> IO ()
threadDelayDelta :: TimeDelta -> IO ()
threadDelayDelta (TimeDelta Sign
s Word64
m) =
  case Sign
s of
    Sign
SignPos | Word64
m Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 -> Int -> IO ()
threadDelay (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
div Word64
m Word64
1000))
    Sign
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

class (Ord t) => TimeLike t where
  -- | `diffTime end start` computes `end - start`
  diffTime :: t -> t -> TimeDelta

  -- | `addTime start (diffTime end start) == end`
  addTime :: t -> TimeDelta -> t

  currentTime :: IO t

awaitDelta :: (TimeLike t) => t -> TimeDelta -> IO t
awaitDelta :: forall t. TimeLike t => t -> TimeDelta -> IO t
awaitDelta t
m TimeDelta
t = do
  let target :: t
target = t -> TimeDelta -> t
forall t. TimeLike t => t -> TimeDelta -> t
addTime t
m TimeDelta
t
  t
cur <- IO t
forall t. TimeLike t => IO t
currentTime
  let td :: TimeDelta
td = t -> t -> TimeDelta
forall t. TimeLike t => t -> t -> TimeDelta
diffTime t
target t
cur
  t
target t -> IO () -> IO t
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TimeDelta -> IO ()
threadDelayDelta TimeDelta
td

newtype PosixTime = PosixTime {PosixTime -> Word64
unPosixTime :: Word64}
  deriving stock (PosixTime -> PosixTime -> Bool
(PosixTime -> PosixTime -> Bool)
-> (PosixTime -> PosixTime -> Bool) -> Eq PosixTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PosixTime -> PosixTime -> Bool
== :: PosixTime -> PosixTime -> Bool
$c/= :: PosixTime -> PosixTime -> Bool
/= :: PosixTime -> PosixTime -> Bool
Eq, Int -> PosixTime -> ShowS
[PosixTime] -> ShowS
PosixTime -> String
(Int -> PosixTime -> ShowS)
-> (PosixTime -> String)
-> ([PosixTime] -> ShowS)
-> Show PosixTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PosixTime -> ShowS
showsPrec :: Int -> PosixTime -> ShowS
$cshow :: PosixTime -> String
show :: PosixTime -> String
$cshowList :: [PosixTime] -> ShowS
showList :: [PosixTime] -> ShowS
Show, Eq PosixTime
Eq PosixTime =>
(PosixTime -> PosixTime -> Ordering)
-> (PosixTime -> PosixTime -> Bool)
-> (PosixTime -> PosixTime -> Bool)
-> (PosixTime -> PosixTime -> Bool)
-> (PosixTime -> PosixTime -> Bool)
-> (PosixTime -> PosixTime -> PosixTime)
-> (PosixTime -> PosixTime -> PosixTime)
-> Ord PosixTime
PosixTime -> PosixTime -> Bool
PosixTime -> PosixTime -> Ordering
PosixTime -> PosixTime -> PosixTime
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
$ccompare :: PosixTime -> PosixTime -> Ordering
compare :: PosixTime -> PosixTime -> Ordering
$c< :: PosixTime -> PosixTime -> Bool
< :: PosixTime -> PosixTime -> Bool
$c<= :: PosixTime -> PosixTime -> Bool
<= :: PosixTime -> PosixTime -> Bool
$c> :: PosixTime -> PosixTime -> Bool
> :: PosixTime -> PosixTime -> Bool
$c>= :: PosixTime -> PosixTime -> Bool
>= :: PosixTime -> PosixTime -> Bool
$cmax :: PosixTime -> PosixTime -> PosixTime
max :: PosixTime -> PosixTime -> PosixTime
$cmin :: PosixTime -> PosixTime -> PosixTime
min :: PosixTime -> PosixTime -> PosixTime
Ord, PosixTime
PosixTime -> PosixTime -> Bounded PosixTime
forall a. a -> a -> Bounded a
$cminBound :: PosixTime
minBound :: PosixTime
$cmaxBound :: PosixTime
maxBound :: PosixTime
Bounded)

-- private
e9W :: Word64
e9W :: Word64
e9W = Word64
1000000000

-- private
picoToNanoWord :: Pico -> Word64
picoToNanoWord :: Pico -> Word64
picoToNanoWord (MkFixed Integer
i) = Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div Integer
i Integer
1000)

instance TimeLike PosixTime where
  diffTime :: PosixTime -> PosixTime -> TimeDelta
diffTime (PosixTime Word64
t2) (PosixTime Word64
t1) = Word64 -> Word64 -> TimeDelta
timeDeltaFromDiff Word64
t2 Word64
t1
  addTime :: PosixTime -> TimeDelta -> PosixTime
addTime (PosixTime Word64
t) TimeDelta
td = Word64 -> PosixTime
PosixTime (Word64 -> TimeDelta -> Word64
timeDeltaAdd Word64
t TimeDelta
td)
  currentTime :: IO PosixTime
currentTime = (NominalDiffTime -> PosixTime)
-> IO NominalDiffTime -> IO PosixTime
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64 -> PosixTime
PosixTime (Word64 -> PosixTime)
-> (NominalDiffTime -> Word64) -> NominalDiffTime -> PosixTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> Word64
picoToNanoWord (Pico -> Word64)
-> (NominalDiffTime -> Pico) -> NominalDiffTime -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Pico
nominalDiffTimeToSeconds) IO NominalDiffTime
getPOSIXTime

-- | Monotonic time in nanoseconds since some unspecified epoch (see 'getMonotonicTimeNs')
newtype MonoTime = MonoTime {MonoTime -> Word64
unMonoTime :: Word64}
  deriving stock (MonoTime -> MonoTime -> Bool
(MonoTime -> MonoTime -> Bool)
-> (MonoTime -> MonoTime -> Bool) -> Eq MonoTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MonoTime -> MonoTime -> Bool
== :: MonoTime -> MonoTime -> Bool
$c/= :: MonoTime -> MonoTime -> Bool
/= :: MonoTime -> MonoTime -> Bool
Eq, Int -> MonoTime -> ShowS
[MonoTime] -> ShowS
MonoTime -> String
(Int -> MonoTime -> ShowS)
-> (MonoTime -> String) -> ([MonoTime] -> ShowS) -> Show MonoTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MonoTime -> ShowS
showsPrec :: Int -> MonoTime -> ShowS
$cshow :: MonoTime -> String
show :: MonoTime -> String
$cshowList :: [MonoTime] -> ShowS
showList :: [MonoTime] -> ShowS
Show, Eq MonoTime
Eq MonoTime =>
(MonoTime -> MonoTime -> Ordering)
-> (MonoTime -> MonoTime -> Bool)
-> (MonoTime -> MonoTime -> Bool)
-> (MonoTime -> MonoTime -> Bool)
-> (MonoTime -> MonoTime -> Bool)
-> (MonoTime -> MonoTime -> MonoTime)
-> (MonoTime -> MonoTime -> MonoTime)
-> Ord MonoTime
MonoTime -> MonoTime -> Bool
MonoTime -> MonoTime -> Ordering
MonoTime -> MonoTime -> MonoTime
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
$ccompare :: MonoTime -> MonoTime -> Ordering
compare :: MonoTime -> MonoTime -> Ordering
$c< :: MonoTime -> MonoTime -> Bool
< :: MonoTime -> MonoTime -> Bool
$c<= :: MonoTime -> MonoTime -> Bool
<= :: MonoTime -> MonoTime -> Bool
$c> :: MonoTime -> MonoTime -> Bool
> :: MonoTime -> MonoTime -> Bool
$c>= :: MonoTime -> MonoTime -> Bool
>= :: MonoTime -> MonoTime -> Bool
$cmax :: MonoTime -> MonoTime -> MonoTime
max :: MonoTime -> MonoTime -> MonoTime
$cmin :: MonoTime -> MonoTime -> MonoTime
min :: MonoTime -> MonoTime -> MonoTime
Ord, MonoTime
MonoTime -> MonoTime -> Bounded MonoTime
forall a. a -> a -> Bounded a
$cminBound :: MonoTime
minBound :: MonoTime
$cmaxBound :: MonoTime
maxBound :: MonoTime
Bounded)

monoTimeFromFracSecs :: (Real a, Show a) => a -> MonoTime
monoTimeFromFracSecs :: forall a. (Real a, Show a) => a -> MonoTime
monoTimeFromFracSecs a
d = Word64 -> MonoTime
MonoTime (Rational -> Word64
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational
1000000000 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* a -> Rational
forall a. Real a => a -> Rational
toRational (a -> a
forall a. (HasCallStack, Ord a, Num a, Show a) => a -> a
assertingNonNegative a
d)))

monoTimeFromNanos :: (Integral a, Show a) => a -> MonoTime
monoTimeFromNanos :: forall a. (Integral a, Show a) => a -> MonoTime
monoTimeFromNanos = Word64 -> MonoTime
MonoTime (Word64 -> MonoTime) -> (a -> Word64) -> a -> MonoTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Word64) -> (a -> a) -> a -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. (HasCallStack, Ord a, Num a, Show a) => a -> a
assertingNonNegative

monoTimeToFracSecs :: (Fractional a) => MonoTime -> a
monoTimeToFracSecs :: forall a. Fractional a => MonoTime -> a
monoTimeToFracSecs (MonoTime Word64
n) = Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
1000000000

monoTimeToNanos :: MonoTime -> Word64
monoTimeToNanos :: MonoTime -> Word64
monoTimeToNanos = MonoTime -> Word64
unMonoTime

instance TimeLike MonoTime where
  diffTime :: MonoTime -> MonoTime -> TimeDelta
diffTime (MonoTime Word64
t2) (MonoTime Word64
t1) = Word64 -> Word64 -> TimeDelta
timeDeltaFromDiff Word64
t2 Word64
t1
  addTime :: MonoTime -> TimeDelta -> MonoTime
addTime (MonoTime Word64
t) TimeDelta
td = Word64 -> MonoTime
MonoTime (Word64 -> TimeDelta -> Word64
timeDeltaAdd Word64
t TimeDelta
td)
  currentTime :: IO MonoTime
currentTime = (Word64 -> MonoTime) -> IO Word64 -> IO MonoTime
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> MonoTime
MonoTime IO Word64
getMonotonicTimeNSec

newtype NtpTime = NtpTime {NtpTime -> Word64
unNtpTime :: Word64}
  deriving stock (NtpTime -> NtpTime -> Bool
(NtpTime -> NtpTime -> Bool)
-> (NtpTime -> NtpTime -> Bool) -> Eq NtpTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NtpTime -> NtpTime -> Bool
== :: NtpTime -> NtpTime -> Bool
$c/= :: NtpTime -> NtpTime -> Bool
/= :: NtpTime -> NtpTime -> Bool
Eq, Int -> NtpTime -> ShowS
[NtpTime] -> ShowS
NtpTime -> String
(Int -> NtpTime -> ShowS)
-> (NtpTime -> String) -> ([NtpTime] -> ShowS) -> Show NtpTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtpTime -> ShowS
showsPrec :: Int -> NtpTime -> ShowS
$cshow :: NtpTime -> String
show :: NtpTime -> String
$cshowList :: [NtpTime] -> ShowS
showList :: [NtpTime] -> ShowS
Show, Eq NtpTime
Eq NtpTime =>
(NtpTime -> NtpTime -> Ordering)
-> (NtpTime -> NtpTime -> Bool)
-> (NtpTime -> NtpTime -> Bool)
-> (NtpTime -> NtpTime -> Bool)
-> (NtpTime -> NtpTime -> Bool)
-> (NtpTime -> NtpTime -> NtpTime)
-> (NtpTime -> NtpTime -> NtpTime)
-> Ord NtpTime
NtpTime -> NtpTime -> Bool
NtpTime -> NtpTime -> Ordering
NtpTime -> NtpTime -> NtpTime
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
$ccompare :: NtpTime -> NtpTime -> Ordering
compare :: NtpTime -> NtpTime -> Ordering
$c< :: NtpTime -> NtpTime -> Bool
< :: NtpTime -> NtpTime -> Bool
$c<= :: NtpTime -> NtpTime -> Bool
<= :: NtpTime -> NtpTime -> Bool
$c> :: NtpTime -> NtpTime -> Bool
> :: NtpTime -> NtpTime -> Bool
$c>= :: NtpTime -> NtpTime -> Bool
>= :: NtpTime -> NtpTime -> Bool
$cmax :: NtpTime -> NtpTime -> NtpTime
max :: NtpTime -> NtpTime -> NtpTime
$cmin :: NtpTime -> NtpTime -> NtpTime
min :: NtpTime -> NtpTime -> NtpTime
Ord, NtpTime
NtpTime -> NtpTime -> Bounded NtpTime
forall a. a -> a -> Bounded a
$cminBound :: NtpTime
minBound :: NtpTime
$cmaxBound :: NtpTime
maxBound :: NtpTime
Bounded)

-- private
nanoWordToSplit :: Word64 -> (Word32, Word32)
nanoWordToSplit :: Word64 -> (Word32, Word32)
nanoWordToSplit Word64
j =
  let whole :: Word64
whole = Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
div Word64
j Word64
e9W
      part :: Word64
part = Word64
j Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
e9W Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
whole
  in  (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
whole, Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
part)

-- private
nanoWordFromSplit :: Word32 -> Word32 -> Word64
nanoWordFromSplit :: Word32 -> Word32 -> Word64
nanoWordFromSplit Word32
whole Word32
part = Word64
e9W Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
whole Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
part

-- private
ntpFromSplit :: Word32 -> Word32 -> NtpTime
ntpFromSplit :: Word32 -> Word32 -> NtpTime
ntpFromSplit Word32
whole Word32
part = Word64 -> NtpTime
NtpTime (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
whole) Int
32 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
part)

-- private
ntpToSplit :: NtpTime -> (Word32, Word32)
ntpToSplit :: NtpTime -> (Word32, Word32)
ntpToSplit (NtpTime Word64
k) = (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR Word64
k Int
32), Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
k)

-- private
-- Difference in nano seconds between 1/1/1900 and 1/1/1970
-- 1900 is the NTP epoch, 1970 is the unix epoch
ntpEpochDiffSeconds :: Word32
ntpEpochDiffSeconds :: Word32
ntpEpochDiffSeconds = Word32
2208988800

-- | Convert 'NtpTime' to 'PosixTime'
posixToNtp :: PosixTime -> NtpTime
posixToNtp :: PosixTime -> NtpTime
posixToNtp (PosixTime Word64
j) =
  let (Word32
whole, Word32
part) = Word64 -> (Word32, Word32)
nanoWordToSplit Word64
j
      whole' :: Word32
whole' = Word32
whole Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
ntpEpochDiffSeconds
  in  Word32 -> Word32 -> NtpTime
ntpFromSplit Word32
whole' Word32
part

-- | Convert 'NtpTime' to 'PosixTime'
ntpToPosix :: NtpTime -> PosixTime
ntpToPosix :: NtpTime -> PosixTime
ntpToPosix NtpTime
k =
  let (Word32
whole, Word32
part) = NtpTime -> (Word32, Word32)
ntpToSplit NtpTime
k
      whole' :: Word32
whole' = Word32
whole Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
ntpEpochDiffSeconds
  in  Word64 -> PosixTime
PosixTime (Word32 -> Word32 -> Word64
nanoWordFromSplit Word32
whole' Word32
part)

-- (Probably best to do time arithmetic directly on PosixTime)
instance TimeLike NtpTime where
  diffTime :: NtpTime -> NtpTime -> TimeDelta
diffTime NtpTime
n2 NtpTime
n1 = PosixTime -> PosixTime -> TimeDelta
forall t. TimeLike t => t -> t -> TimeDelta
diffTime (NtpTime -> PosixTime
ntpToPosix NtpTime
n2) (NtpTime -> PosixTime
ntpToPosix NtpTime
n1)
  addTime :: NtpTime -> TimeDelta -> NtpTime
addTime NtpTime
n TimeDelta
d = PosixTime -> NtpTime
posixToNtp (PosixTime -> TimeDelta -> PosixTime
forall t. TimeLike t => t -> TimeDelta -> t
addTime (NtpTime -> PosixTime
ntpToPosix NtpTime
n) TimeDelta
d)
  currentTime :: IO NtpTime
currentTime = (PosixTime -> NtpTime) -> IO PosixTime -> IO NtpTime
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PosixTime -> NtpTime
posixToNtp IO PosixTime
forall t. TimeLike t => IO t
currentTime

-- private
assertingNonNegative :: (HasCallStack, Ord a, Num a, Show a) => a -> a
assertingNonNegative :: forall a. (HasCallStack, Ord a, Num a, Show a) => a -> a
assertingNonNegative a
a =
  if a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0
    then String -> a
forall a. HasCallStack => String -> a
error (String
"Required non-negative value but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a)
    else a
a