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 :: forall (m :: Type -> Type) cl. MonadIO m => cl -> UTCClock m cl
overwriteUTC cl
cl =
  RescaledClockS
    { unscaledClockS :: cl
unscaledClockS = cl
cl
    , rescaleS :: RescalingSInit m cl UTCTime (Tag cl)
rescaleS = m (RescalingS m cl UTCTime (Tag cl), UTCTime)
-> RescalingSInit m cl UTCTime (Tag cl)
forall a b. a -> b -> a
const (m (RescalingS m cl UTCTime (Tag cl), UTCTime)
 -> RescalingSInit m cl UTCTime (Tag cl))
-> m (RescalingS m cl UTCTime (Tag cl), UTCTime)
-> RescalingSInit m cl UTCTime (Tag cl)
forall a b. (a -> b) -> a -> b
$ do
        UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        (RescalingS m cl UTCTime (Tag cl), UTCTime)
-> m (RescalingS m cl UTCTime (Tag cl), UTCTime)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Time cl, Tag cl) -> m (UTCTime, Tag cl))
-> RescalingS m cl UTCTime (Tag cl)
forall (m :: Type -> Type) a b.
Functor m =>
(a -> m b) -> Automaton m a b
arrM (((Time cl, Tag cl) -> m (UTCTime, Tag cl))
 -> RescalingS m cl UTCTime (Tag cl))
-> ((Time cl, Tag cl) -> m (UTCTime, Tag cl))
-> RescalingS m cl UTCTime (Tag cl)
forall a b. (a -> b) -> a -> b
$ \(Time cl
_timePassed, Tag cl
tag) -> (,Tag cl
tag) (UTCTime -> (UTCTime, Tag cl)) -> m UTCTime -> m (UTCTime, Tag cl)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime, UTCTime
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 :: forall cl (m :: Type -> Type).
(Real (Time cl), MonadIO m) =>
cl -> UTCClock m cl
addUTC cl
cl =
  RescaledClockS
    { unscaledClockS :: cl
unscaledClockS = cl
cl
    , rescaleS :: RescalingSInit m cl UTCTime (Tag cl)
rescaleS = m (RescalingS m cl UTCTime (Tag cl), UTCTime)
-> RescalingSInit m cl UTCTime (Tag cl)
forall a b. a -> b -> a
const (m (RescalingS m cl UTCTime (Tag cl), UTCTime)
 -> RescalingSInit m cl UTCTime (Tag cl))
-> m (RescalingS m cl UTCTime (Tag cl), UTCTime)
-> RescalingSInit m cl UTCTime (Tag cl)
forall a b. (a -> b) -> a -> b
$ do
        UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        (RescalingS m cl UTCTime (Tag cl), UTCTime)
-> m (RescalingS m cl UTCTime (Tag cl), UTCTime)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (((Time cl, Tag cl) -> (UTCTime, Tag cl))
-> RescalingS m cl UTCTime (Tag cl)
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (((Time cl, Tag cl) -> (UTCTime, Tag cl))
 -> RescalingS m cl UTCTime (Tag cl))
-> ((Time cl, Tag cl) -> (UTCTime, Tag cl))
-> RescalingS m cl UTCTime (Tag cl)
forall a b. (a -> b) -> a -> b
$ \(Time cl
timePassed, Tag cl
tag) -> (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Time cl -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Time cl
timePassed) UTCTime
now, Tag cl
tag), UTCTime
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 :: forall cl (m :: Type -> Type).
(Real (Time cl), MonadIO m, Fractional (Diff (Time cl))) =>
cl -> WaitUTCClock m cl
waitUTC cl
unscaledClockS =
  RescaledClockS
    { cl
unscaledClockS :: cl
unscaledClockS :: cl
unscaledClockS
    , rescaleS :: RescalingSInit m cl UTCTime (Tag cl, Maybe (Diff (Time cl)))
rescaleS = \Time cl
_ -> do
        UTCTime
initTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        let
          runningClock :: RescalingS m cl UTCTime (Tag cl, Maybe (Diff (Time cl)))
runningClock = ((Time cl, Tag cl)
 -> m (UTCTime, (Tag cl, Maybe (Diff (Time cl)))))
-> RescalingS m cl UTCTime (Tag cl, Maybe (Diff (Time cl)))
forall (m :: Type -> Type) a b.
Functor m =>
(a -> m b) -> Automaton m a b
arrM (((Time cl, Tag cl)
  -> m (UTCTime, (Tag cl, Maybe (Diff (Time cl)))))
 -> RescalingS m cl UTCTime (Tag cl, Maybe (Diff (Time cl))))
-> ((Time cl, Tag cl)
    -> m (UTCTime, (Tag cl, Maybe (Diff (Time cl)))))
-> RescalingS m cl UTCTime (Tag cl, Maybe (Diff (Time cl)))
forall a b. (a -> b) -> a -> b
$ \(Time cl
sinceInitTarget, Tag cl
tag) -> IO (UTCTime, (Tag cl, Maybe (Diff (Time cl))))
-> m (UTCTime, (Tag cl, Maybe (Diff (Time cl))))
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, (Tag cl, Maybe (Diff (Time cl))))
 -> m (UTCTime, (Tag cl, Maybe (Diff (Time cl)))))
-> IO (UTCTime, (Tag cl, Maybe (Diff (Time cl))))
-> m (UTCTime, (Tag cl, Maybe (Diff (Time cl))))
forall a b. (a -> b) -> a -> b
$ do
            UTCTime
beforeSleep <- IO UTCTime
getCurrentTime
            let
              diff :: Rational
              diff :: Rational
diff = NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational (NominalDiffTime -> Rational) -> NominalDiffTime -> Rational
forall a b. (a -> b) -> a -> b
$ UTCTime
beforeSleep UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
initTime
              remaining :: Rational
remaining = Time cl -> Rational
forall a. Real a => a -> Rational
toRational Time cl
sinceInitTarget Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
diff
            Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Rational -> Int
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ Rational
1000000 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
remaining
            UTCTime
now <- IO UTCTime
getCurrentTime
            (UTCTime, (Tag cl, Maybe (Diff (Time cl))))
-> IO (UTCTime, (Tag cl, Maybe (Diff (Time cl))))
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (UTCTime
now, (Tag cl
tag, Bool -> Maybe ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Rational
remaining Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0) Maybe () -> Maybe (Diff (Time cl)) -> Maybe (Diff (Time cl))
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Diff (Time cl) -> Maybe (Diff (Time cl))
forall a. a -> Maybe a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Rational -> Diff (Time cl)
forall a. Fractional a => Rational -> a
fromRational Rational
remaining)))
        (RescalingS m cl UTCTime (Tag cl, Maybe (Diff (Time cl))), UTCTime)
-> m (RescalingS m cl UTCTime (Tag cl, Maybe (Diff (Time cl))),
      UTCTime)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (RescalingS m cl UTCTime (Tag cl, Maybe (Diff (Time cl)))
runningClock, UTCTime
initTime)
    }