{-# 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.Arrow (arr, first, second, (>>>))
import Data.Functor ((<&>))
import GHC.TypeLits

-- time
import Data.Time.Clock

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.FixedStep
import FRP.Rhine.Clock.Proxy
import FRP.Rhine.Clock.Realtime (WaitUTCClock, waitUTC)
import FRP.Rhine.Clock.Unschedule

{- | 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.

For example, @'Millisecond' 100@ ticks every 0.1 seconds, so 10 times per seconds.

The tag of this clock is 'Maybe Double',
where 'Nothing' represents successful realtime,
and @'Just' lag@ a lag (in seconds).
-}
newtype Millisecond (n :: Nat) = Millisecond (WaitUTCClock IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double))

instance Clock IO (Millisecond n) where
  type Time (Millisecond n) = UTCTime
  type Tag (Millisecond n) = Maybe Double
  initClock :: Millisecond n
-> RunningClockInit IO (Time (Millisecond n)) (Tag (Millisecond n))
initClock (Millisecond WaitUTCClock
  IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
cl) = RescaledClockS
  IO
  (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
  UTCTime
  ((), Maybe Double)
-> IO
     (RunningClock
        IO
        (Time
           (RescaledClockS
              IO
              (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
              UTCTime
              ((), Maybe Double)))
        (Tag
           (RescaledClockS
              IO
              (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
              UTCTime
              ((), Maybe Double))),
      Time
        (RescaledClockS
           IO
           (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
           UTCTime
           ((), Maybe Double)))
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock RescaledClockS
  IO
  (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
  UTCTime
  ((), Maybe Double)
WaitUTCClock
  IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
cl IO
  (RunningClock
     IO
     (Time
        (RescaledClockS
           IO
           (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
           UTCTime
           ((), Maybe Double)))
     (Tag
        (RescaledClockS
           IO
           (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
           UTCTime
           ((), Maybe Double))),
   Time
     (RescaledClockS
        IO
        (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
        UTCTime
        ((), Maybe Double)))
-> ((RunningClock
       IO
       (Time
          (RescaledClockS
             IO
             (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
             UTCTime
             ((), Maybe Double)))
       (Tag
          (RescaledClockS
             IO
             (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
             UTCTime
             ((), Maybe Double))),
     Time
       (RescaledClockS
          IO
          (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
          UTCTime
          ((), Maybe Double)))
    -> (RunningClock IO UTCTime (Maybe Double), UTCTime))
-> IO (RunningClock IO UTCTime (Maybe Double), UTCTime)
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> (RunningClock IO UTCTime ((), Maybe Double)
 -> RunningClock IO UTCTime (Maybe Double))
-> (RunningClock IO UTCTime ((), Maybe Double), UTCTime)
-> (RunningClock IO UTCTime (Maybe Double), UTCTime)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (RunningClock IO UTCTime ((), Maybe Double)
-> Automaton
     IO (UTCTime, ((), Maybe Double)) (UTCTime, Maybe Double)
-> RunningClock IO UTCTime (Maybe Double)
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((UTCTime, ((), Maybe Double)) -> (UTCTime, Maybe Double))
-> Automaton
     IO (UTCTime, ((), Maybe Double)) (UTCTime, Maybe Double)
forall b c. (b -> c) -> Automaton IO b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ((((), Maybe Double) -> Maybe Double)
-> (UTCTime, ((), Maybe Double)) -> (UTCTime, Maybe Double)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((), Maybe Double) -> Maybe Double
forall a b. (a, b) -> b
snd))

instance GetClockProxy (Millisecond n)

-- | Tries to achieve real time by using 'waitUTC', see its docs.
waitClock :: (KnownNat n) => Millisecond n
waitClock :: forall (n :: Nat). KnownNat n => Millisecond n
waitClock = WaitUTCClock
  IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
-> Millisecond n
forall (n :: Nat).
WaitUTCClock
  IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
-> Millisecond n
Millisecond (WaitUTCClock
   IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
 -> Millisecond n)
-> WaitUTCClock
     IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
-> Millisecond n
forall a b. (a -> b) -> a -> b
$ RescaledClock (UnscheduleClock IO (FixedStep n)) Double
-> WaitUTCClock
     IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
forall cl (m :: Type -> Type).
(Real (Time cl), MonadIO m, Fractional (Diff (Time cl))) =>
cl -> WaitUTCClock m cl
waitUTC (RescaledClock (UnscheduleClock IO (FixedStep n)) Double
 -> WaitUTCClock
      IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double))
-> RescaledClock (UnscheduleClock IO (FixedStep n)) Double
-> WaitUTCClock
     IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)
forall a b. (a -> b) -> a -> b
$ UnscheduleClock IO (FixedStep n)
-> Rescaling (UnscheduleClock IO (FixedStep n)) Double
-> RescaledClock (UnscheduleClock IO (FixedStep n)) Double
forall cl time. cl -> Rescaling cl time -> RescaledClock cl time
RescaledClock (FixedStep n -> UnscheduleClock IO (FixedStep n)
forall cl. cl -> UnscheduleClock IO cl
unyieldClock FixedStep n
forall (n :: Nat). KnownNat n => FixedStep n
FixedStep) ((Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000) (Double -> Double) -> (Integer -> Double) -> Integer -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
forall a. Num a => Integer -> a
fromInteger)