Simplify initClock

rhine-bayes/app/Main.hs

@@ -364,9 +364,9 @@ glossClockUTC :: (Real (Time cl)) => cl -> GlossClockUTC cl
 glossClockUTC cl =
   RescaledClockS
     { unscaledClockS = cl
-    , rescaleS = const $ do
-        now <- liftIO getCurrentTime
-        return (arr $ \(timePassed, event) -> (addUTCTime (realToFrac timePassed) now, event), now)
+    , rescaleS = proc (timePassed, event) -> do
+        initTime <- onStart_ $ liftIO getCurrentTime -< ()
+        returnA -< (addUTCTime (realToFrac timePassed) initTime, event)
     }
 
 {- | The part of the program which simulates latent position and sensor,

rhine-gloss/src/FRP/Rhine/Gloss/IO.hs

@@ -99,7 +99,7 @@ data GlossEventClockIO = GlossEventClockIO
 instance (MonadIO m) => Clock (GlossConcT m) GlossEventClockIO where
   type Time GlossEventClockIO = Float
   type Tag GlossEventClockIO = Event
-  initClock _ = return (constM getEvent, 0)
+  initClock _ = constM getEvent
     where
       getEvent = do
         GlossEnv {eventVar, timeRef} <- GlossConcT ask
@@ -116,7 +116,7 @@ data GlossSimClockIO = GlossSimClockIO
 instance (MonadIO m) => Clock (GlossConcT m) GlossSimClockIO where
   type Time GlossSimClockIO = Float
   type Tag GlossSimClockIO = ()
-  initClock _ = return (constM getTime &&& arr (const ()), 0)
+  initClock _ = constM getTime &&& arr (const ())
     where
       getTime = do
         GlossEnv {timeVar} <- GlossConcT ask

rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs

@@ -35,7 +35,6 @@ import Control.Monad.Schedule.Class
 import Control.Monad.Schedule.Yield
 
 -- automaton
-import Data.Automaton.Trans.Except (performOnFirstSample)
 import qualified Data.Automaton.Trans.Reader as AutomatonReader
 import qualified Data.Automaton.Trans.Writer as AutomatonWriter
 import Data.Stream.Result (Result (..))
@@ -83,7 +82,7 @@ instance Semigroup GlossClock where
 instance Clock GlossM GlossClock where
   type Time GlossClock = Float
   type Tag GlossClock = Maybe Event
-  initClock _ = return (constM (GlossM $ yield >> lift ask) >>> (sumS *** Category.id), 0)
+  initClock _ = constM (GlossM $ yield >> lift ask) >>> (sumS *** Category.id)
 
 instance GetClockProxy GlossClock
 
@@ -126,7 +125,7 @@ flowGloss GlossSettings {..} rhine =
   play display backgroundColor stepsPerSecond (worldAutomaton, Blank) getPic handleEvent simStep
   where
     worldAutomaton :: WorldAutomaton
-    worldAutomaton = AutomatonWriter.runWriterS $ AutomatonReader.runReaderS $ hoistS (runYieldT . unGlossM) $ performOnFirstSample $ eraseClock rhine
+    worldAutomaton = AutomatonWriter.runWriterS $ AutomatonReader.runReaderS $ hoistS (runYieldT . unGlossM) $ eraseClock rhine
     stepWith :: (Float, Maybe Event) -> (WorldAutomaton, Picture) -> (WorldAutomaton, Picture)
     stepWith (diff, eventMaybe) (automaton, _) = let Result automaton' (picture, _) = runIdentity $ stepAutomaton automaton ((diff, eventMaybe), ()) in (automaton', picture)
     getPic (_, pic) = pic

rhine-terminal/src/FRP/Rhine/Terminal.hs

@@ -44,15 +44,10 @@ instance (MonadInput m, MonadIO m) => Clock m TerminalEventClock where
   type Time TerminalEventClock = UTCTime
   type Tag TerminalEventClock = Either Interrupt Event
 
-  initClock TerminalEventClock = do
-    initialTime <- liftIO getCurrentTime
-    return
-      ( constM $ do
-          event <- awaitEvent
-          time <- liftIO getCurrentTime
-          return (time, event)
-      , initialTime
-      )
+  initClock TerminalEventClock = constM $ do
+    event <- awaitEvent
+    time <- liftIO getCurrentTime
+    return (time, event)
 
 instance GetClockProxy TerminalEventClock
 

