diff --git a/rhine/src/FRP/Rhine/SN/Free.hs b/rhine/src/FRP/Rhine/SN/Free.hs index ab058584..c07bd9ba 100644 --- 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}