{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}

module FRP.Rhine.Clock.Proxy where

-- base
import Data.Kind (Type)

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

{- | Witnesses the structure of a clock type,
   in particular whether 'SequentialClock's or 'ParallelClock's are involved.
-}
data ClockProxy cl where
  LeafProxy ::
    (cl ~ In cl, cl ~ Out cl) =>
    ClockProxy cl
  SequentialProxy ::
    ClockProxy cl1 ->
    ClockProxy cl2 ->
    ClockProxy (SequentialClock cl1 cl2)
  ParallelProxy ::
    ClockProxy clL ->
    ClockProxy clR ->
    ClockProxy (ParallelClock clL clR)

inProxy :: ClockProxy cl -> ClockProxy (In cl)
inProxy :: forall cl. ClockProxy cl -> ClockProxy (In cl)
inProxy ClockProxy cl
LeafProxy = ClockProxy cl
ClockProxy (In cl)
forall cl. (cl ~ In cl, cl ~ Out cl) => ClockProxy cl
LeafProxy
inProxy (SequentialProxy ClockProxy cl1
p1 ClockProxy cl2
_) = ClockProxy cl1 -> ClockProxy (In cl1)
forall cl. ClockProxy cl -> ClockProxy (In cl)
inProxy ClockProxy cl1
p1
inProxy (ParallelProxy ClockProxy clL
pL ClockProxy clR
pR) = ClockProxy (In clL)
-> ClockProxy (In clR)
-> ClockProxy (ParallelClock (In clL) (In clR))
forall cl1 cl2.
ClockProxy cl1
-> ClockProxy cl2 -> ClockProxy (ParallelClock cl1 cl2)
ParallelProxy (ClockProxy clL -> ClockProxy (In clL)
forall cl. ClockProxy cl -> ClockProxy (In cl)
inProxy ClockProxy clL
pL) (ClockProxy clR -> ClockProxy (In clR)
forall cl. ClockProxy cl -> ClockProxy (In cl)
inProxy ClockProxy clR
pR)

outProxy :: ClockProxy cl -> ClockProxy (Out cl)
outProxy :: forall cl. ClockProxy cl -> ClockProxy (Out cl)
outProxy ClockProxy cl
LeafProxy = ClockProxy cl
ClockProxy (Out cl)
forall cl. (cl ~ In cl, cl ~ Out cl) => ClockProxy cl
LeafProxy
outProxy (SequentialProxy ClockProxy cl1
_ ClockProxy cl2
p2) = ClockProxy cl2 -> ClockProxy (Out cl2)
forall cl. ClockProxy cl -> ClockProxy (Out cl)
outProxy ClockProxy cl2
p2
outProxy (ParallelProxy ClockProxy clL
pL ClockProxy clR
pR) = ClockProxy (Out clL)
-> ClockProxy (Out clR)
-> ClockProxy (ParallelClock (Out clL) (Out clR))
forall cl1 cl2.
ClockProxy cl1
-> ClockProxy cl2 -> ClockProxy (ParallelClock cl1 cl2)
ParallelProxy (ClockProxy clL -> ClockProxy (Out clL)
forall cl. ClockProxy cl -> ClockProxy (Out cl)
outProxy ClockProxy clL
pL) (ClockProxy clR -> ClockProxy (Out clR)
forall cl. ClockProxy cl -> ClockProxy (Out cl)
outProxy ClockProxy clR
pR)

{- | Return the incoming tag, assuming that the incoming clock is ticked,
   and 'Nothing' otherwise.
-}
inTag :: ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))
inTag :: forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))
inTag (SequentialProxy ClockProxy cl1
p1 ClockProxy cl2
_) (Left Tag cl1
tag1) = ClockProxy cl1 -> Tag cl1 -> Maybe (Tag (In cl1))
forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))
inTag ClockProxy cl1
p1 Tag cl1
tag1
inTag (SequentialProxy ClockProxy cl1
_ ClockProxy cl2
_) (Right Tag cl2
_) = Maybe (Tag (In cl))
Maybe (Tag (In cl1))
forall a. Maybe a
Nothing
inTag (ParallelProxy ClockProxy clL
pL ClockProxy clR
_) (Left Tag clL
tagL) = Tag (In clL) -> Either (Tag (In clL)) (Tag (In clR))
forall a b. a -> Either a b
Left (Tag (In clL) -> Either (Tag (In clL)) (Tag (In clR)))
-> Maybe (Tag (In clL))
-> Maybe (Either (Tag (In clL)) (Tag (In clR)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ClockProxy clL -> Tag clL -> Maybe (Tag (In clL))
forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))
inTag ClockProxy clL
pL Tag clL
tagL
inTag (ParallelProxy ClockProxy clL
_ ClockProxy clR
pR) (Right Tag clR
tagR) = Tag (In clR) -> Either (Tag (In clL)) (Tag (In clR))
forall a b. b -> Either a b
Right (Tag (In clR) -> Either (Tag (In clL)) (Tag (In clR)))
-> Maybe (Tag (In clR))
-> Maybe (Either (Tag (In clL)) (Tag (In clR)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ClockProxy clR -> Tag clR -> Maybe (Tag (In clR))
forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))
inTag ClockProxy clR
pR Tag clR
tagR
inTag ClockProxy cl
LeafProxy Tag cl
tag = Tag cl -> Maybe (Tag cl)
forall a. a -> Maybe a
Just Tag cl
tag

