{- |
Provides a clock that ticks at every multiple of a fixed number of milliseconds.
-}

{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module FRP.Rhine.Clock.Realtime.Millisecond where

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

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

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

{- |
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 (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 (FixedStep n) UTCTime Bool
cl) = RescaledClockS IO (FixedStep n) UTCTime Bool
-> RunningClockInit
     IO
     (Time (RescaledClockS IO (FixedStep n) UTCTime Bool))
     (Tag (RescaledClockS IO (FixedStep n) UTCTime Bool))
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock RescaledClockS 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 :: Millisecond n
waitClock = RescaledClockS IO (FixedStep n) UTCTime Bool -> Millisecond n
forall (n :: Nat).
RescaledClockS IO (FixedStep n) UTCTime Bool -> Millisecond n
Millisecond (RescaledClockS IO (FixedStep n) UTCTime Bool -> Millisecond n)
-> RescaledClockS IO (FixedStep n) UTCTime Bool -> Millisecond n
forall a b. (a -> b) -> a -> b
$ FixedStep n
-> RescalingSInit IO (FixedStep n) UTCTime Bool
-> RescaledClockS IO (FixedStep n) UTCTime Bool
forall (m :: Type -> Type) cl time tag.
cl -> RescalingSInit m cl time tag -> RescaledClockS m cl time tag
RescaledClockS FixedStep n
forall (n :: Nat). KnownNat n => FixedStep n
FixedStep (RescalingSInit IO (FixedStep n) UTCTime Bool
 -> RescaledClockS IO (FixedStep n) UTCTime Bool)
-> RescalingSInit IO (FixedStep n) UTCTime Bool
-> RescaledClockS IO (FixedStep n) UTCTime Bool
forall a b. (a -> b) -> a -> b
$ \Time (FixedStep n)
_ -> do
  UTCTime
initTime <- IO UTCTime
getCurrentTime
  let
    runningClock :: MSF IO (Integer, ()) (UTCTime, Bool)
runningClock = ((Integer, ()) -> IO (UTCTime, Bool))
-> MSF IO (Integer, ()) (UTCTime, Bool)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM (((Integer, ()) -> IO (UTCTime, Bool))
 -> MSF IO (Integer, ()) (UTCTime, Bool))
-> ((Integer, ()) -> IO (UTCTime, Bool))
-> MSF IO (Integer, ()) (UTCTime, Bool)
forall a b. (a -> b) -> a -> b
$ \(Integer
n, ()) -> do
      UTCTime
beforeSleep <- IO UTCTime
getCurrentTime
      let
        diff :: Double
        diff :: Double
diff      = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall a b. (a -> b) -> a -> b
$ UTCTime
beforeSleep UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
initTime
        remaining :: Int
remaining = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
diff Double -> Double -> Double
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
      (UTCTime, Bool) -> IO (UTCTime, Bool)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (UTCTime
now, Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
  (MSF IO (Integer, ()) (UTCTime, Bool), UTCTime)
-> IO (MSF IO (Integer, ()) (UTCTime, Bool), UTCTime)
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 :: ResamplingBuffer
  m (Millisecond k) (Millisecond (n * k)) a (Vector n a)
downsampleMillisecond = ResamplingBuffer m (Millisecond k) (Millisecond (n * k)) a [a]
forall (m :: Type -> Type) cl1 cl2 a.
Monad m =>
ResamplingBuffer m cl1 cl2 a [a]
collect ResamplingBuffer m (Millisecond k) (Millisecond (n * k)) a [a]
-> ClSF m (Millisecond (n * k)) [a] (Vector n a)
-> ResamplingBuffer
     m (Millisecond k) (Millisecond (n * k)) a (Vector n a)
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
>>-^ ([a] -> Vector n a)
-> ClSF m (Millisecond (n * k)) [a] (Vector n a)
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ([a] -> Maybe (Vector n a)
forall (n :: Nat) a. KnownNat n => [a] -> Maybe (Vector n a)
fromList ([a] -> Maybe (Vector n a))
-> (Maybe (Vector n a) -> Vector n a) -> [a] -> Vector n a
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Maybe (Vector n a) -> Vector n a
forall a. Maybe a -> a
assumeSize)
  where
    assumeSize :: Maybe a -> a
assumeSize = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (a -> Maybe a -> a) -> a -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords
      [ [Char]
"You are using an incorrectly implemented schedule"
      , [Char]
"for two Millisecond clocks."
      , [Char]
"Use a correct schedule like downsampleMillisecond."
      ]

-- | Two 'Millisecond' clocks can always be scheduled deterministically.
scheduleMillisecond :: Schedule IO (Millisecond n1) (Millisecond n2)
scheduleMillisecond :: Schedule IO (Millisecond n1) (Millisecond n2)
scheduleMillisecond = (Millisecond n1
 -> Millisecond n2
 -> RunningClockInit
      IO
      (Time (Millisecond n1))
      (Either (Tag (Millisecond n1)) (Tag (Millisecond n2))))
-> Schedule IO (Millisecond n1) (Millisecond n2)
forall (m :: Type -> Type) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
 -> cl2
 -> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule Millisecond n1
-> Millisecond n2
-> RunningClockInit
     IO
     (Time (Millisecond n1))
     (Either (Tag (Millisecond n1)) (Tag (Millisecond n2)))
forall (n1 :: Nat) (n2 :: Nat).
Millisecond n1
-> Millisecond n2 -> RunningClockInit IO UTCTime (Either Bool Bool)
initSchedule'
  where
    initSchedule' :: Millisecond n1
-> Millisecond n2
-> RunningClockInit
     IO
     (Time (RescaledClockS IO (FixedStep n1) UTCTime Bool))
     (Either
        (Tag (RescaledClockS IO (FixedStep n1) UTCTime Bool))
        (Tag (RescaledClockS IO (FixedStep n2) UTCTime Bool)))
initSchedule' (Millisecond RescaledClockS IO (FixedStep n1) UTCTime Bool
cl1) (Millisecond RescaledClockS IO (FixedStep n2) UTCTime Bool
cl2)
      = Schedule
  IO
  (RescaledClockS IO (FixedStep n1) UTCTime Bool)
  (RescaledClockS IO (FixedStep n2) UTCTime Bool)
-> RescaledClockS IO (FixedStep n1) UTCTime Bool
-> RescaledClockS IO (FixedStep n2) UTCTime Bool
-> RunningClockInit
     IO
     (Time (RescaledClockS IO (FixedStep n1) UTCTime Bool))
     (Either
        (Tag (RescaledClockS IO (FixedStep n1) UTCTime Bool))
        (Tag (RescaledClockS IO (FixedStep n2) UTCTime Bool)))
forall (m :: Type -> Type) cl1 cl2.
Schedule m cl1 cl2
-> cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule (Schedule IO (FixedStep n1) (FixedStep n2)
-> Schedule
     IO
     (RescaledClockS IO (FixedStep n1) UTCTime Bool)
     (RescaledClockS IO (FixedStep n2) UTCTime Bool)
forall (m :: Type -> Type) cl1 cl2 time tag1 tag2.
Monad m =>
Schedule m cl1 cl2
-> Schedule
     m (RescaledClockS m cl1 time tag1) (RescaledClockS m cl2 time tag2)
rescaledScheduleS Schedule IO (FixedStep n1) (FixedStep n2)
forall (m :: Type -> Type) (n1 :: Nat) (n2 :: Nat).
Monad m =>
Schedule m (FixedStep n1) (FixedStep n2)
scheduleFixedStep) RescaledClockS IO (FixedStep n1) UTCTime Bool
cl1 RescaledClockS IO (FixedStep n2) UTCTime Bool
cl2