{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Clock.Proxy where
import Data.Kind (Type)
import FRP.Rhine.Clock
import FRP.Rhine.Schedule
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 LeafProxy = LeafProxy
inProxy (SequentialProxy p1 p2) = inProxy p1
inProxy (ParallelProxy pL pR) = ParallelProxy (inProxy pL) (inProxy pR)
outProxy :: ClockProxy cl -> ClockProxy (Out cl)
outProxy LeafProxy = LeafProxy
outProxy (SequentialProxy p1 p2) = outProxy p2
outProxy (ParallelProxy pL pR) = ParallelProxy (outProxy pL) (outProxy pR)
inTag :: ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))
inTag (SequentialProxy p1 _) (Left tag1) = inTag p1 tag1
inTag (SequentialProxy _ _) (Right _) = Nothing
inTag (ParallelProxy pL _) (Left tagL) = Left <$> inTag pL tagL
inTag (ParallelProxy _ pR) (Right tagR) = Right <$> inTag pR tagR
inTag LeafProxy tag = Just tag
outTag :: ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))
outTag (SequentialProxy _ _ ) (Left _) = Nothing
outTag (SequentialProxy _ p2) (Right tag2) = outTag p2 tag2
outTag (ParallelProxy pL _) (Left tagL) = Left <$> outTag pL tagL
outTag (ParallelProxy _ pR) (Right tagR) = Right <$> outTag pR tagR
outTag LeafProxy tag = Just tag
class GetClockProxy cl where
getClockProxy :: ClockProxy cl
default getClockProxy
:: (cl ~ In cl, cl ~ Out cl)
=> ClockProxy cl
getClockProxy = LeafProxy
instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (SequentialClock m cl1 cl2) where
getClockProxy = SequentialProxy getClockProxy getClockProxy
instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (ParallelClock m cl1 cl2) where
getClockProxy = ParallelProxy getClockProxy 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)
class ToClockProxy a where
type Cl a :: Type
toClockProxy :: a -> ClockProxy (Cl a)
default toClockProxy
:: GetClockProxy (Cl a)
=> a -> ClockProxy (Cl a)
toClockProxy _ = getClockProxy