{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

{- |
The 'MonadSchedule' class from the @monad-schedule@ package is the compatibility mechanism between two different clocks.
It implements a concurrency abstraction that allows the clocks to run at the same time, independently.
Several such clocks running together form composite clocks, such as 'ParallelClock' and 'SequentialClock'.
This module defines these composite clocks,
and utilities to work with them.
-}
module FRP.Rhine.Schedule where

-- base
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as N

-- dunai
import Data.MonadicStreamFunction
import Data.MonadicStreamFunction.Async (concatS)
import Data.MonadicStreamFunction.InternalCore

-- monad-schedule
import Control.Monad.Schedule.Class

-- rhine
import FRP.Rhine.Clock

-- * Scheduling

scheduleList :: (Monad m, MonadSchedule m) => NonEmpty (MSF m a b) -> MSF m a (NonEmpty b)
scheduleList :: forall (m :: Type -> Type) a b.
(Monad m, MonadSchedule m) =>
NonEmpty (MSF m a b) -> MSF m a (NonEmpty b)
scheduleList NonEmpty (MSF m a b)
msfs = forall {m :: Type -> Type} {b} {a}.
(Monad m, MonadSchedule m) =>
NonEmpty (MSF m b a) -> [m (a, MSF m b a)] -> MSF m b (NonEmpty a)
scheduleList' NonEmpty (MSF m a b)
msfs []
  where
    scheduleList' :: NonEmpty (MSF m b a) -> [m (a, MSF m b a)] -> MSF m b (NonEmpty a)
scheduleList' NonEmpty (MSF m b a)
msfs [m (a, MSF m b a)]
running = forall (m :: Type -> Type) a b.
(a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \b
a -> do
      let bsAndConts :: NonEmpty (m (a, MSF m b a))
bsAndConts = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: Type -> Type) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF b
a forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (MSF m b a)
msfs
      (NonEmpty (a, MSF m b a)
done, [m (a, MSF m b a)]
running) <- forall (m :: Type -> Type) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule (forall a. NonEmpty a -> a
N.head NonEmpty (m (a, MSF m b a))
bsAndConts forall a. a -> [a] -> NonEmpty a
:| forall a. NonEmpty a -> [a]
N.tail NonEmpty (m (a, MSF m b a))
bsAndConts forall a. [a] -> [a] -> [a]
++ [m (a, MSF m b a)]
running)
      let (NonEmpty a
bs, NonEmpty (MSF m b a)
dones) = forall (f :: Type -> Type) a b. Functor f => f (a, b) -> (f a, f b)
N.unzip NonEmpty (a, MSF m b a)
done
      forall (m :: Type -> Type) a. Monad m => a -> m a
return (NonEmpty a
bs, NonEmpty (MSF m b a) -> [m (a, MSF m b a)] -> MSF m b (NonEmpty a)
scheduleList' NonEmpty (MSF m b a)
dones [m (a, MSF m b a)]
running)

{- | Two clocks in the 'ScheduleT' monad transformer
  can always be canonically scheduled.
  Indeed, this is the purpose for which 'ScheduleT' was defined.
-}
runningSchedule ::
  ( Monad m
  , MonadSchedule m
  , Clock m cl1
  , Clock m cl2
  , Time cl1 ~ Time cl2
  ) =>
  cl1 ->
  cl2 ->
  RunningClock m (Time cl1) (Tag cl1) ->
  RunningClock m (Time cl2) (Tag cl2) ->
  RunningClock m (Time cl1) (Either (Tag cl1) (Tag cl2))
runningSchedule :: forall (m :: Type -> Type) cl1 cl2.
(Monad m, MonadSchedule m, Clock m cl1, Clock m cl2,
 Time cl1 ~ Time cl2) =>
cl1
-> cl2
-> RunningClock m (Time cl1) (Tag cl1)
-> RunningClock m (Time cl2) (Tag cl2)
-> RunningClock m (Time cl1) (Either (Tag cl1) (Tag cl2))
runningSchedule cl1
_ cl2
_ RunningClock m (Time cl1) (Tag cl1)
rc1 RunningClock m (Time cl2) (Tag cl2)
rc2 = forall (m :: Type -> Type) b.
Monad m =>
MStream m [b] -> MStream m b
concatS forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a b.
(Monad m, MonadSchedule m) =>
NonEmpty (MSF m a b) -> MSF m a (NonEmpty b)
scheduleList [RunningClock m (Time cl1) (Tag cl1)
rc1 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 :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. a -> Either a b
Left), RunningClock m (Time cl2) (Tag cl2)
rc2 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 :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. b -> Either a b
Right)] 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 :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr forall a. NonEmpty a -> [a]
N.toList

