{-# 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 m cl1 cl2)
  ParallelProxy
    :: ClockProxy clL
    -> ClockProxy clR
    -> ClockProxy (ParallelClock m clL clR)

inProxy :: ClockProxy cl -> ClockProxy (In cl)
inProxy :: ClockProxy cl -> ClockProxy (In cl)
inProxy ClockProxy cl
LeafProxy = 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 m (In clL) (In clR))
forall clL clR (m :: Type -> Type).
ClockProxy clL
-> ClockProxy clR -> ClockProxy (ParallelClock m clL clR)
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 :: ClockProxy cl -> ClockProxy (Out cl)
outProxy ClockProxy cl
LeafProxy = 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 m (Out clL) (Out clR))
forall clL clR (m :: Type -> Type).
ClockProxy clL
-> ClockProxy clR -> ClockProxy (ParallelClock m clL clR)
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 :: ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))
inTag (SequentialProxy ClockProxy cl1
p1 ClockProxy cl2
_) (Left  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 _)    = Maybe (Tag (In cl))
forall a. Maybe a
Nothing
inTag (ParallelProxy ClockProxy clL
pL ClockProxy clR
_) (Left  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 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 :: ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))
outTag (SequentialProxy ClockProxy cl1
_ ClockProxy cl2
_ ) (Left  _)    = Maybe (Tag (Out cl))
forall a. Maybe a
Nothing
outTag (SequentialProxy ClockProxy cl1
_ ClockProxy cl2
p2) (Right 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  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 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 m cl1 cl2) where
  getClockProxy :: ClockProxy (SequentialClock m cl1 cl2)
getClockProxy = ClockProxy cl1
-> ClockProxy cl2 -> ClockProxy (SequentialClock m cl1 cl2)
forall cl1 cl2 (m :: Type -> Type).
ClockProxy cl1
-> ClockProxy cl2 -> ClockProxy (SequentialClock m 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 m cl1 cl2) where
  getClockProxy :: ClockProxy (ParallelClock m cl1 cl2)
getClockProxy = ClockProxy cl1
-> ClockProxy cl2 -> ClockProxy (ParallelClock m cl1 cl2)
forall clL clR (m :: Type -> Type).
ClockProxy clL
-> ClockProxy clR -> ClockProxy (ParallelClock m clL clR)
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