{- |
Clocks implemented in the 'ScheduleT' monad transformer
can always be scheduled (by construction).
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Schedule.Trans where

-- dunai
import Data.MonadicStreamFunction.InternalCore

-- rhine
import Control.Monad.Schedule
import FRP.Rhine.Clock
import FRP.Rhine.Schedule


-- * Universal schedule for the 'ScheduleT' monad transformer

-- | Two clocks in the 'ScheduleT' monad transformer
--   can always be canonically scheduled.
--   Indeed, this is the purpose for which 'ScheduleT' was defined.
schedule
  :: ( Monad m
     , Clock (ScheduleT (Diff (Time cl1)) m) cl1
     , Clock (ScheduleT (Diff (Time cl1)) m) cl2
     , Time cl1 ~ Time cl2
     , Ord (Diff (Time cl1))
     , Num (Diff (Time cl1))
     )
  => Schedule (ScheduleT (Diff (Time cl1)) m) cl1 cl2
schedule :: Schedule (ScheduleT (Diff (Time cl1)) m) cl1 cl2
schedule = Schedule :: 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 {cl1
-> cl2
-> FreeT
     (Wait (Diff (Time cl2)))
     m
     (MSF
        (FreeT (Wait (Diff (Time cl2))) m)
        ()
        (Time cl1, Either (Tag cl1) (Tag cl2)),
      Time cl1)
forall (m :: Type -> Type) cl1 cl2.
(Monad m, Num (Diff (Time cl1)), Ord (Diff (Time cl1)),
 Clock (ScheduleT (Diff (Time cl2)) m) cl2,
 Clock (ScheduleT (Diff (Time cl1)) m) cl1,
 Clock (ScheduleT (Diff (Time cl1)) m) cl2, Time cl2 ~ Time cl1) =>
cl1
-> cl2
-> ScheduleT
     (Diff (Time cl1))
     m
     (MSF
        (ScheduleT (Diff (Time cl1)) m)
        ()
        (Time cl1, Either (Tag cl1) (Tag cl2)),
      Time cl1)
initSchedule :: cl1
-> cl2
-> FreeT
     (Wait (Diff (Time cl2)))
     m
     (MSF
        (FreeT (Wait (Diff (Time cl2))) m)
        ()
        (Time cl1, Either (Tag cl1) (Tag cl2)),
      Time cl1)
initSchedule :: forall (m :: Type -> Type) cl1 cl2.
(Monad m, Num (Diff (Time cl1)), Ord (Diff (Time cl1)),
 Clock (ScheduleT (Diff (Time cl2)) m) cl2,
 Clock (ScheduleT (Diff (Time cl1)) m) cl1,
 Clock (ScheduleT (Diff (Time cl1)) m) cl2, Time cl2 ~ Time cl1) =>
cl1
-> cl2
-> ScheduleT
     (Diff (Time cl1))
     m
     (MSF
        (ScheduleT (Diff (Time cl1)) m)
        ()
        (Time cl1, Either (Tag cl1) (Tag cl2)),
      Time cl1)
..}
  where
    initSchedule :: cl1
-> cl2
-> ScheduleT
     (Diff (Time cl1))
     m
     (MSF
        (ScheduleT (Diff (Time cl1)) m)
        ()
        (Time cl1, Either (Tag cl1) (Tag cl2)),
      Time cl1)
initSchedule cl1
cl1 cl2
cl2 = do
      (RunningClock (ScheduleT (Diff (Time cl1)) m) (Time cl1) (Tag cl1)
runningClock1, Time cl1
initTime) <- cl1
-> RunningClockInit
     (ScheduleT (Diff (Time cl1)) m) (Time cl1) (Tag cl1)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl1
cl1
      (RunningClock (ScheduleT (Diff (Time cl1)) m) (Time cl2) (Tag cl2)
runningClock2, Time cl1
_)        <- cl2
-> RunningClockInit
     (ScheduleT (Diff (Time cl1)) m) (Time cl2) (Tag cl2)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl2
cl2
      (MSF
   (ScheduleT (Diff (Time cl1)) m)
   ()
   (Time cl1, Either (Tag cl1) (Tag cl2)),
 Time cl1)
-> ScheduleT
     (Diff (Time cl1))
     m
     (MSF
        (ScheduleT (Diff (Time cl1)) m)
        ()
        (Time cl1, Either (Tag cl1) (Tag cl2)),
      Time cl1)
forall (m :: Type -> Type) a. Monad m => a -> m a
return
        ( cl1
-> cl2
-> RunningClock
     (ScheduleT (Diff (Time cl1)) m) (Time cl1) (Tag cl1)
-> RunningClock
     (ScheduleT (Diff (Time cl1)) m) (Time cl2) (Tag cl2)
-> MSF
     (ScheduleT (Diff (Time cl1)) m)
     ()
     (Time cl1, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) cl1 cl2.
(Monad m, Clock (ScheduleT (Diff (Time cl1)) m) cl1,
 Clock (ScheduleT (Diff (Time cl2)) m) cl2, Time cl1 ~ Time cl2,
 Ord (Diff (Time cl1)), Num (Diff (Time cl1))) =>
cl1
-> cl2
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
-> MSF
     (ScheduleT (Diff (Time cl1)) m)
     ()
     (Time cl1, Either (Tag cl1) (Tag cl2))
runningSchedule cl1
cl1 cl2
cl2 RunningClock (ScheduleT (Diff (Time cl1)) m) (Time cl1) (Tag cl1)
runningClock1 RunningClock (ScheduleT (Diff (Time cl1)) m) (Time cl2) (Tag cl2)
runningClock2
        , Time cl1
initTime
        )

    -- Combines the two individual running clocks to one running clock.
    runningSchedule
      :: ( Monad m
         , Clock (ScheduleT (Diff (Time cl1)) m) cl1
         , Clock (ScheduleT (Diff (Time cl2)) m) cl2
         , Time cl1 ~ Time cl2
         , Ord (Diff (Time cl1))
         , Num (Diff (Time cl1))
         )
      => cl1 -> cl2
      -> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
      -> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
      -> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Either (Tag cl1) (Tag cl2))
    runningSchedule :: cl1
