{- |
'Clock's are the central new notion in Rhine.
There are clock types (instances of the 'Clock' type class)
and their values.

This module provides the 'Clock' type class, several utilities,
and certain general constructions of 'Clock's,
such as clocks lifted along monad morphisms or time rescalings.
-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Clock
  ( module FRP.Rhine.Clock
  , module X
  )
where

-- base
import qualified Control.Category as Category

-- transformers
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Trans.Class (lift, MonadTrans)

-- dunai
import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))

-- time-domain
import Data.TimeDomain as X

-- * The 'Clock' type class

{- |
A clock creates a stream of time stamps and additional information,
possibly together with side effects in a monad 'm'
that cause the environment to wait until the specified time is reached.
-}
type RunningClock m time tag = MSF m () (time, tag)

{- |
When initialising a clock, the initial time is measured
(typically by means of a side effect),
and a running clock is returned.
-}
type RunningClockInit m time tag = m (RunningClock m time tag, time)

{- |
Since we want to leverage Haskell's type system to annotate signal networks by their clocks,
each clock must be an own type, 'cl'.
Different values of the same clock type should tick at the same speed,
and only differ in implementation details.
Often, clocks are singletons.
-}
class TimeDomain (Time cl) => Clock m cl where
  -- | The time domain, i.e. type of the time stamps the clock creates.
  type Time cl
  -- | Additional information that the clock may output at each tick,
  --   e.g. if a realtime promise was met, if an event occurred,
  --   if one of its subclocks (if any) ticked.
  type Tag cl
  -- | The method that produces to a clock value a running clock,
  --   i.e. an effectful stream of tagged time stamps together with an initialisation time.
  initClock
    :: cl -- ^ The clock value, containing e.g. settings or device parameters
    -> RunningClockInit m (Time cl) (Tag cl) -- ^ The stream of time stamps, and the initial time

-- * Auxiliary definitions and utilities

-- | An annotated, rich time stamp.
data TimeInfo cl = TimeInfo
  { -- | Time passed since the last tick
    TimeInfo cl -> Diff (Time cl)
sinceLast :: Diff (Time cl)
    -- | Time passed since the initialisation of the clock
  , TimeInfo cl -> Diff (Time cl)
sinceInit :: Diff (Time cl)
    -- | The absolute time of the current tick
  , TimeInfo cl -> Time cl
absolute  :: Time cl
    -- | The tag annotation of the current tick
  , TimeInfo cl -> Tag cl
tag       :: Tag cl
  }

-- | A utility that changes the tag of a 'TimeInfo'.
retag
  :: (Time cl1 ~ Time cl2)
  => (Tag cl1 -> Tag cl2)
  -> TimeInfo cl1 -> TimeInfo cl2
retag :: (Tag cl1 -> Tag cl2) -> TimeInfo cl1 -> TimeInfo cl2
retag Tag cl1 -> Tag cl2
f TimeInfo {Diff (Time cl1)
Time cl1
Tag cl1
tag :: Tag cl1
absolute :: Time cl1
sinceInit :: Diff (Time cl1)
sinceLast :: Diff (Time cl1)
tag :: forall cl. TimeInfo cl -> Tag cl
absolute :: forall cl. TimeInfo cl -> Time cl
sinceInit :: forall cl. TimeInfo cl -> Diff (Time cl)
sinceLast :: forall cl. TimeInfo cl -> Diff (Time cl)
..} = TimeInfo :: forall cl.
Diff (Time cl)
-> Diff (Time cl) -> Time cl -> Tag cl -> TimeInfo cl
TimeInfo { tag :: Tag cl2
tag = Tag cl1 -> Tag cl2
f Tag cl1
tag, Diff (Time cl1)
Diff (Time cl2)
Time cl1
Time cl2
absolute :: Time cl1
sinceInit :: Diff (Time cl1)
sinceLast :: Diff (Time cl1)
absolute :: Time cl2
sinceInit :: Diff (Time cl2)
sinceLast :: Diff (Time cl2)
.. }