rhine/src/FRP/Rhine/Clock.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 
 {- |
@@ -44,13 +43,6 @@ that cause the environment to wait until the specified time is reached.
 -}
 type RunningClock m time tag = Automaton m () (time, tag)
 
-{- |
-When initialising a clock, the initial time is measured
-(typically by means of a side effect),
-and a running clock is returned.
--}
-type RunningClockInit m time tag = m (RunningClock m time tag, time)
-
 {- |
 Since we want to leverage Haskell's type system to annotate signal networks by their clocks,
 each clock must be an own type, 'cl'.
@@ -73,7 +65,7 @@ class (TimeDomain (Time cl)) => Clock m cl where
     -- | The clock value, containing e.g. settings or device parameters
     cl ->
     -- | The stream of time stamps, and the initial time
-    RunningClockInit m (Time cl) (Tag cl)
+    RunningClock m (Time cl) (Tag cl)
 
 -- * Auxiliary definitions and utilities
 
@@ -116,21 +108,15 @@ type RescalingM m cl time = Time cl -> m time
 -}
 type RescalingS m cl time tag = Automaton m (Time cl, Tag cl) (time, tag)
 
-{- | Like 'RescalingS', but allows for an initialisation
-   of the rescaling morphism, together with the initial time.
--}
-type RescalingSInit m cl time tag = Time cl -> m (RescalingS m cl time tag, time)
-
-{- | Convert an effectful morphism of time domains into a stateful one with initialisation.
-   Think of its type as @RescalingM m cl time -> RescalingSInit m cl time tag@,
+{- | Convert an effectful morphism of time domains into a stateful one.
+   Think of its type as @'RescalingM' m cl time -> 'RescalingS' m cl time tag@,
    although this type is ambiguous.
 -}
-rescaleMToSInit ::
+rescaleMToS ::
   (Monad m) =>
   (time1 -> m time2) ->
-  time1 ->
-  m (Automaton m (time1, tag) (time2, tag), time2)
-rescaleMToSInit rescaling time1 = (arrM rescaling *** Category.id,) <$> rescaling time1
+  Automaton m (time1, tag) (time2, tag)
+rescaleMToS rescaling = arrM rescaling *** Category.id
 
 -- ** Applying rescalings to clocks
 
@@ -146,12 +132,7 @@ instance
   where
   type Time (RescaledClock cl time) = time
   type Tag (RescaledClock cl time) = Tag cl
-  initClock (RescaledClock cl f) = do
-    (runningClock, initTime) <- initClock cl
-    return
-      ( runningClock >>> first (arr f)
-      , f initTime
-      )
+  initClock (RescaledClock cl f) = initClock cl >>> first (arr f)
 
 {- | Instead of a mere function as morphism of time domains,
    we can transform one time domain into the other with an effectful morphism.
@@ -169,13 +150,7 @@ instance
   where
   type Time (RescaledClockM m cl time) = time
   type Tag (RescaledClockM m cl time) = Tag cl
-  initClock RescaledClockM {..} = do
-    (runningClock, initTime) <- initClock unscaledClockM
-    rescaledInitTime <- rescaleM initTime
-    return
-      ( runningClock >>> first (arrM rescaleM)
-      , rescaledInitTime
-      )
+  initClock RescaledClockM {..} = initClock unscaledClockM >>> first (arrM rescaleM)
 
 -- | A 'RescaledClock' is trivially a 'RescaledClockM'.
 rescaledClockToM :: (Monad m) => RescaledClock cl time -> RescaledClockM m cl time
@@ -191,7 +166,7 @@ rescaledClockToM RescaledClock {..} =
 data RescaledClockS m cl time tag = RescaledClockS
   { unscaledClockS :: cl
   -- ^ The clock before the rescaling
-  , rescaleS :: RescalingSInit m cl time tag
+  , rescaleS :: RescalingS m cl time tag
   -- ^ The rescaling stream function, and rescaled initial time,
   --   depending on the initial time before rescaling
   }
@@ -202,13 +177,7 @@ instance
   where
   type Time (RescaledClockS m cl time tag) = time
   type Tag (RescaledClockS m cl time tag) = tag
-  initClock RescaledClockS {..} = do
-    (runningClock, initTime) <- initClock unscaledClockS
-    (rescaling, rescaledInitTime) <- rescaleS initTime
-    return
-      ( runningClock >>> rescaling
-      , rescaledInitTime
-      )
+  initClock RescaledClockS {..} = initClock unscaledClockS >>> rescaleS
 
 -- | A 'RescaledClockM' is trivially a 'RescaledClockS'.
 rescaledClockMToS ::
@@ -218,7 +187,7 @@ rescaledClockMToS ::
 rescaledClockMToS RescaledClockM {..} =
   RescaledClockS
     { unscaledClockS = unscaledClockM
-    , rescaleS = rescaleMToSInit rescaleM
+    , rescaleS = rescaleMToS rescaleM
     }
 
 -- | A 'RescaledClock' is trivially a 'RescaledClockS'.
@@ -240,12 +209,7 @@ instance
   where
   type Time (HoistClock m1 m2 cl) = Time cl
   type Tag (HoistClock m1 m2 cl) = Tag cl
-  initClock HoistClock {..} = do
-    (runningClock, initialTime) <- monadMorphism $ initClock unhoistedClock
-    return
-      ( hoistS monadMorphism runningClock
-      , initialTime
-      )
+  initClock HoistClock {..} = hoistS monadMorphism $ initClock unhoistedClock
 
 -- | Lift a clock type into a monad transformer.
 type LiftClock m t cl = HoistClock m (t m) cl

rhine/src/FRP/Rhine/Clock/Except.hs

@@ -5,7 +5,6 @@ import Control.Arrow
 import Control.Exception
 import Control.Exception qualified as Exception
 import Control.Monad ((<=<))
-import Data.Functor ((<&>))
 import Data.Void
 
 -- time
@@ -48,11 +47,7 @@ instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio
   type Time (ExceptClock cl e) = Time cl
   type Tag (ExceptClock cl e) = Tag cl
 
-  initClock ExceptClock {getExceptClock} = do
-    ioerror $
-      Exception.try $
-        initClock getExceptClock
-          <&> first (hoistS (ioerror . Exception.try))
+  initClock ExceptClock {getExceptClock} = hoistS (ioerror . Exception.try) $ initClock getExceptClock
     where
       ioerror :: (MonadError e eio, MonadIO eio) => IO (Either e a) -> eio a
       ioerror = liftEither <=< liftIO
@@ -74,17 +69,10 @@ data CatchClock cl1 e cl2 = CatchClock cl1 (e -> cl2)
 instance (Time cl1 ~ Time cl2, Clock (ExceptT e m) cl1, Clock m cl2, Monad m) => Clock m (CatchClock cl1 e cl2) where
   type Time (CatchClock cl1 e cl2) = Time cl1
   type Tag (CatchClock cl1 e cl2) = Either (Tag cl2) (Tag cl1)
-  initClock (CatchClock cl1 handler) = do
-    tryToInit <- runExceptT $ first (>>> arr (second Right)) <$> initClock cl1
-    case tryToInit of
-      Right (runningClock, initTime) -> do
-        let catchingClock = safely $ do
-              e <- AutomatonExcept.try runningClock
-              let cl2 = handler e
-              (runningClock', _) <- once_ $ initClock cl2
-              safe $ runningClock' >>> arr (second Left)
-        return (catchingClock, initTime)
-      Left e -> (fmap (first (>>> arr (second Left))) . initClock) $ handler e
+  initClock (CatchClock cl1 handler) = safely $ do
+    e <- AutomatonExcept.try $ initClock cl1 >>> arr (second Right)
+    let cl2 = handler e
+    safe $ initClock cl2 >>> arr (second Left)
 
 instance (GetClockProxy (CatchClock cl1 e cl2))
 
@@ -132,14 +120,13 @@ data Single m time tag e = Single
 instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) where
   type Time (Single m time tag e) = time
   type Tag (Single m time tag e) = tag
-  initClock Single {singleTag, getTime, exception} = do
-    initTime <- getTime
-    let runningClock = hoistS (errorT . runExceptT) $ runAutomatonExcept $ do
-          step_ (initTime, singleTag)
-          return exception
-        errorT :: (MonadError e m) => m (Either e a) -> m a
-        errorT = (>>= liftEither)
-    return (runningClock, initTime)
+  initClock Single {singleTag, getTime, exception} = hoistS (errorT . runExceptT) $ runAutomatonExcept $ do
+    initTime <- once_ getTime
+    step_ (initTime, singleTag)
+    return exception
+    where
+      errorT :: (MonadError e m) => m (Either e a) -> m a
+      errorT = (>>= liftEither)
 
 -- * 'DelayException'
 

rhine/src/FRP/Rhine/Clock/FixedStep.hs

@@ -51,12 +51,9 @@ instance (MonadSchedule m, Monad m) => Clock (ScheduleT Integer m) (FixedStep n)
   type Tag (FixedStep n) = ()
   initClock cl =
     let step = stepsize cl
-     in return
-          ( arr (const step)
-              >>> accumulateWith (+) 0
-              >>> arrM (\time -> wait step $> (time, ()))
-          , 0
-          )
+     in arr (const step)
+          >>> accumulateWith (+) 0
+          >>> arrM (\time -> wait step $> (time, ()))
 
 instance GetClockProxy (FixedStep n)
 

rhine/src/FRP/Rhine/Clock/Periodic.hs

@@ -47,11 +47,7 @@ instance
   where
   type Time (Periodic v) = Integer
   type Tag (Periodic v) = ()
-  initClock cl =
-    return
-      ( cycleS (theList cl) >>> withSideEffect wait >>> accumulateWith (+) 0 &&& arr (const ())
-      , 0
-      )
+  initClock cl = cycleS (theList cl) >>> withSideEffect wait >>> accumulateWith (+) 0 &&& arr (const ())
 
 instance GetClockProxy (Periodic v)
 

rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs

@@ -99,15 +99,15 @@ instance
   type Time (AudioClock rate bufferSize) = UTCTime
   type Tag (AudioClock rate bufferSize) = Maybe Double
 
-  initClock audioClock = do
+  initClock audioClock =
     let
       step =
         picosecondsToDiffTime $
           round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double) -- The only sufficiently precise conversion function
       bufferSize = theBufferSize audioClock
 
-      runningClock :: (MonadIO m) => UTCTime -> Maybe Double -> Automaton m () (UTCTime, Maybe Double)
-      runningClock initialTime maybeWasLate = safely $ do
+      runningClock :: (MonadIO m) => UTCTime -> Maybe Double -> AutomatonExcept () (UTCTime, Maybe Double) m void
+      runningClock initialTime maybeWasLate = do
         bufferFullTime <- try $ proc () -> do
           n <- count -< ()
           let nextTime = (realToFrac step * fromIntegral (n :: Int)) `addUTCTime` initialTime
@@ -117,12 +117,12 @@ instance
         let
           lateDiff = currentTime `diffTime` bufferFullTime
           late = if lateDiff > 0 then Just lateDiff else Nothing
-        safe $ runningClock bufferFullTime late
-    initialTime <- liftIO getCurrentTime
-    return
-      ( runningClock initialTime Nothing
-      , initialTime
-      )
+        runningClock bufferFullTime late
+     in
+      safely $ do
+        -- FIXME this is of course a bit inefficient because now we have the full monad in AutomatonExcept. We'd really need something like eolc's >>>= here
+        initialTime <- once_ $ liftIO getCurrentTime
+        runningClock initialTime Nothing
 
 instance GetClockProxy (AudioClock rate bufferSize)
 
@@ -147,11 +147,7 @@ instance (Monad m, PureAudioClockRate rate) => Clock m (PureAudioClock rate) whe
   type Time (PureAudioClock rate) = Double
   type Tag (PureAudioClock rate) = ()
 
-  initClock audioClock =
-    return
-      ( arr (const (1 / thePureRateNum audioClock)) >>> sumS &&& arr (const ())
-      , 0
-      )
+  initClock audioClock = arr (const (1 / thePureRateNum audioClock)) >>> sumS &&& arr (const ())
 
 instance GetClockProxy (PureAudioClock rate)
 

rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs

@@ -29,12 +29,7 @@ instance (MonadIO m) => Clock m Busy where
   type Time Busy = UTCTime
   type Tag Busy = ()
 
-  initClock _ = do
-    initialTime <- liftIO getCurrentTime
-    return
-      ( constM (liftIO getCurrentTime)
+  initClock _ = constM (liftIO getCurrentTime)
           &&& arr (const ())
-      , initialTime
-      )
 
 instance GetClockProxy Busy

rhine/src/FRP/Rhine/Clock/Realtime/Event.hs

@@ -150,16 +150,11 @@ instance Semigroup (EventClock event) where
 instance (MonadIO m) => Clock (EventChanT event m) (EventClock event) where
   type Time (EventClock event) = UTCTime
   type Tag (EventClock event) = event
-  initClock _ = do
-    initialTime <- liftIO getCurrentTime
-    return
-      ( constM $ do
+  initClock _ = constM $ do
           chan <- ask
           event <- liftIO $ readChan chan
           time <- liftIO getCurrentTime
           return (time, event)
-      , initialTime
-      )
 
 instance GetClockProxy (EventClock event)