{- | A schedule implements a combination of two clocks.
   It outputs a time stamp and an 'Either' value,
   which specifies which of the two subclocks has ticked.
-}
initSchedule ::
  ( Time cl1 ~ Time cl2
  , Monad m
  , MonadSchedule m
  , Clock m cl1
  , Clock m cl2
  ) =>
  cl1 ->
  cl2 ->
  RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule :: forall cl1 cl2 (m :: Type -> Type).
(Time cl1 ~ Time cl2, Monad m, MonadSchedule m, Clock m cl1,
 Clock m cl2) =>
cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule cl1
cl1 cl2
cl2 = do
  (RunningClock m (Time cl2) (Tag cl1)
runningClock1, Time cl2
initTime) <- forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl1
cl1
  (RunningClock m (Time cl2) (Tag cl2)
runningClock2, Time cl2
_) <- forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl2
cl2
  forall (m :: Type -> Type) a. Monad m => a -> m a
return
    ( forall (m :: Type -> Type) cl1 cl2.
(Monad m, MonadSchedule m, Clock m cl1, Clock m cl2,
 Time cl1 ~ Time cl2) =>
cl1
-> cl2
-> RunningClock m (Time cl1) (Tag cl1)
-> RunningClock m (Time cl2) (Tag cl2)
-> RunningClock m (Time cl1) (Either (Tag cl1) (Tag cl2))
runningSchedule cl1
cl1 cl2
cl2 RunningClock m (Time cl2) (Tag cl1)
runningClock1 RunningClock m (Time cl2) (Tag cl2)
runningClock2
    , Time cl2
initTime
    )

-- * Composite clocks

-- ** Sequentially combined clocks

{- | Two clocks can be combined with a schedule as a clock
   for an asynchronous sequential composition of signal networks.
-}
data SequentialClock cl1 cl2 = Time cl1 ~ Time cl2 =>
  SequentialClock
  { forall cl1 cl2. SequentialClock cl1 cl2 -> cl1
sequentialCl1 :: cl1
  , forall cl1 cl2. SequentialClock cl1 cl2 -> cl2
sequentialCl2 :: cl2
  }

-- | Abbrevation synonym.
type SeqClock cl1 cl2 = SequentialClock cl1 cl2

instance
  (Monad m, MonadSchedule m, Clock m cl1, Clock m cl2) =>
  Clock m (SequentialClock cl1 cl2)
  where
  type Time (SequentialClock cl1 cl2) = Time cl1
  type Tag (SequentialClock cl1 cl2) = Either (Tag cl1) (Tag cl2)
  initClock :: SequentialClock cl1 cl2
-> RunningClockInit
     m (Time (SequentialClock cl1 cl2)) (Tag (SequentialClock cl1 cl2))
initClock SequentialClock {cl1
cl2
sequentialCl2 :: cl2
sequentialCl1 :: cl1
sequentialCl2 :: forall cl1 cl2. SequentialClock cl1 cl2 -> cl2
sequentialCl1 :: forall cl1 cl2. SequentialClock cl1 cl2 -> cl1
..} =
    forall cl1 cl2 (m :: Type -> Type).
(Time cl1 ~ Time cl2, Monad m, MonadSchedule m, Clock m cl1,
 Clock m cl2) =>
cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule cl1
sequentialCl1 cl2
sequentialCl2

-- ** Parallelly combined clocks

