{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

{- |
Provides a clock that ticks at every multiple of a fixed number of milliseconds.
-}
module FRP.Rhine.Clock.Realtime.Millisecond where

-- base
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import Data.Time.Clock
import GHC.TypeLits

-- vector-sized
import Data.Vector.Sized (Vector, fromList)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.FixedStep
import FRP.Rhine.Clock.Proxy
import FRP.Rhine.Clock.Unschedule
import FRP.Rhine.ResamplingBuffer
import FRP.Rhine.ResamplingBuffer.Collect
import FRP.Rhine.ResamplingBuffer.Util

{- |
A clock ticking every 'n' milliseconds,
in real time.
Since 'n' is in the type signature,
it is ensured that when composing two signals on a 'Millisecond' clock,
they will be driven at the same rate.

The tag of this clock is 'Bool',
where 'True' represents successful realtime,
and 'False' a lag.
-}
newtype Millisecond (n :: Nat) = Millisecond (RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool)

-- TODO Consider changing the tag to Maybe Double

instance Clock IO (Millisecond n) where
  type Time (Millisecond n) = UTCTime
  type Tag (Millisecond n) = Bool
  initClock :: Millisecond n
-> RunningClockInit IO (Time (Millisecond n)) (Tag (Millisecond n))
initClock (Millisecond RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
cl) = forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
cl

instance GetClockProxy (Millisecond n)

{- | This implementation measures the time after each tick,
   and waits for the remaining time until the next tick.
   If the next tick should already have occurred,
   the tag is set to 'False', 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
   the clock to miss one or more ticks when using low values of 'n'.
   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 low values of @n@ 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.
-}
waitClock :: (KnownNat n) => Millisecond n
waitClock :: forall (n :: Nat). KnownNat n => Millisecond n
waitClock = forall (n :: Nat).
RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool
-> Millisecond n
Millisecond forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) cl time tag.
cl -> RescalingSInit m cl time tag -> RescaledClockS m cl time tag
RescaledClockS (forall cl. cl -> UnscheduleClock IO cl
unyieldClock forall (n :: Nat). KnownNat n => FixedStep n
FixedStep) forall a b. (a -> b) -> a -> b
$ \Time (UnscheduleClock IO (FixedStep n))
_ -> do
  UTCTime
initTime <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let
    runningClock :: MSF IO (Integer, ()) (UTCTime, Bool)
runningClock = forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM forall a b. (a -> b) -> a -> b
$ \(Integer
n, ()) -> forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      UTCTime
beforeSleep <- IO UTCTime
getCurrentTime
      let
        diff :: Double
        diff :: Double
diff = forall a b. (Real a, Fractional b) => a -> b
realToFrac forall a b. (a -> b) -> a -> b
$ UTCTime
beforeSleep UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
initTime
        remaining :: Int
remaining = forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ Integer
n forall a. Num a => a -> a -> a
* Integer
1000 forall a. Num a => a -> a -> a
- forall a b. (RealFrac a, Integral b) => a -> b
round (Double
diff forall a. Num a => a -> a -> a
* Double
1000000)
      Int -> IO ()
threadDelay Int
remaining
      UTCTime
now <- IO UTCTime
getCurrentTime -- TODO Test whether this is a performance penalty
      forall (m :: Type -> Type) a. Monad m => a -> m a
return (UTCTime
now, Int
remaining forall a. Ord a => a -> a -> Bool
> Int
0)
  forall (m :: Type -> Type) a. Monad m => a -> m a
return (MSF IO (Integer, ()) (UTCTime, Bool)
runningClock, UTCTime
initTime)

-- TODO It would be great if this could be directly implemented in terms of downsampleFixedStep
downsampleMillisecond ::
  (KnownNat n, Monad m) =>
  ResamplingBuffer m (Millisecond k) (Millisecond (n * k)) a (Vector n a)
downsampleMillisecond :: forall (n :: Nat) (m :: Type -> Type) (k :: Nat) a.
(KnownNat n, Monad m) =>
ResamplingBuffer
  m (Millisecond k) (Millisecond (n * k)) a (Vector n a)
downsampleMillisecond = forall (m :: Type -> Type) cl1 cl2 a.
Monad m =>
ResamplingBuffer m cl1 cl2 a [a]
collect forall (m :: Type -> Type) cl1 cl2 a b c.
Monad m =>
ResamplingBuffer m cl1 cl2 a b
-> ClSF m cl2 b c -> ResamplingBuffer m cl1 cl2 a c
>>-^ forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (forall (n :: Nat) a. KnownNat n => [a] -> Maybe (Vector n a)
fromList forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall {a}. Maybe a -> a
assumeSize)
  where
    assumeSize :: Maybe a -> a
assumeSize =
      forall a. a -> Maybe a -> a
fromMaybe forall a b. (a -> b) -> a -> b
$
        forall a. HasCallStack => [Char] -> a
error [Char]
"downsampleMillisecond: Internal error. Please report this as a bug: https://github.com/turion/rhine/issues"