-> cl2
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
-> MSF
     (ScheduleT (Diff (Time cl1)) m)
     ()
     (Time cl1, Either (Tag cl1) (Tag cl2))
runningSchedule cl1
cl1 cl2
cl2 MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
rc1 MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
rc2 = (()
 -> FreeT
      (Wait (Diff (Time cl2)))
      m
      ((Time cl2, Either (Tag cl1) (Tag cl2)),
       MSF
         (FreeT (Wait (Diff (Time cl2))) m)
         ()
         (Time cl2, Either (Tag cl1) (Tag cl2))))
-> MSF
     (FreeT (Wait (Diff (Time cl2))) m)
     ()
     (Time cl2, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) a b.
(a -> m (b, MSF m a b)) -> MSF m a b
MSF ((()
  -> FreeT
       (Wait (Diff (Time cl2)))
       m
       ((Time cl2, Either (Tag cl1) (Tag cl2)),
        MSF
          (FreeT (Wait (Diff (Time cl2))) m)
          ()
          (Time cl2, Either (Tag cl1) (Tag cl2))))
 -> MSF
      (FreeT (Wait (Diff (Time cl2))) m)
      ()
      (Time cl2, Either (Tag cl1) (Tag cl2)))
-> (()
    -> FreeT
         (Wait (Diff (Time cl2)))
         m
         ((Time cl2, Either (Tag cl1) (Tag cl2)),
          MSF
            (FreeT (Wait (Diff (Time cl2))) m)
            ()
            (Time cl2, Either (Tag cl1) (Tag cl2))))
-> MSF
     (FreeT (Wait (Diff (Time cl2))) m)
     ()
     (Time cl2, Either (Tag cl1) (Tag cl2))