{- | Two clocks can be combined with a schedule as a clock
   for an asynchronous parallel composition of signal networks.
-}
data ParallelClock cl1 cl2 = Time cl1 ~ Time cl2 =>
  ParallelClock
  { forall cl1 cl2. ParallelClock cl1 cl2 -> cl1
parallelCl1 :: cl1
  , forall cl1 cl2. ParallelClock cl1 cl2 -> cl2
parallelCl2 :: cl2
  }

-- | Abbrevation synonym.
type ParClock cl1 cl2 = ParallelClock cl1 cl2

instance
  (Monad m, MonadSchedule m, Clock m cl1, Clock m cl2) =>
  Clock m (ParallelClock cl1 cl2)
  where
  type Time (ParallelClock cl1 cl2) = Time cl1
  type Tag (ParallelClock cl1 cl2) = Either (Tag cl1) (Tag cl2)
  initClock :: ParallelClock cl1 cl2
-> RunningClockInit
     m (Time (ParallelClock cl1 cl2)) (Tag (ParallelClock cl1 cl2))
initClock ParallelClock {cl1
cl2
parallelCl2 :: cl2
parallelCl1 :: cl1
parallelCl2 :: forall cl1 cl2. ParallelClock cl1 cl2 -> cl2
parallelCl1 :: forall cl1 cl2. ParallelClock cl1 cl2 -> cl1
..} =
    forall cl1 cl2 (m :: Type -> Type).
(Time cl1 ~ Time cl2, Monad m, MonadSchedule m, Clock m cl1,
 Clock m cl2) =>
cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule cl1
parallelCl1 cl2
parallelCl2

-- * Navigating the clock tree

-- | The clock that represents the rate at which data enters the system.
type family In cl where
  In (SequentialClock cl1 cl2) = In cl1
  In (ParallelClock cl1 cl2) = ParallelClock (In cl1) (In cl2)
  In cl = cl

-- | The clock that represents the rate at which data leaves the system.
type family Out cl where
  Out (SequentialClock cl1 cl2) = Out cl2
  Out (ParallelClock cl1 cl2) = ParallelClock (Out cl1) (Out cl2)
  Out cl = cl

{- | A tree representing possible last times to which
   the constituents of a clock may have ticked.
-}
data LastTime cl where
  SequentialLastTime ::
    LastTime cl1 ->
    LastTime cl2 ->
    LastTime (SequentialClock cl1 cl2)
  ParallelLastTime ::
    LastTime cl1 ->
    LastTime cl2 ->
    LastTime (ParallelClock cl1 cl2)
  LeafLastTime :: Time cl -> LastTime cl

-- | An inclusion of a clock into a tree of parallel compositions of clocks.
data ParClockInclusion clS cl where
  ParClockInL ::
    ParClockInclusion (ParallelClock clL clR) cl ->
    ParClockInclusion clL cl
  ParClockInR ::
    ParClockInclusion (ParallelClock clL clR) cl ->
    ParClockInclusion clR cl
  ParClockRefl :: ParClockInclusion cl cl

{- | Generates a tag for the composite clock from a tag of a leaf clock,
   given a parallel clock inclusion.
-}
parClockTagInclusion :: ParClockInclusion clS cl -> Tag clS -> Tag cl
parClockTagInclusion :: forall clS cl. ParClockInclusion clS cl -> Tag clS -> Tag cl
parClockTagInclusion (ParClockInL ParClockInclusion (ParallelClock clS clR) cl
parClockInL) Tag clS
tag = forall clS cl. ParClockInclusion clS cl -> Tag clS -> Tag cl
parClockTagInclusion ParClockInclusion (ParallelClock clS clR) cl
parClockInL forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Tag clS
tag
parClockTagInclusion (ParClockInR ParClockInclusion (ParallelClock clL clS) cl
parClockInR) Tag clS
tag = forall clS cl. ParClockInclusion clS cl -> Tag clS -> Tag cl
parClockTagInclusion ParClockInclusion (ParallelClock clL clS) cl
parClockInR forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Tag clS
tag
parClockTagInclusion ParClockInclusion clS cl
ParClockRefl Tag clS
tag = Tag clS
tag