CHERRY try to translate between clock and clocks ti

turion · Jan 26, 2024 · 8759498 · 8759498
1 parent 2ee4558
commit 8759498
Showing 1 changed file with 17 additions and 0 deletions.
diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-} -- FIXME consider using lenses instead
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
@@ -298,6 +299,22 @@ newtype TheTag cl = TheTag {getTheTag :: Tag cl}
 
 newtype Tags cls = Tags {getTags :: HSum TheTag cls}
 
+instance (TimeDomain td) => Clock m (Clocks m td cls) where
+  type Time (Clocks m td cls) = td
+  type Tag (Clocks m td cls) = Tags cls
+
+clocksTimeInfoToTick :: TimeInfo (Clocks m td cls) -> Tick cls
+clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = Here TheTag {getTheTag}}, ..} = Tick $ Here TimeInfo {tag = getTheTag, ..}
+clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = There tag}, ..} = Tick $ There $ getTick $ clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = tag}, ..}
+
+instance (TimeDomain td) => Clock m (Clocks m td cls) where
+  type Time (Clocks m td cls) = td
+  type Tag (Clocks m td cls) = Tags cls
+
+clocksTimeInfoToTick :: TimeInfo (Clocks m td cls) -> Tick cls
+clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = Here TheTag {getTheTag}}, ..} = Tick $ Here TimeInfo {tag = getTheTag, ..}
+clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = There tag}, ..} = Tick $ There $ getTick $ clocksTimeInfoToTick TimeInfo {tag = Tags {getTags = tag}, ..}
+
 newtype TheTag cl = TheTag {getTheTag :: Tag cl}
 
 newtype Tags cls = Tags {getTags :: HSum TheTag cls}