-- * Certain universal building blocks to produce new clocks from given ones

-- ** Rescalings of time domains

-- | A pure morphism of time domains is just a function.
type Rescaling cl time = Time cl -> time

-- | An effectful morphism of time domains is a Kleisli arrow.
--   It can use a side effect to rescale a point in one time domain
--   into another one.
type RescalingM m cl time = Time cl -> m time

-- | An effectful, stateful morphism of time domains is an 'MSF'
--   that uses side effects to rescale a point in one time domain
--   into another one.
type RescalingS m cl time tag = MSF m (Time cl, Tag cl) (time, tag)

-- | Like 'RescalingS', but allows for an initialisation
--   of the rescaling morphism, together with the initial time.
type RescalingSInit m cl time tag = Time cl -> m (RescalingS m cl time tag, time)

-- | Convert an effectful morphism of time domains into a stateful one with initialisation.
--   Think of its type as @RescalingM m cl time -> RescalingSInit m cl time tag@,
--   although this type is ambiguous.
rescaleMToSInit
  :: Monad m
  => (time1 -> m time2) -> time1 -> m (MSF m (time1, tag) (time2, tag), time2)
rescaleMToSInit :: (time1 -> m time2)
-> time1 -> m (MSF m (time1, tag) (time2, tag), time2)
rescaleMToSInit time1 -> m time2
rescaling time1
time1 = ((time1 -> m time2) -> MSF m time1 time2
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM time1 -> m time2
rescaling MSF m time1 time2
-> MSF m tag tag -> MSF m (time1, tag) (time2, tag)
forall (a :: Type -> Type -> Type) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** MSF m tag tag
forall k (cat :: k -> k -> Type) (a :: k). Category cat => cat a a
Category.id, ) (time2 -> (MSF m (time1, tag) (time2, tag), time2))
-> m time2 -> m (MSF m (time1, tag) (time2, tag), time2)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> time1 -> m time2
rescaling time1
time1

-- ** Applying rescalings to clocks

-- | Applying a morphism of time domains yields a new clock.
data RescaledClock cl time = RescaledClock
  { RescaledClock cl time -> cl
unscaledClock :: cl
  , RescaledClock cl time -> Rescaling cl time
rescale       :: Rescaling cl time
  }


instance (Monad m, TimeDomain time, Clock m cl)
      => Clock m (RescaledClock cl time) where
  type Time (RescaledClock cl time) = time
  type Tag  (RescaledClock cl time) = Tag cl
  initClock :: RescaledClock cl time
-> RunningClockInit
     m (Time (RescaledClock cl time)) (Tag (RescaledClock cl time))
initClock (RescaledClock cl
cl Rescaling cl time
f) = do
    (MSF m () (Time cl, Tag cl)
runningClock, Time cl
initTime) <- cl -> m (MSF m () (Time cl, Tag cl), Time cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
cl
    (MSF m () (time, Tag cl), time)
-> m (MSF m () (time, Tag cl), time)
forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( MSF m () (Time cl, Tag cl)
runningClock MSF m () (Time cl, Tag cl)
-> MSF m (Time cl, Tag cl) (time, Tag cl)
-> MSF m () (time, Tag cl)
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m (Time cl) time -> MSF m (Time cl, Tag cl) (time, Tag cl)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Rescaling cl time -> MSF m (Time cl) time
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr Rescaling cl time
f)
      , Rescaling cl time
f Time cl
initTime
      )

-- | Instead of a mere function as morphism of time domains,
--   we can transform one time domain into the other with an effectful morphism.
data RescaledClockM m cl time = RescaledClockM
  { RescaledClockM m cl time -> cl
unscaledClockM :: cl
  -- ^ The clock before the rescaling
  , RescaledClockM m cl time -> RescalingM m cl time
rescaleM       :: RescalingM m cl time
  -- ^ Computing the new time effectfully from the old time
  }

