{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

{- | Utilities to run 'ClSF's at the speed of combined clocks
   when they are defined only for a constituent clock.
-}
module FRP.Rhine.ClSF.Upsample where

-- dunai
import Control.Monad.Trans.MSF.Reader

-- rhine
import FRP.Rhine.ClSF.Core
import FRP.Rhine.Clock
import FRP.Rhine.Schedule

{- | An 'MSF' can be given arbitrary other arguments
   that cause it to tick without doing anything
   and replicating the last output.
-}
upsampleMSF :: (Monad m) => b -> MSF m a b -> MSF m (Either arbitrary a) b
upsampleMSF :: forall (m :: Type -> Type) b a arbitrary.
Monad m =>
b -> MSF m a b -> MSF m (Either arbitrary a) b
upsampleMSF b
b MSF m a b
msf = forall (a :: Type -> Type -> Type) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right MSF m a b
msf forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: Type -> Type) a s.
Monad m =>
(a -> s -> s) -> s -> MSF m a s
accumulateWith forall a. Semigroup a => a -> a -> a
(<>) (forall a b. b -> Either a b
Right b
b) 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} {b}. Either a b -> b
fromRight
  where
    fromRight :: Either a b -> b
fromRight (Right b
b') = b
b'
    fromRight (Left a
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"fromRight: This case never occurs in upsampleMSF."

-- Note that the Semigroup instance of Either a arbitrary
-- updates when the first argument is Right.

{- | Upsample a 'ClSF' to a parallel clock.
   The given 'ClSF' is only called when @clR@ ticks,
   otherwise the last output is replicated
   (with the given @b@ as initialisation).
-}
upsampleR ::
  (Monad m, Time clL ~ Time clR) =>
  b ->
  ClSF m clR a b ->
  ClSF m (ParallelClock clL clR) a b
upsampleR :: forall (m :: Type -> Type) clL clR b a.
(Monad m, Time clL ~ Time clR) =>
b -> ClSF m clR a b -> ClSF m (ParallelClock clL clR) a b
upsampleR b
b ClSF m clR a b
clsf = forall (m :: Type -> Type) r a b.
Monad m =>
MSF m (r, a) b -> MSF (ReaderT r m) a b
readerS forall a b. (a -> b) -> a -> b
$ forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr forall {cl} {cl} {a} {b}.
(Time cl ~ Time cl, Diff (Time cl) ~ Diff (Time cl),
 Tag cl ~ Either a (Tag cl)) =>
(TimeInfo cl, b) -> Either a (TimeInfo cl, b)
remap forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: Type -> Type) b a arbitrary.
Monad m =>
b -> MSF m a b -> MSF m (Either arbitrary a) b
upsampleMSF b
b (forall (m :: Type -> Type) r a b.
Monad m =>
MSF (ReaderT r m) a b -> MSF m (r, a) b
runReaderS ClSF m clR a b
clsf)
  where
    remap :: (TimeInfo cl, b) -> Either a (TimeInfo cl, b)
remap (TimeInfo {tag :: forall cl. TimeInfo cl -> Tag cl
tag = Left a
tag}, b
_) = forall a b. a -> Either a b
Left a
tag
    remap (TimeInfo {tag :: forall cl. TimeInfo cl -> Tag cl
tag = Right Tag cl
tag, Diff (Time cl)
Time cl
absolute :: forall cl. TimeInfo cl -> Time cl
sinceInit :: forall cl. TimeInfo cl -> Diff (Time cl)
sinceLast :: forall cl. TimeInfo cl -> Diff (Time cl)
absolute :: Time cl
sinceInit :: Diff (Time cl)
sinceLast :: Diff (Time cl)
..}, b
a) = forall a b. b -> Either a b
Right (TimeInfo {Diff (Time cl)
Time cl
Tag cl
absolute :: Time cl
sinceInit :: Diff (Time cl)
sinceLast :: Diff (Time cl)
absolute :: Time cl
sinceInit :: Diff (Time cl)
sinceLast :: Diff (Time cl)
tag :: Tag cl
tag :: Tag cl
..}, b
a)

{- | Upsample a 'ClSF' to a parallel clock.
   The given 'ClSF' is only called when @clL@ ticks,
   otherwise the last output is replicated
   (with the given @b@ as initialisation).
-}
upsampleL ::
  (Monad m, Time clL ~ Time clR) =>
  b ->
  ClSF m clL a b ->
  ClSF m (ParallelClock clL clR) a b
upsampleL :: forall (m :: Type -> Type) clL clR b a.
(Monad m, Time clL ~ Time clR) =>
b -> ClSF m clL a b -> ClSF m (ParallelClock clL clR) a b
upsampleL b
b ClSF m clL a b
clsf = forall (m :: Type -> Type) r a b.
Monad m =>
MSF m (r, a) b -> MSF (ReaderT r m) a b
readerS forall a b. (a -> b) -> a -> b
$ forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr forall {cl} {cl} {b} {b}.
(Time cl ~ Time cl, Diff (Time cl) ~ Diff (Time cl),
 Tag cl ~ Either (Tag cl) b) =>
(TimeInfo cl, b) -> Either b (TimeInfo cl, b)
remap forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: Type -> Type) b a arbitrary.
Monad m =>
b -> MSF m a b -> MSF m (Either arbitrary a) b
upsampleMSF b
b (forall (m :: Type -> Type) r a b.
Monad m =>
MSF (ReaderT r m) a b -> MSF m (r, a) b
runReaderS ClSF m clL a b
clsf)
  where
    remap :: (TimeInfo cl, b) -> Either b (TimeInfo cl, b)
remap (TimeInfo {tag :: forall cl. TimeInfo cl -> Tag cl
tag = Right b
tag}, b
_) = forall a b. a -> Either a b
Left b
tag
    remap (TimeInfo {tag :: forall cl. TimeInfo cl -> Tag cl
tag = Left Tag cl
tag, Diff (Time cl)
Time cl
absolute :: Time cl
sinceInit :: Diff (Time cl)
sinceLast :: Diff (Time cl)
absolute :: forall cl. TimeInfo cl -> Time cl
sinceInit :: forall cl. TimeInfo cl -> Diff (Time cl)
sinceLast :: forall cl. TimeInfo cl -> Diff (Time cl)
..}, b
a) = forall a b. b -> Either a b
Right (TimeInfo {Diff (Time cl)
Time cl
Tag cl
absolute :: Time cl
sinceInit :: Diff (Time cl)
sinceLast :: Diff (Time cl)
tag :: Tag cl
absolute :: Time cl
sinceInit :: Diff (Time cl)
sinceLast :: Diff (Time cl)
tag :: Tag cl
..}, b
a)