Realtime.hs

module FRP.Rhine.Clock.Realtime where

-- base
import Control.Arrow (arr)
import Control.Concurrent (threadDelay)
import Control.Monad (guard)
import Control.Monad.IO.Class

-- time
import Data.Time (addUTCTime, diffUTCTime, getCurrentTime)

-- automaton
import Data.Automaton

-- rhine
import FRP.Rhine.Clock

-- time-domain
import Data.TimeDomain (Diff, UTCTime)

{- | A clock rescaled to the 'UTCTime' time domain.

There are different strategies how a clock may be rescaled, see below.
-}
type UTCClock m cl = RescaledClockS m cl UTCTime (Tag cl)

-- | Rescale an 'IO' clock to the UTC time domain, overwriting its timestamps.
overwriteUTC :: (MonadIO m) => cl -> UTCClock m cl
overwriteUTC cl =
  RescaledClockS
    { unscaledClockS = cl
    , rescaleS = const $ do
        now <- liftIO getCurrentTime
        return (arrM $ \(_timePassed, tag) -> (,tag) <$> liftIO getCurrentTime, now)
    }

{- | Rescale a clock to the UTC time domain.

The initial time stamp is measured as system time,
and the increments (durations between ticks) are taken from the original clock.
No attempt at waiting until the specified time is made,
the timestamps of the original clock are trusted unconditionally.
-}
addUTC :: (Real (Time cl), MonadIO m) => cl -> UTCClock m cl
addUTC cl =
  RescaledClockS
    { unscaledClockS = cl
    , rescaleS = const $ do
        now <- liftIO getCurrentTime
        return (arr $ \(timePassed, tag) -> (addUTCTime (realToFrac timePassed) now, tag), now)
    }

{- | Like 'UTCClock', but also output in the tag whether and by how much the target realtime was missed.

The original clock specifies with its time stamps when, relative to the initialisation time,
the UTC clock should tick.
A tag of @(tag, 'Nothing')@ means that the tick was in time.
@(tag, 'Just' dt)@ means that the tick was too late by @dt@.
-}
type WaitUTCClock m cl = RescaledClockS m cl UTCTime (Tag cl, Maybe (Diff (Time cl)))

{- | Measure the time after each tick, and wait for the remaining time until the next tick.

If the next tick should already have occurred @dt@ seconds ago,
the tag is set to @'Just' dt@, representing a failed real time attempt.

Note that this clock internally uses 'threadDelay' which can block
for quite a lot longer than the requested time, which can cause
'waitUTC' to miss one or more ticks when using a fast original clock.
When using 'threadDelay', the difference between the real wait time
and the requested wait time will be larger when using
the @-threaded@ ghc option (around 800 microseconds) than when not using
this option (around 100 microseconds). For fast clocks it is recommended
that @-threaded@ not be used in order to miss less ticks. The clock will adjust
the wait time, up to no wait time at all, to catch up when a tick is missed.
-}
waitUTC :: (Real (Time cl), MonadIO m, Fractional (Diff (Time cl))) => cl -> WaitUTCClock m cl
waitUTC unscaledClockS =
  RescaledClockS
    { unscaledClockS
    , rescaleS = \_ -> do
        initTime <- liftIO getCurrentTime
        let
          runningClock = arrM $ \(sinceInitTarget, tag) -> liftIO $ do
            beforeSleep <- getCurrentTime
            let
              diff :: Rational
              diff = toRational $ beforeSleep `diffUTCTime` initTime
              remaining = toRational sinceInitTarget - diff
            threadDelay $ round $ 1000000 * remaining
            now <- getCurrentTime
            return (now, (tag, guard (remaining > 0) >> return (fromRational remaining)))
        return (runningClock, initTime)
    }