{-# 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 Control.Arrow
import Data.List.NonEmpty as N

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

-- automaton
import Data.Automaton
import Data.Stream.Optimized (OptimizedStreamT (..), toStreamT)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Schedule.Internal

-- * Scheduling

{- | Run several automata concurrently.

Whenever one automaton outputs a value,
it is returned together with all other values that happen to be output at the same time.
-}
scheduleList :: (Monad m, MonadSchedule m) => NonEmpty (Automaton m a b) -> Automaton m a (NonEmpty b)
scheduleList :: forall (m :: Type -> Type) a b.
(Monad m, MonadSchedule m) =>
NonEmpty (Automaton m a b) -> Automaton m a (NonEmpty b)
scheduleList NonEmpty (Automaton m a b)
automatons0 =
  OptimizedStreamT (ReaderT a m) (NonEmpty b)
-> Automaton m a (NonEmpty b)
forall (m :: Type -> Type) a b.
OptimizedStreamT (ReaderT a m) b -> Automaton m a b
Automaton (OptimizedStreamT (ReaderT a m) (NonEmpty b)
 -> Automaton m a (NonEmpty b))
-> OptimizedStreamT (ReaderT a m) (NonEmpty b)
-> Automaton m a (NonEmpty b)
forall a b. (a -> b) -> a -> b
$
    StreamT (ReaderT a m) (NonEmpty b)
-> OptimizedStreamT (ReaderT a m) (NonEmpty b)
forall (m :: Type -> Type) a. StreamT m a -> OptimizedStreamT m a
Stateful (StreamT (ReaderT a m) (NonEmpty b)
 -> OptimizedStreamT (ReaderT a m) (NonEmpty b))
-> StreamT (ReaderT a m) (NonEmpty b)
-> OptimizedStreamT (ReaderT a m) (NonEmpty b)
forall a b. (a -> b) -> a -> b
$
      NonEmpty (StreamT (ReaderT a m) b)
-> StreamT (ReaderT a m) (NonEmpty b)
forall (m :: Type -> Type) b.
(MonadSchedule m, Applicative m) =>
NonEmpty (StreamT m b) -> StreamT m (NonEmpty b)
scheduleStreams' (NonEmpty (StreamT (ReaderT a m) b)
 -> StreamT (ReaderT a m) (NonEmpty b))
-> NonEmpty (StreamT (ReaderT a m) b)
-> StreamT (ReaderT a m) (NonEmpty b)
forall a b. (a -> b) -> a -> b
$
        OptimizedStreamT (ReaderT a m) b -> StreamT (ReaderT a m) b
forall (m :: Type -> Type) b.
Functor m =>
OptimizedStreamT m b -> StreamT m b
toStreamT (OptimizedStreamT (ReaderT a m) b -> StreamT (ReaderT a m) b)
-> (Automaton m a b -> OptimizedStreamT (ReaderT a m) b)
-> Automaton m a b
-> StreamT (ReaderT a m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Automaton m a b -> OptimizedStreamT (ReaderT a m) b
forall (m :: Type -> Type) a b.
Automaton m a b -> OptimizedStreamT (ReaderT a m) b
getAutomaton (Automaton m a b -> StreamT (ReaderT a m) b)
-> NonEmpty (Automaton m a b) -> NonEmpty (StreamT (ReaderT a m) b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Automaton m a b)
automatons0

{- | Run two automata concurrently.

Whenever one automaton returns a value, it is returned.
-}
schedulePair :: (Monad m, MonadSchedule m) => Automaton m a b -> Automaton m a b -> Automaton m a b
schedulePair :: forall (m :: Type -> Type) a b.
(Monad m, MonadSchedule m) =>
Automaton m a b -> Automaton m a b -> Automaton m a b
schedulePair Automaton m a b
automatonL Automaton m a b
automatonR = Automaton m a [b] -> Automaton m a b
forall (m :: Type -> Type) a b.
Monad m =>
Automaton m a [b] -> Automaton m a b
concatS (Automaton m a [b] -> Automaton m a b)
-> Automaton m a [b] -> Automaton m a b
forall a b. (a -> b) -> a -> b
$ (NonEmpty b -> [b])
-> Automaton m a (NonEmpty b) -> Automaton m a [b]
forall a b. (a -> b) -> Automaton m a a -> Automaton m a b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
toList (Automaton m a (NonEmpty b) -> Automaton m a [b])
-> Automaton m a (NonEmpty b) -> Automaton m a [b]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Automaton m a b) -> Automaton m a (NonEmpty b)
forall (m :: Type -> Type) a b.
(Monad m, MonadSchedule m) =>
NonEmpty (Automaton m a b) -> Automaton m a (NonEmpty b)
scheduleList (NonEmpty (Automaton m a b) -> Automaton m a (NonEmpty b))
-> NonEmpty (Automaton m a b) -> Automaton m a (NonEmpty b)
forall a b. (a -> b) -> a -> b
$ Automaton m a b
automatonL Automaton m a b -> [Automaton m a b] -> NonEmpty (Automaton m a b)
forall a. a -> [a] -> NonEmpty a
:| [Automaton m a b
Item [Automaton m a b]
automatonR]