{- | Return the incoming tag, assuming that the outgoing clock is ticked,
   and 'Nothing' otherwise.
-}
outTag :: ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))
outTag :: forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))
outTag (SequentialProxy ClockProxy cl1
_ ClockProxy cl2
_) (Left Tag cl1
_) = Maybe (Tag (Out cl))
Maybe (Tag (Out cl2))
forall a. Maybe a
Nothing
outTag (SequentialProxy ClockProxy cl1
_ ClockProxy cl2
p2) (Right Tag cl2
tag2) = ClockProxy cl2 -> Tag cl2 -> Maybe (Tag (Out cl2))
forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))
outTag ClockProxy cl2
p2 Tag cl2
tag2
outTag (ParallelProxy ClockProxy clL
pL ClockProxy clR
_) (Left Tag clL
tagL) = Tag (Out clL) -> Either (Tag (Out clL)) (Tag (Out clR))
forall a b. a -> Either a b
Left (Tag (Out clL) -> Either (Tag (Out clL)) (Tag (Out clR)))
-> Maybe (Tag (Out clL))
-> Maybe (Either (Tag (Out clL)) (Tag (Out clR)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ClockProxy clL -> Tag clL -> Maybe (Tag (Out clL))
forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))
outTag ClockProxy clL
pL Tag clL
tagL
outTag (ParallelProxy ClockProxy clL
_ ClockProxy clR
pR) (Right Tag clR
tagR) = Tag (Out clR) -> Either (Tag (Out clL)) (Tag (Out clR))
forall a b. b -> Either a b
Right (Tag (Out clR) -> Either (Tag (Out clL)) (Tag (Out clR)))
-> Maybe (Tag (Out clR))
-> Maybe (Either (Tag (Out clL)) (Tag (Out clR)))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ClockProxy clR -> Tag clR -> Maybe (Tag (Out clR))
forall cl. ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))
outTag ClockProxy clR
pR Tag clR
tagR
outTag ClockProxy cl
LeafProxy Tag cl
tag = Tag cl -> Maybe (Tag cl)
forall a. a -> Maybe a
Just Tag cl
tag

-- TODO Should this be a superclass with default implementation of clocks? But then we have a circular dependency...
-- No we don't, Schedule should not depend on clock (the type).

-- | Clocks should be able to automatically generate a proxy for themselves.
class GetClockProxy cl where
  getClockProxy :: ClockProxy cl
  default getClockProxy ::
    (cl ~ In cl, cl ~ Out cl) =>
    ClockProxy cl
  getClockProxy = ClockProxy cl
forall cl. (cl ~ In cl, cl ~ Out cl) => ClockProxy cl
LeafProxy

instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (SequentialClock cl1 cl2) where
  getClockProxy :: ClockProxy (SequentialClock cl1 cl2)
getClockProxy = ClockProxy cl1
-> ClockProxy cl2 -> ClockProxy (SequentialClock cl1 cl2)
forall cl1 cl2.
ClockProxy cl1
-> ClockProxy cl2 -> ClockProxy (SequentialClock cl1 cl2)
SequentialProxy ClockProxy cl1
forall cl. GetClockProxy cl => ClockProxy cl
getClockProxy ClockProxy cl2
forall cl. GetClockProxy cl => ClockProxy cl
getClockProxy

instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (ParallelClock cl1 cl2) where
  getClockProxy :: ClockProxy (ParallelClock cl1 cl2)
getClockProxy = ClockProxy cl1
-> ClockProxy cl2 -> ClockProxy (ParallelClock cl1 cl2)
forall cl1 cl2.
ClockProxy cl1
-> ClockProxy cl2 -> ClockProxy (ParallelClock cl1 cl2)
ParallelProxy ClockProxy cl1
forall cl. GetClockProxy cl => ClockProxy cl
getClockProxy ClockProxy cl2
forall cl. GetClockProxy cl => ClockProxy cl
getClockProxy

instance (GetClockProxy cl) => GetClockProxy (HoistClock m1 m2 cl)
instance (GetClockProxy cl) => GetClockProxy (RescaledClock cl time)
instance (GetClockProxy cl) => GetClockProxy (RescaledClockM m cl time)
instance (GetClockProxy cl) => GetClockProxy (RescaledClockS m cl time tag)

-- | Extract a clock proxy from a type.
class ToClockProxy a where
  type Cl a :: Type

  toClockProxy :: a -> ClockProxy (Cl a)
  default toClockProxy ::
    (GetClockProxy (Cl a)) =>
    a ->
    ClockProxy (Cl a)
  toClockProxy a
_ = ClockProxy (Cl a)
forall cl. GetClockProxy cl => ClockProxy cl
getClockProxy