forall a b. (a -> b) -> a -> b
$ \()
_ -> do
      -- Race both clocks against each other
      Either
  (((Time cl2, Tag cl1),
    MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)),
   ScheduleT
     (Diff (Time cl2))
     m
     ((Time cl2, Tag cl2),
      MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)))
  (ScheduleT
     (Diff (Time cl2))
     m
     ((Time cl2, Tag cl1),
      MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)),
   ((Time cl2, Tag cl2),
    MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)))
raceResult <- ScheduleT
  (Diff (Time cl2))
  m
  ((Time cl2, Tag cl1),
   MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1))
-> ScheduleT
     (Diff (Time cl2))
     m
     ((Time cl2, Tag cl2),
      MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2))
-> ScheduleT
     (Diff (Time cl2))
     m
     (Either
        (((Time cl2, Tag cl1),
          MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)),
         ScheduleT
           (Diff (Time cl2))
           m
           ((Time cl2, Tag cl2),
            MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)))
        (ScheduleT
           (Diff (Time cl2))
           m
           ((Time cl2, Tag cl1),
            MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)),
         ((Time cl2, Tag cl2),
          MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2))))
forall diff (m :: Type -> Type) a b.
(Ord diff, Num diff, Monad m) =>
ScheduleT diff m a
-> ScheduleT diff m b
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
race (MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)
-> ()
-> ScheduleT
     (Diff (Time cl2))
     m
     ((Time cl2, Tag cl1),
      MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1))
forall (m :: Type -> Type) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)
rc1 ()) (MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)
-> ()
-> ScheduleT
     (Diff (Time cl2))
     m
     ((Time cl2, Tag cl2),
      MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2))
forall (m :: Type -> Type) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)
rc2 ())
      case Either
  (((Time cl2, Tag cl1),
    MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)),
   ScheduleT
     (Diff (Time cl2))
     m
     ((Time cl2, Tag cl2),
      MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)))
  (ScheduleT
     (Diff (Time cl2))
     m
     ((Time cl2, Tag cl1),
      MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)),
   ((Time cl2, Tag cl2),
    MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)))
raceResult of
        -- The first clock ticks first...
        Left  (((Time cl2
time, Tag cl1
tag1), MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)
rc1'), ScheduleT
  (Diff (Time cl2))
  m
  ((Time cl2, Tag cl2),
   MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2))
cont2) -> ((Time cl2, Either (Tag cl1) (Tag cl2)),
 MSF
   (FreeT (Wait (Diff (Time cl2))) m)
   ()
   (Time cl2, Either (Tag cl1) (Tag cl2)))
-> FreeT
     (Wait (Diff (Time cl2)))
     m
     ((Time cl2, Either (Tag cl1) (Tag cl2)),
      MSF
        (FreeT (Wait (Diff (Time cl2))) m)
        ()
        (Time cl2, Either (Tag cl1) (Tag cl2)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return
          -- so we can emit its time stamp...
          ( (Time cl2
time, Tag cl1 -> Either (Tag cl1) (Tag cl2)
forall a b. a -> Either a b
Left Tag cl1
tag1)
          -- and continue.
          , cl1
-> cl2
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
-> MSF
     (ScheduleT (Diff (Time cl1)) m)
     ()
     (Time cl1, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) cl1 cl2.
(Monad m, Clock (ScheduleT (Diff (Time cl1)) m) cl1,
 Clock (ScheduleT (Diff (Time cl2)) m) cl2, Time cl1 ~ Time cl2,
 Ord (Diff (Time cl1)), Num (Diff (Time cl1))) =>
cl1
-> cl2
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
-> MSF
     (ScheduleT (Diff (Time cl1)) m)
     ()
     (Time cl1, Either (Tag cl1) (Tag cl2))
runningSchedule cl1
cl1 cl2
cl2 MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)
rc1' ((()
 -> ScheduleT
      (Diff (Time cl2))
      m
      ((Time cl2, Tag cl2),
       MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)))
-> MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)
forall (m :: Type -> Type) a b.
(a -> m (b, MSF m a b)) -> MSF m a b
MSF ((()
  -> ScheduleT
       (Diff (Time cl2))
       m
       ((Time cl2, Tag cl2),
        MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)))
 -> MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2))
-> (()
    -> ScheduleT
         (Diff (Time cl2))
         m
         ((Time cl2, Tag cl2),
          MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)))
-> MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)
forall a b. (a -> b) -> a -> b
$ ScheduleT
  (Diff (Time cl2))
  m
  ((Time cl2, Tag cl2),
   MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2))
-> ()
-> ScheduleT
     (Diff (Time cl2))
     m
     ((Time cl2, Tag cl2),
      MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2))
forall a b. a -> b -> a
const ScheduleT
  (Diff (Time cl2))
  m
  ((Time cl2, Tag cl2),
   MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2))
cont2)
          )
        -- The second clock ticks first...
        Right (ScheduleT
  (Diff (Time cl2))
  m
  ((Time cl2, Tag cl1),
   MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1))
cont1, ((Time cl2
time, Tag cl2
tag2), MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)
rc2')) -> ((Time cl2, Either (Tag cl1) (Tag cl2)),
 MSF
   (FreeT (Wait (Diff (Time cl2))) m)
   ()
   (Time cl2, Either (Tag cl1) (Tag cl2)))
-> FreeT
     (Wait (Diff (Time cl2)))
     m
     ((Time cl2, Either (Tag cl1) (Tag cl2)),
      MSF
        (FreeT (Wait (Diff (Time cl2))) m)
        ()
        (Time cl2, Either (Tag cl1) (Tag cl2)))
forall (m :: Type -> Type) a. Monad m => a -> m a
return
          -- so we can emit its time stamp...
          ( (Time cl2
time, Tag cl2 -> Either (Tag cl1) (Tag cl2)
forall a b. b -> Either a b
Right Tag cl2
tag2)
          -- and continue.
          , cl1
-> cl2
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
-> MSF
     (ScheduleT (Diff (Time cl1)) m)
     ()
     (Time cl1, Either (Tag cl1) (Tag cl2))
forall (m :: Type -> Type) cl1 cl2.
(Monad m, Clock (ScheduleT (Diff (Time cl1)) m) cl1,
 Clock (ScheduleT (Diff (Time cl2)) m) cl2, Time cl1 ~ Time cl2,
 Ord (Diff (Time cl1)), Num (Diff (Time cl1))) =>
cl1
-> cl2
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)
-> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
-> MSF
     (ScheduleT (Diff (Time cl1)) m)
     ()
     (Time cl1, Either (Tag cl1) (Tag cl2))
runningSchedule cl1
cl1 cl2
cl2 ((()
 -> ScheduleT
      (Diff (Time cl2))
      m
      ((Time cl2, Tag cl1),
       MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)))
-> MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)
forall (m :: Type -> Type) a b.
(a -> m (b, MSF m a b)) -> MSF m a b
MSF ((()
  -> ScheduleT
       (Diff (Time cl2))
       m
       ((Time cl2, Tag cl1),
        MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)))
 -> MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1))
-> (()
    -> ScheduleT
         (Diff (Time cl2))
         m
         ((Time cl2, Tag cl1),
          MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)))
-> MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1)
forall a b. (a -> b) -> a -> b
$ ScheduleT
  (Diff (Time cl2))
  m
  ((Time cl2, Tag cl1),
   MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1))
-> ()
-> ScheduleT
     (Diff (Time cl2))
     m
     ((Time cl2, Tag cl1),
      MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1))
forall a b. a -> b -> a
const ScheduleT
  (Diff (Time cl2))
  m
  ((Time cl2, Tag cl1),
   MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl1))
cont1) MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)
MSF (FreeT (Wait (Diff (Time cl2))) m) () (Time cl2, Tag cl2)
rc2'
          )