-- | Run two running clocks concurrently.
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 = Automaton m () (Time cl2, Either (Tag cl1) (Tag cl2))
-> Automaton m () (Time cl2, Either (Tag cl1) (Tag cl2))
-> Automaton m () (Time cl2, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) a b.
(Monad m, MonadSchedule m) =>
Automaton m a b -> Automaton m a b -> Automaton m a b
schedulePair (RunningClock m (Time cl1) (Tag cl1)
Automaton m () (Time cl2, Tag cl1)
rc1 Automaton m () (Time cl2, Tag cl1)
-> Automaton
     m (Time cl2, Tag cl1) (Time cl2, Either (Tag cl1) (Tag cl2))
-> Automaton m () (Time cl2, Either (Tag cl1) (Tag cl2))
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Time cl2, Tag cl1) -> (Time cl2, Either (Tag cl1) (Tag cl2)))
-> Automaton
     m (Time cl2, Tag cl1) (Time cl2, Either (Tag cl1) (Tag cl2))
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ((Tag cl1 -> Either (Tag cl1) (Tag cl2))
-> (Time cl2, Tag cl1) -> (Time cl2, Either (Tag cl1) (Tag cl2))
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 Tag cl1 -> Either (Tag cl1) (Tag cl2)
forall a b. a -> Either a b
Left)) (RunningClock m (Time cl2) (Tag cl2)
rc2 RunningClock m (Time cl2) (Tag cl2)
-> Automaton
     m (Time cl2, Tag cl2) (Time cl2, Either (Tag cl1) (Tag cl2))
-> Automaton m () (Time cl2, Either (Tag cl1) (Tag cl2))
forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Time cl2, Tag cl2) -> (Time cl2, Either (Tag cl1) (Tag cl2)))
-> Automaton
     m (Time cl2, Tag cl2) (Time cl2, Either (Tag cl1) (Tag cl2))
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr ((Tag cl2 -> Either (Tag cl1) (Tag cl2))
-> (Time cl2, Tag cl2) -> (Time cl2, Either (Tag cl1) (Tag cl2))
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 Tag cl2 -> Either (Tag cl1) (Tag cl2)
forall a b. b -> Either a b
Right))

{- | 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) <- cl1 -> RunningClockInit m (Time cl1) (Tag cl1)
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
_) <- cl2 -> m (RunningClock m (Time cl2) (Tag cl2), Time cl2)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl2
cl2
  (RunningClock m (Time cl2) (Either (Tag cl1) (Tag cl2)), Time cl2)
-> m (RunningClock m (Time cl2) (Either (Tag cl1) (Tag cl2)),
      Time cl2)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return
    ( cl1
-> cl2
-> RunningClock m (Time cl1) (Tag cl1)
-> RunningClock m (Time cl2) (Tag cl2)
-> RunningClock m (Time cl1) (Either (Tag cl1) (Tag cl2))
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 cl1) (Tag cl1)
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
sequentialCl1 :: forall cl1 cl2. SequentialClock cl1 cl2 -> cl1
sequentialCl2 :: forall cl1 cl2. SequentialClock cl1 cl2 -> cl2
sequentialCl1 :: cl1
sequentialCl2 :: cl2
..} =
    cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
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
parallelCl1 :: forall cl1 cl2. ParallelClock cl1 cl2 -> cl1
parallelCl2 :: forall cl1 cl2. ParallelClock cl1 cl2 -> cl2
parallelCl1 :: cl1
parallelCl2 :: cl2
..} =
    cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
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 = ParClockInclusion (ParallelClock clS clR) cl
-> Tag (ParallelClock clS clR) -> Tag cl
forall clS cl. ParClockInclusion clS cl -> Tag clS -> Tag cl
parClockTagInclusion ParClockInclusion (ParallelClock clS clR) cl
parClockInL (Tag (ParallelClock clS clR) -> Tag cl)
-> Tag (ParallelClock clS clR) -> Tag cl
forall a b. (a -> b) -> a -> b
$ Tag clS -> Either (Tag clS) (Tag clR)
forall a b. a -> Either a b
Left Tag clS
tag
parClockTagInclusion (ParClockInR ParClockInclusion (ParallelClock clL clS) cl
parClockInR) Tag clS
tag = ParClockInclusion (ParallelClock clL clS) cl
-> Tag (ParallelClock clL clS) -> Tag cl
forall clS cl. ParClockInclusion clS cl -> Tag clS -> Tag cl
parClockTagInclusion ParClockInclusion (ParallelClock clL clS) cl
parClockInR (Tag (ParallelClock clL clS) -> Tag cl)
-> Tag (ParallelClock clL clS) -> Tag cl
forall a b. (a -> b) -> a -> b
$ Tag clS -> Either (Tag clL) (Tag clS)
forall a b. b -> Either a b
Right Tag clS
tag
parClockTagInclusion ParClockInclusion clS cl
ParClockRefl Tag clS
tag = Tag clS
Tag cl
tag