instance (Monad m, TimeDomain time, Clock m cl)
      => Clock m (RescaledClockM m cl time) where
  type Time (RescaledClockM m cl time) = time
  type Tag  (RescaledClockM m cl time) = Tag cl
  initClock :: RescaledClockM m cl time
-> RunningClockInit
     m
     (Time (RescaledClockM m cl time))
     (Tag (RescaledClockM m cl time))
initClock RescaledClockM {cl
RescalingM m cl time
rescaleM :: RescalingM m cl time
unscaledClockM :: cl
rescaleM :: forall (m :: Type -> Type) cl time.
RescaledClockM m cl time -> RescalingM m cl time
unscaledClockM :: forall (m :: Type -> Type) cl time. RescaledClockM m cl time -> cl
..} = do
    (MSF m () (Time cl, Tag cl)
runningClock, Time cl
initTime) <- cl -> m (MSF m () (Time cl, Tag cl), Time cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
unscaledClockM
    time
rescaledInitTime         <- RescalingM m cl time
rescaleM Time cl
initTime
    (MSF m () (time, Tag cl), time)
-> m (MSF m () (time, Tag cl), time)
forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( MSF m () (Time cl, Tag cl)
runningClock MSF m () (Time cl, Tag cl)
-> MSF m (Time cl, Tag cl) (time, Tag cl)
-> MSF m () (time, Tag cl)
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m (Time cl) time -> MSF m (Time cl, Tag cl) (time, Tag cl)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (RescalingM m cl time -> MSF m (Time cl) time
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> MSF m a b
arrM RescalingM m cl time
rescaleM)
      , time
rescaledInitTime
      )

-- | A 'RescaledClock' is trivially a 'RescaledClockM'.
rescaledClockToM :: Monad m => RescaledClock cl time -> RescaledClockM m cl time
rescaledClockToM :: RescaledClock cl time -> RescaledClockM m cl time
rescaledClockToM RescaledClock {cl
Rescaling cl time
rescale :: Rescaling cl time
unscaledClock :: cl
rescale :: forall cl time. RescaledClock cl time -> Rescaling cl time
unscaledClock :: forall cl time. RescaledClock cl time -> cl
..} = RescaledClockM :: forall (m :: Type -> Type) cl time.
cl -> RescalingM m cl time -> RescaledClockM m cl time
RescaledClockM
  { unscaledClockM :: cl
unscaledClockM = cl
unscaledClock
  , rescaleM :: RescalingM m cl time
rescaleM       = time -> m time
forall (m :: Type -> Type) a. Monad m => a -> m a
return (time -> m time) -> Rescaling cl time -> RescalingM m cl time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rescaling cl time
rescale
  }


-- | Instead of a mere function as morphism of time domains,
--   we can transform one time domain into the other with a monadic stream function.
data RescaledClockS m cl time tag = RescaledClockS
  { RescaledClockS m cl time tag -> cl
unscaledClockS :: cl
  -- ^ The clock before the rescaling
  , RescaledClockS m cl time tag -> RescalingSInit m cl time tag
rescaleS       :: RescalingSInit m cl time tag
  -- ^ The rescaling stream function, and rescaled initial time,
  --   depending on the initial time before rescaling
  }

instance (Monad m, TimeDomain time, Clock m cl)
      => Clock m (RescaledClockS m cl time tag) where
  type Time (RescaledClockS m cl time tag) = time
  type Tag  (RescaledClockS m cl time tag) = tag
  initClock :: RescaledClockS m cl time tag
-> RunningClockInit
     m
     (Time (RescaledClockS m cl time tag))
     (Tag (RescaledClockS m cl time tag))
initClock RescaledClockS {cl
RescalingSInit m cl time tag
rescaleS :: RescalingSInit m cl time tag
unscaledClockS :: cl
rescaleS :: forall (m :: Type -> Type) cl time tag.
RescaledClockS m cl time tag -> RescalingSInit m cl time tag
unscaledClockS :: forall (m :: Type -> Type) cl time tag.
RescaledClockS m cl time tag -> cl
..} = do
    (MSF m () (Time cl, Tag cl)
runningClock, Time cl
initTime) <- cl -> m (MSF m () (Time cl, Tag cl), Time cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
unscaledClockS
    (MSF m (Time cl, Tag cl) (time, tag)
rescaling, time
rescaledInitTime) <- RescalingSInit m cl time tag
rescaleS Time cl
initTime
    (MSF m () (time, tag), time) -> m (MSF m () (time, tag), time)
forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( MSF m () (Time cl, Tag cl)
runningClock MSF m () (Time cl, Tag cl)
-> MSF m (Time cl, Tag cl) (time, tag) -> MSF m () (time, tag)
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF m (Time cl, Tag cl) (time, tag)
rescaling
      , time
rescaledInitTime
      )

-- | A 'RescaledClockM' is trivially a 'RescaledClockS'.
rescaledClockMToS
  :: Monad m
  => RescaledClockM m cl time -> RescaledClockS m cl time (Tag cl)
rescaledClockMToS :: RescaledClockM m cl time -> RescaledClockS m cl time (Tag cl)
rescaledClockMToS RescaledClockM {cl
RescalingM m cl time
rescaleM :: RescalingM m cl time
unscaledClockM :: cl
rescaleM :: forall (m :: Type -> Type) cl time.
RescaledClockM m cl time -> RescalingM m cl time
unscaledClockM :: forall (m :: Type -> Type) cl time. RescaledClockM m cl time -> cl
..} = RescaledClockS :: forall (m :: Type -> Type) cl time tag.
cl -> RescalingSInit m cl time tag -> RescaledClockS m cl time tag
RescaledClockS
  { unscaledClockS :: cl
unscaledClockS = cl
unscaledClockM
  , rescaleS :: RescalingSInit m cl time (Tag cl)
rescaleS       = RescalingM m cl time -> RescalingSInit m cl time (Tag cl)
forall (m :: Type -> Type) time1 time2 tag.
Monad m =>
(time1 -> m time2)
-> time1 -> m (MSF m (time1, tag) (time2, tag), time2)
rescaleMToSInit RescalingM m cl time
rescaleM
  }

-- | A 'RescaledClock' is trivially a 'RescaledClockS'.
rescaledClockToS
  :: Monad m
  => RescaledClock cl time -> RescaledClockS m cl time (Tag cl)
rescaledClockToS :: RescaledClock cl time -> RescaledClockS m cl time (Tag cl)
rescaledClockToS = RescaledClockM m cl time -> RescaledClockS m cl time (Tag cl)
forall (m :: Type -> Type) cl time.
Monad m =>
RescaledClockM m cl time -> RescaledClockS m cl time (Tag cl)
rescaledClockMToS (RescaledClockM m cl time -> RescaledClockS m cl time (Tag cl))
-> (RescaledClock cl time -> RescaledClockM m cl time)
-> RescaledClock cl time
-> RescaledClockS m cl time (Tag cl)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RescaledClock cl time -> RescaledClockM m cl time
forall (m :: Type -> Type) cl time.
Monad m =>
RescaledClock cl time -> RescaledClockM m cl time
rescaledClockToM

-- | Applying a monad morphism yields a new clock.
data HoistClock m1 m2 cl = HoistClock
  { HoistClock m1 m2 cl -> cl
unhoistedClock :: cl
  , HoistClock m1 m2 cl -> forall a. m1 a -> m2 a
monadMorphism  :: forall a . m1 a -> m2 a
  }

instance (Monad m1, Monad m2, Clock m1 cl)
      => Clock m2 (HoistClock m1 m2 cl) where
  type Time (HoistClock m1 m2 cl) = Time cl
  type Tag  (HoistClock m1 m2 cl) = Tag  cl
  initClock :: HoistClock m1 m2 cl
-> RunningClockInit
     m2 (Time (HoistClock m1 m2 cl)) (Tag (HoistClock m1 m2 cl))
initClock HoistClock {cl
forall a. m1 a -> m2 a
monadMorphism :: forall a. m1 a -> m2 a
unhoistedClock :: cl
monadMorphism :: forall (m1 :: Type -> Type) (m2 :: Type -> Type) cl.
HoistClock m1 m2 cl -> forall a. m1 a -> m2 a
unhoistedClock :: forall (m1 :: Type -> Type) (m2 :: Type -> Type) cl.
HoistClock m1 m2 cl -> cl
..} = do
    (MSF m1 () (Time cl, Tag cl)
runningClock, Time cl
initialTime) <- m1 (MSF m1 () (Time cl, Tag cl), Time cl)
-> m2 (MSF m1 () (Time cl, Tag cl), Time cl)
forall a. m1 a -> m2 a
monadMorphism (m1 (MSF m1 () (Time cl, Tag cl), Time cl)
 -> m2 (MSF m1 () (Time cl, Tag cl), Time cl))
-> m1 (MSF m1 () (Time cl, Tag cl), Time cl)
-> m2 (MSF m1 () (Time cl, Tag cl), Time cl)
forall a b. (a -> b) -> a -> b
$ cl -> m1 (MSF m1 () (Time cl, Tag cl), Time cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
unhoistedClock
    let hoistMSF :: (forall a. m1 a -> m2 a) -> MSF m1 a b -> MSF m2 a b
hoistMSF = (forall a. m1 a -> m2 a) -> MSF m1 a b -> MSF m2 a b
forall (m2 :: Type -> Type) (m1 :: Type -> Type) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS
    -- TODO Look out for API changes in dunai here
    (MSF m2 () (Time cl, Tag cl), Time cl)
-> m2 (MSF m2 () (Time cl, Tag cl), Time cl)
forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( (forall a. m1 a -> m2 a)
-> MSF m1 () (Time cl, Tag cl) -> MSF m2 () (Time cl, Tag cl)
forall a b. (forall a. m1 a -> m2 a) -> MSF m1 a b -> MSF m2 a b
hoistMSF forall a. m1 a -> m2 a
monadMorphism MSF m1 () (Time cl, Tag cl)
runningClock
      , Time cl
initialTime
      )


-- | Lift a clock type into a monad transformer.
type LiftClock m t cl = HoistClock m (t m) cl

-- | Lift a clock value into a monad transformer.
liftClock :: (Monad m, MonadTrans t) => cl -> LiftClock m t cl
liftClock :: cl -> LiftClock m t cl
liftClock cl
unhoistedClock = HoistClock :: forall (m1 :: Type -> Type) (m2 :: Type -> Type) cl.
cl -> (forall a. m1 a -> m2 a) -> HoistClock m1 m2 cl
HoistClock
  { monadMorphism :: forall a. m a -> t m a
monadMorphism = forall a. m a -> t m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
  , cl
unhoistedClock :: cl
unhoistedClock :: cl
..
  }

-- | Lift a clock type into 'MonadIO'.
type IOClock m cl = HoistClock IO m cl

-- | Lift a clock value into 'MonadIO'.
ioClock :: MonadIO m => cl -> IOClock m cl
ioClock :: cl -> IOClock m cl
ioClock cl
unhoistedClock = HoistClock :: forall (m1 :: Type -> Type) (m2 :: Type -> Type) cl.
cl -> (forall a. m1 a -> m2 a) -> HoistClock m1 m2 cl
HoistClock
  { monadMorphism :: forall a. IO a -> m a
monadMorphism = forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO
  , cl
unhoistedClock :: cl
unhoistedClock :: cl
..
  }