-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The monotonic clock every deadline and imposed wait in the core is measured on. A wall-clock
adjustment must never read as a longer lease or a shorter pause.
-}
module Ecluse.Core.Clock (
    MonoTime (..),
    monotonicNow,
    monoAfter,
    monoSecondsBetween,
    waitUntilMonotonic,
    waitSeconds,
    secondsToMicros,
) where

import Data.Time (NominalDiffTime)
import GHC.Clock (getMonotonicTime)
import UnliftIO.Concurrent (threadDelay)

-- | A reading of the monotonic clock, in seconds from an arbitrary origin.
newtype MonoTime = MonoTime Double
    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, 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, 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)

-- | Read the monotonic clock.
monotonicNow :: IO MonoTime
monotonicNow :: IO MonoTime
monotonicNow = Double -> MonoTime
MonoTime (Double -> MonoTime) -> IO Double -> IO MonoTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Double
getMonotonicTime

-- | The instant this many seconds after the given one. A negative offset reads backwards.
monoAfter :: MonoTime -> Double -> MonoTime
monoAfter :: MonoTime -> Double -> MonoTime
monoAfter (MonoTime Double
at) Double
offset = Double -> MonoTime
MonoTime (Double
at Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset)

-- | The seconds from the first instant to the second, negative once the second has passed.
monoSecondsBetween :: MonoTime -> MonoTime -> Double
monoSecondsBetween :: MonoTime -> MonoTime -> Double
monoSecondsBetween (MonoTime Double
from') (MonoTime Double
to') = Double
to' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
from'

-- | Wait until the given instant. The clock is re-read, so a wait can only ever come up short.
waitUntilMonotonic :: MonoTime -> IO ()
waitUntilMonotonic :: MonoTime -> IO ()
waitUntilMonotonic MonoTime
target = do
    now <- IO MonoTime
monotonicNow
    let pause = MonoTime -> MonoTime -> Double
monoSecondsBetween MonoTime
now MonoTime
target
    when (pause > 0) (threadDelay (round (pause * 1_000_000)))

{- | Wait a duration, keeping its sub-second part. The microseconds saturate rather than wrap, so
an absurd duration waits a very long time instead of returning at once.
-}
waitSeconds :: NominalDiffTime -> IO ()
waitSeconds :: NominalDiffTime -> IO ()
waitSeconds NominalDiffTime
seconds = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
micros Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
ceilingMicros Integer
micros)))
  where
    micros :: Integer
micros = Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational NominalDiffTime
seconds Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1_000_000)
    ceilingMicros :: Integer
ceilingMicros = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int
forall a. Bounded a => a
maxBound :: Int)

{- | A delay in seconds as the microseconds a delay primitive takes. Every config decoder that
spells a pause bounds it below @maxBound `div` 1_000_000@, so the conversion cannot wrap.
-}
secondsToMicros :: NominalDiffTime -> Int
secondsToMicros :: NominalDiffTime -> Int
secondsToMicros NominalDiffTime
seconds = NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
seconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000