From 5737c2222b595531f0e1cca970232023faef2968 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Thu, 8 Feb 2024 16:48:17 +0100
Subject: [PATCH 1/2] Add Except, Catch, and Single clocks, and many utilities

---
 rhine/rhine.cabal                   |  10 ++
 rhine/src/FRP/Rhine/Clock/Except.hs | 199 ++++++++++++++++++++++++++++
 rhine/test/Clock.hs                 |   4 +-
 rhine/test/Clock/Except.hs          | 138 +++++++++++++++++++
 rhine/test/assets/testdata.txt      |   2 +
 5 files changed, 352 insertions(+), 1 deletion(-)
 create mode 100644 rhine/src/FRP/Rhine/Clock/Except.hs
 create mode 100644 rhine/test/Clock/Except.hs
 create mode 100644 rhine/test/assets/testdata.txt

diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal
index 438b609a..1368e489 100644
--- a/rhine/rhine.cabal
+++ b/rhine/rhine.cabal
@@ -26,6 +26,7 @@ category: FRP
 build-type: Simple
 extra-source-files: ChangeLog.md
 extra-doc-files: README.md
+data-files: test/assets/*.txt
 tested-with:
   ghc ==9.0.2
   ghc ==9.2.8
@@ -43,6 +44,8 @@ source-repository this
 common opts
   build-depends:
     base >=4.14 && <4.18,
+    text >=1.2 && <2.1,
+    transformers >=0.5,
     vector-sized >=1.4,
 
   if flag(dev)
@@ -53,6 +56,7 @@ common opts
     -Wno-unticked-promoted-constructors
 
   default-extensions:
+    Arrows
     DataKinds
     FlexibleContexts
     FlexibleInstances
@@ -79,6 +83,7 @@ library
     FRP.Rhine.ClSF.Upsample
     FRP.Rhine.ClSF.Util
     FRP.Rhine.Clock
+    FRP.Rhine.Clock.Except
     FRP.Rhine.Clock.FixedStep
     FRP.Rhine.Clock.Periodic
     FRP.Rhine.Clock.Proxy
@@ -121,6 +126,7 @@ library
     dunai ^>=0.12.2,
     free >=5.1,
     monad-schedule ^>=0.1.2,
+    mtl >=2.2 && <2.4,
     random >=1.1,
     simple-affine-space ^>=0.2,
     text >=1.2 && <2.1,
@@ -138,13 +144,17 @@ test-suite test
   main-is: Main.hs
   other-modules:
     Clock
+    Clock.Except
     Clock.FixedStep
     Clock.Millisecond
+    Paths_rhine
     Schedule
     Util
 
+  autogen-modules: Paths_rhine
   build-depends:
     monad-schedule,
+    mtl,
     rhine,
     tasty ^>=1.4,
     tasty-hunit ^>=0.10,
diff --git a/rhine/src/FRP/Rhine/Clock/Except.hs b/rhine/src/FRP/Rhine/Clock/Except.hs
new file mode 100644
index 00000000..1d85dbb7
--- /dev/null
+++ b/rhine/src/FRP/Rhine/Clock/Except.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module FRP.Rhine.Clock.Except where
+
+-- base
+import Control.Arrow
+import Control.Exception
+import Control.Exception qualified as Exception
+import Control.Monad ((<=<))
+import Data.Functor ((<&>))
+import Data.Void
+
+-- transformers
+import Control.Monad.Trans.MSF.Except
+
+-- time
+import Data.Time (UTCTime, getCurrentTime)
+
+-- mtl
+import Control.Monad.Error.Class
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.MSF qualified as MSFExcept
+
+-- dunai
+import Data.MonadicStreamFunction (morphS)
+
+-- rhine
+
+import Control.Monad.Trans.MSF.Reader (readerS, runReaderS)
+import FRP.Rhine.ClSF.Core (ClSF)
+import FRP.Rhine.Clock (
+  Clock (..),
+  HoistClock (..),
+  TimeDomain,
+  TimeInfo (..),
+  retag,
+ )
+import FRP.Rhine.Clock.Proxy (GetClockProxy)
+
+{- | Handle 'IO' exceptions purely in 'ExceptT'.
+
+The clock @cl@ may throw 'Exception's of type @e@ while running.
+These exceptions are automatically caught, and raised as an error in 'ExceptT'
+(or more generally in 'MonadError', which implies the presence of 'ExceptT' in the monad transformer stack)
+
+It can then be caught and handled with 'CatchClock'.
+-}
+newtype ExceptClock cl e = ExceptClock {getExceptClock :: cl}
+
+instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio (ExceptClock cl e) where
+  type Time (ExceptClock cl e) = Time cl
+  type Tag (ExceptClock cl e) = Tag cl
+
+  initClock ExceptClock {getExceptClock} = do
+    ioerror $
+      Exception.try $
+        initClock getExceptClock
+          <&> first (morphS (ioerror . Exception.try))
+    where
+      ioerror :: (MonadError e eio, MonadIO eio) => IO (Either e a) -> eio a
+      ioerror = liftEither <=< liftIO
+
+instance GetClockProxy (ExceptClock cl e)
+
+{- | Catch an exception in one clock and proceed with another.
+
+When @cl@ throws an exception @e@ (in @'ExceptT' e@) while running,
+this exception is caught, and a clock @cl'@ is started from the exception value.
+
+For this to be possible, @cl@ must run in the monad @'ExceptT' e m@, while @cl'@ must run in @m@.
+To give @cl'@ the ability to throw another exception, you need to add a further 'ExceptT' layer to the stack in @m@.
+-}
+data CatchClock cl e cl' = CatchClock cl (e -> cl')
+
+instance (Time cl ~ Time cl', Clock (ExceptT e m) cl, Clock m cl', Monad m) => Clock m (CatchClock cl e cl') where
+  type Time (CatchClock cl e cl') = Time cl
+  type Tag (CatchClock cl e cl') = Either (Tag cl') (Tag cl)
+  initClock (CatchClock cl handler) = do
+    tryToInit <- runExceptT $ first (>>> arr (second Right)) <$> initClock cl
+    -- FIXME Each of these branches needs a unit test
+    case tryToInit of
+      Right (runningClock, initTime) -> do
+        let catchingClock = safely $ do
+              e <- MSFExcept.try runningClock
+              let cl' = handler e
+              (runningClock', _) <- once_ $ initClock cl'
+              safe $ runningClock' >>> arr (second Left)
+        return (catchingClock, initTime)
+      Left e -> (fmap (first (>>> arr (second Left))) . initClock) $ handler e
+
+instance (GetClockProxy (CatchClock cl e cl'))
+
+-- FIXME cl1 cl2 convention everywhere?
+catchClSF :: (Time cl1 ~ Time cl2, Monad m) => ClSF m cl1 a b -> ClSF m cl2 a b -> ClSF m (CatchClock cl1 e cl2) a b
+catchClSF clsf1 clsf2 = readerS $ proc (timeInfo, a) -> do
+  case tag timeInfo of
+    Right tag1 -> runReaderS clsf1 -< (retag (const tag1) timeInfo, a)
+    Left tag2 -> runReaderS clsf2 -< (retag (const tag2) timeInfo, a)
+
+-- | A clock that throws no exceptions.
+type SafeClock m = HoistClock (ExceptT Void m) m
+
+-- | Hoist the monad of a clock into 'ExceptT', without throwing an exception.
+safeClock :: (Functor m) => cl -> SafeClock m cl
+safeClock unhoistedClock =
+  HoistClock
+    { unhoistedClock
+    , monadMorphism = fmap (either absurd id) . runExceptT
+    }
+
+{- | A clock that emits a single tick, and then throws an exception.
+
+The tag, time measurement and exception have to be supplied as clock value.
+-}
+data Single m time tag e = Single
+  { singleTag :: tag
+  -- ^ The tag that will be emitted on the tick.
+  , getTime :: m time
+  -- ^ A method to measure the current time.
+  , exception :: e
+  -- ^ The exception to throw after the single tick.
+  }
+
+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 = morphS (errorT . runExceptT) $ runMSFExcept $ do
+          step_ (initTime, singleTag)
+          return exception
+        errorT :: (MonadError e m) => m (Either e a) -> m a
+        errorT = (>>= liftEither)
+    return (runningClock, initTime)
+
+{- | Catch an exception in clock @cl@ and throw it after one time step.
+
+This is particularly useful if you want to give your signal network a chance to save its current state in some way.
+-}
+type DelayException m time cl e e' = CatchClock cl e (Single m time e e')
+
+-- | Construct a 'DelayException' clock.
+delayException ::
+  (Monad m, Clock (ExceptT e m) cl, MonadError e' m) =>
+  -- | The clock that will throw an exception @e@
+  cl ->
+  -- | How to transform the exception into the new exception that will be thrown later
+  (e -> e') ->
+  -- | How to measure the current time
+  m (Time cl) ->
+  DelayException m (Time cl) cl e e'
+delayException cl handler mTime = CatchClock cl $ \e -> Single e mTime $ handler e
+
+-- | Like 'delayException', but the exception thrown by @cl@ and by the @DelayException@ clock are the same.
+delayException' :: (Monad m, MonadError e m, Clock (ExceptT e m) cl) => cl -> m (Time cl) -> DelayException m (Time cl) cl e e
+delayException' cl = delayException cl id
+
+-- | Catch an 'IO' 'Exception', and throw it after one time step.
+type DelayMonadIOException m cl e e' = DelayException m UTCTime (ExceptClock cl e) e e'
+
+-- | Build a 'DelayMonadIOException'. The time will be measured using the system time.
+delayMonadIOException :: (Exception e, MonadIO m, MonadError e' m, Clock IO cl, Time cl ~ UTCTime) => cl -> (e -> e') -> DelayMonadIOException m cl e e'
+delayMonadIOException cl handler = delayException (ExceptClock cl) handler $ liftIO getCurrentTime
+
+-- | 'DelayMonadIOException' specialised to 'IOError'.
+type DelayMonadIOError m cl e = DelayMonadIOException m cl IOError e
+
+-- | 'delayMonadIOException' specialised to 'IOError'.
+delayMonadIOError :: (Exception e, MonadError e m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> (IOError -> e) -> DelayMonadIOError m cl e
+delayMonadIOError = delayMonadIOException
+
+-- | Like 'delayMonadIOError', but throw the error without transforming it.
+delayMonadIOError' :: (MonadError IOError m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayMonadIOError m cl IOError
+delayMonadIOError' cl = delayMonadIOError cl id
+
+{- | 'DelayMonadIOException' specialised to the monad @'ExceptT' e' 'IO'@.
+
+This is sometimes helpful when the type checker complains about an ambigous monad type variable.
+-}
+type DelayIOException cl e e' = DelayException (ExceptT e' IO) UTCTime (ExceptClock cl e) e e'
+
+-- | 'delayMonadIOException' specialised to the monad @'ExceptT' e' 'IO'@.
+delayIOException :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> (e -> e') -> DelayIOException cl e e'
+delayIOException = delayMonadIOException
+
+-- | 'delayIOException'', but throw the error without transforming it.
+delayIOException' :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayIOException cl e e
+delayIOException' cl = delayIOException cl id
+
+-- | 'DelayIOException' specialised to 'IOError'.
+type DelayIOError cl e = DelayIOException cl IOError e
+
+-- | 'delayIOException' specialised to 'IOError'.
+delayIOError :: (Time cl ~ UTCTime, Clock IO cl) => cl -> (IOError -> e) -> DelayIOError cl e
+delayIOError = delayIOException
+
+-- | 'delayIOError', but throw the error without transforming it.
+delayIOError' :: (Time cl ~ UTCTime, Clock IO cl) => cl -> DelayIOError cl IOError
+delayIOError' cl = delayIOException cl id
diff --git a/rhine/test/Clock.hs b/rhine/test/Clock.hs
index df0e4f80..8a75fac4 100644
--- a/rhine/test/Clock.hs
+++ b/rhine/test/Clock.hs
@@ -4,12 +4,14 @@ module Clock where
 import Test.Tasty
 
 -- rhine
+import Clock.Except
 import Clock.FixedStep
 import Clock.Millisecond
 
 tests =
   testGroup
     "Clock"
-    [ Clock.FixedStep.tests
+    [ Clock.Except.tests
+    , Clock.FixedStep.tests
     , Clock.Millisecond.tests
     ]
diff --git a/rhine/test/Clock/Except.hs b/rhine/test/Clock/Except.hs
new file mode 100644
index 00000000..6b0bd696
--- /dev/null
+++ b/rhine/test/Clock/Except.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Clock.Except where
+
+-- base
+import Data.Either (isRight)
+import GHC.IO.Handle (hDuplicateTo)
+import System.IO (IOMode (ReadMode), stdin, withFile)
+import System.IO.Error (isEOFError)
+
+-- mtl
+import Control.Monad.Writer.Class
+
+-- transformers
+-- Replace Strict by CPS when bumping mtl to 2.3
+import Control.Monad.Trans.Writer.Strict hiding (tell)
+
+-- text
+import Data.Text (Text)
+
+-- tasty
+import Test.Tasty (TestTree, testGroup)
+
+-- tasty-hunit
+import Test.Tasty.HUnit (testCase, (@?), (@?=))
+
+-- rhine
+import FRP.Rhine
+import FRP.Rhine.Clock.Except (
+  CatchClock (CatchClock),
+  DelayIOError,
+  DelayMonadIOError,
+  ExceptClock (ExceptClock),
+  catchClSF,
+  delayIOError,
+  delayMonadIOError',
+ )
+import Paths_rhine
+
+tests :: TestTree
+tests =
+  testGroup
+    "ExceptClock"
+    [catchClockTests, delayedClockTests, innerWriterTests]
+
+-- ** 'CatchClock'
+
+type WT = WriterT [Text]
+type E = ExceptT IOError IO
+type M = WT E
+type EClock = ExceptClock StdinClock IOError
+
+type TestClock =
+  LiftClock
+    E
+    WT
+    ( CatchClock
+        EClock
+        IOError
+        StdinClock
+    )
+
+-- FIXME also need to test the other branch of CatchClock
+testClock :: TestClock
+testClock = liftClock $ CatchClock (ExceptClock StdinClock) $ const StdinClock
+
+catchClockTests :: TestTree
+catchClockTests =
+  testGroup
+    "CatchClock"
+    [ testCase "Outputs the exception on EOF" $ withTestStdin $ do
+        let
+          tellStdin :: ClSF M TestClock () ()
+          tellStdin = proc () -> do
+            tag <- tagS -< ()
+            arrMCl tell -< either (const []) pure tag
+
+        Left result <- runExceptT $ runWriterT $ flow $ tellStdin @@ testClock
+        isEOFError result @? "It's an EOF error"
+    ]
+
+-- ** 'DelayException'
+
+type DelayedClock = DelayIOError StdinClock (Maybe [Text])
+
+delayedClock :: DelayedClock
+delayedClock = delayIOError StdinClock $ const Nothing
+
+delayedClockTests :: TestTree
+delayedClockTests =
+  testGroup
+    "DelayedClock"
+    [ testCase "DelayException delays error by 1 step" $ withTestStdin $ do
+        let
+          -- FIXME it would be cool if there were a utility that combines two clsfs under the two parts of the catchclock
+          throwCollectedText :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()
+          throwCollectedText = proc () -> do
+            tag <- tagS -< ()
+            textSoFar <- mappendS -< either (const []) pure tag
+            throwOn' -< (isRight tag, Just textSoFar)
+        result <- runExceptT $ flow $ throwCollectedText @@ delayedClock
+        result @?= Left (Just ["data", "test"])
+    , testCase "DelayException throws error after 1 step" $ withTestStdin $ do
+        let
+          dontThrow :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()
+          dontThrow = clId
+        result <- runExceptT $ flow $ dontThrow @@ delayedClock
+        result @?= Left Nothing
+    ]
+
+{- | 'WriterT' is now the inner monad, meaning that the log survives exceptions.
+This way, the state is not lost.
+-}
+type ClWriterExcept = DelayMonadIOError (ExceptT IOError (WriterT [Text] IO)) StdinClock IOError
+
+clWriterExcept :: ClWriterExcept
+clWriterExcept = delayMonadIOError' StdinClock
+
+innerWriterTests :: TestTree
+innerWriterTests = testCase "DelayException throws error after 1 step, but can write down results" $ withTestStdin $ do
+  let
+    tellStdin :: (MonadWriter [Text] m) => ClSF m ClWriterExcept () ()
+    tellStdin = catchClSF (tagS >>> arrMCl (tell . pure)) clId
+
+  (Left e, result) <- runWriterT $ runExceptT $ flow $ tellStdin @@ clWriterExcept
+  isEOFError e @? "is EOF"
+  result @?= ["test", "data"]
+
+-- * Test helpers
+
+-- | Emulate test standard input
+withTestStdin :: IO a -> IO a
+withTestStdin action = do
+  testdataFile <- getDataFileName "test/assets/testdata.txt"
+  withFile testdataFile ReadMode $ \h -> do
+    hDuplicateTo h stdin
+    action
diff --git a/rhine/test/assets/testdata.txt b/rhine/test/assets/testdata.txt
new file mode 100644
index 00000000..dfe77698
--- /dev/null
+++ b/rhine/test/assets/testdata.txt
@@ -0,0 +1,2 @@
+test
+data

From 698a01ece20de38adbd6e25a27fc1689585c90cc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Thu, 8 Feb 2024 16:48:17 +0100
Subject: [PATCH 2/2] WIP

---
 rhine/rhine.cabal                   |  23 ++++++
 rhine/src/FRP/Rhine/Clock/Catch.hs  |  72 +++++++++++++++++
 rhine/src/FRP/Rhine/Clock/Except.hs | 109 ++++----------------------
 rhine/test/Clock.hs                 |   9 +++
 rhine/test/Clock/Catch.hs           |  53 +++++++++++++
 rhine/test/Clock/Except.hs          | 117 +++++++++++-----------------
 6 files changed, 216 insertions(+), 167 deletions(-)
 create mode 100644 rhine/src/FRP/Rhine/Clock/Catch.hs
 create mode 100644 rhine/test/Clock/Catch.hs

diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal
index 1368e489..b601130b 100644
--- a/rhine/rhine.cabal
+++ b/rhine/rhine.cabal
@@ -26,7 +26,12 @@ category: FRP
 build-type: Simple
 extra-source-files: ChangeLog.md
 extra-doc-files: README.md
+<<<<<<< HEAD
 data-files: test/assets/*.txt
+=======
+
+data-files:          test/assets/*.txt
+>>>>>>> f7d003c (WIP)
 tested-with:
   ghc ==9.0.2
   ghc ==9.2.8
@@ -47,6 +52,8 @@ common opts
     text >=1.2 && <2.1,
     transformers >=0.5,
     vector-sized >=1.4,
+    transformers >= 0.5,
+    text         >= 1.2 && < 2.1,
 
   if flag(dev)
     ghc-options: -Werror
@@ -83,6 +90,10 @@ library
     FRP.Rhine.ClSF.Upsample
     FRP.Rhine.ClSF.Util
     FRP.Rhine.Clock
+<<<<<<< HEAD
+=======
+    FRP.Rhine.Clock.Catch
+>>>>>>> f7d003c (WIP)
     FRP.Rhine.Clock.Except
     FRP.Rhine.Clock.FixedStep
     FRP.Rhine.Clock.Periodic
@@ -133,6 +144,7 @@ library
     time >=1.8,
     time-domain ^>=0.1.0.2,
     transformers >=0.5,
+    mtl          >= 2.2 && < 2.4,
 
   -- Directories containing source files.
   hs-source-dirs: src
@@ -144,6 +156,10 @@ test-suite test
   main-is: Main.hs
   other-modules:
     Clock
+<<<<<<< HEAD
+=======
+    Clock.Catch
+>>>>>>> f7d003c (WIP)
     Clock.Except
     Clock.FixedStep
     Clock.Millisecond
@@ -151,13 +167,20 @@ test-suite test
     Schedule
     Util
 
+<<<<<<< HEAD
   autogen-modules: Paths_rhine
+=======
+    Paths_rhine
+  autogen-modules:
+    Paths_rhine
+>>>>>>> f7d003c (WIP)
   build-depends:
     monad-schedule,
     mtl,
     rhine,
     tasty ^>=1.4,
     tasty-hunit ^>=0.10,
+    mtl,
 
 flag dev
   description: Enable warnings as errors. Active on ci.
diff --git a/rhine/src/FRP/Rhine/Clock/Catch.hs b/rhine/src/FRP/Rhine/Clock/Catch.hs
new file mode 100644
index 00000000..1ac602a2
--- /dev/null
+++ b/rhine/src/FRP/Rhine/Clock/Catch.hs
@@ -0,0 +1,72 @@
+-- | If a clock in 'IO' throws an 'IOException', you can wrap it in 'Catch' to stop on it.
+module FRP.Rhine.Clock.Catch where
+
+-- base
+import Control.Exception (Exception, catchJust, throw, tryJust)
+import Control.Monad.IO.Class
+
+-- time
+import Data.Time (getCurrentTime)
+
+-- rhine
+import Control.Monad.Trans.MSF (safely)
+import Control.Monad.Trans.MSF.Except (
+  ExceptT (ExceptT),
+  once,
+  safe,
+  step_,
+  try,
+ )
+import FRP.Rhine (GetClockProxy)
+import FRP.Rhine.Clock
+
+data Catch cl e cl' = Catch
+  { throwing :: cl
+  , handler :: e -> Maybe cl'
+  }
+
+type CatchIOError cl cl' = Catch cl IOError cl'
+
+instance (Time cl ~ Time cl', Clock IO cl, Clock IO cl', Exception e) => Clock IO (Catch cl e cl') where
+  type Time (Catch cl e cl') = Time cl
+  type Tag (Catch cl e cl') = Either (Tag cl') (Tag cl)
+  initClock Catch {throwing, handler} = do
+    (runningClock, initialTime) <-
+      catchJust
+        handler
+        (first (>>> arr (second Right)) <$> initClock throwing)
+        (fmap (first (>>> arr (second Left))) . initClock)
+    let catchingClock = safely $ do
+          cl' <- try $ morphS (ExceptT . tryJust handler) runningClock
+          (runningClock', _initialTime) <- once $ const $ initClock cl'
+          safe $ runningClock' >>> arr (second Left)
+    return (catchingClock, initialTime)
+
+instance GetClockProxy (Catch cl e cl')
+
+-- FIXME naming is inconsistent with MSFExcept, it's more like "Step"
+data Once a e = Once a e
+
+instance (MonadIO io, Exception e) => Clock io (Once a e) where
+  type Time (Once a e) = UTCTime
+  type Tag (Once a e) = a
+  initClock (Once a exception) = do
+    initialTime <- liftIO getCurrentTime
+    let runningClock = safely $ do
+          step_ (initialTime, a)
+          safe $ constM $ liftIO $ throw exception
+    return (runningClock, initialTime)
+
+type CatchOnce cl e = Catch cl e (Once () e)
+
+catchOnce :: cl -> (e -> Bool) -> CatchOnce cl e
+catchOnce cl handler =
+  Catch
+    { throwing = cl
+    , handler = \e -> if handler e then Just (Once () e) else Nothing
+    }
+
+type CatchOnceIOError cl = CatchOnce cl IOError
+
+catchOnceIOError :: cl -> (IOError -> Bool) -> CatchOnceIOError cl
+catchOnceIOError = catchOnce
diff --git a/rhine/src/FRP/Rhine/Clock/Except.hs b/rhine/src/FRP/Rhine/Clock/Except.hs
index 1d85dbb7..667ae318 100644
--- a/rhine/src/FRP/Rhine/Clock/Except.hs
+++ b/rhine/src/FRP/Rhine/Clock/Except.hs
@@ -2,49 +2,20 @@
 
 module FRP.Rhine.Clock.Except where
 
--- base
-import Control.Arrow
 import Control.Exception
 import Control.Exception qualified as Exception
-import Control.Monad ((<=<))
-import Data.Functor ((<&>))
-import Data.Void
-
--- transformers
-import Control.Monad.Trans.MSF.Except
-
--- time
-import Data.Time (UTCTime, getCurrentTime)
-
--- mtl
+import Control.Monad ((<=<), (>=>))
 import Control.Monad.Error.Class
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.MSF qualified as MSFExcept
+import Control.Monad.Trans.MSF.Except
+import Data.Functor ((<&>))
+import Data.Time (getCurrentTime)
+import Data.Void
+import FRP.Rhine (GetClockProxy)
+import FRP.Rhine.Clock
 
--- dunai
-import Data.MonadicStreamFunction (morphS)
-
--- rhine
-
-import Control.Monad.Trans.MSF.Reader (readerS, runReaderS)
-import FRP.Rhine.ClSF.Core (ClSF)
-import FRP.Rhine.Clock (
-  Clock (..),
-  HoistClock (..),
-  TimeDomain,
-  TimeInfo (..),
-  retag,
- )
-import FRP.Rhine.Clock.Proxy (GetClockProxy)
-
-{- | Handle 'IO' exceptions purely in 'ExceptT'.
-
-The clock @cl@ may throw 'Exception's of type @e@ while running.
-These exceptions are automatically caught, and raised as an error in 'ExceptT'
-(or more generally in 'MonadError', which implies the presence of 'ExceptT' in the monad transformer stack)
-
-It can then be caught and handled with 'CatchClock'.
--}
 newtype ExceptClock cl e = ExceptClock {getExceptClock :: cl}
 
 instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio (ExceptClock cl e) where
@@ -62,21 +33,13 @@ instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio
 
 instance GetClockProxy (ExceptClock cl e)
 
-{- | Catch an exception in one clock and proceed with another.
-
-When @cl@ throws an exception @e@ (in @'ExceptT' e@) while running,
-this exception is caught, and a clock @cl'@ is started from the exception value.
-
-For this to be possible, @cl@ must run in the monad @'ExceptT' e m@, while @cl'@ must run in @m@.
-To give @cl'@ the ability to throw another exception, you need to add a further 'ExceptT' layer to the stack in @m@.
--}
 data CatchClock cl e cl' = CatchClock cl (e -> cl')
 
 instance (Time cl ~ Time cl', Clock (ExceptT e m) cl, Clock m cl', Monad m) => Clock m (CatchClock cl e cl') where
   type Time (CatchClock cl e cl') = Time cl
-  type Tag (CatchClock cl e cl') = Either (Tag cl') (Tag cl)
+  type Tag (CatchClock cl e cl') = Either (Tag cl) (Tag cl')
   initClock (CatchClock cl handler) = do
-    tryToInit <- runExceptT $ first (>>> arr (second Right)) <$> initClock cl
+    tryToInit <- runExceptT $ first (>>> arr (second Left)) <$> initClock cl
     -- FIXME Each of these branches needs a unit test
     case tryToInit of
       Right (runningClock, initTime) -> do
@@ -84,23 +47,14 @@ instance (Time cl ~ Time cl', Clock (ExceptT e m) cl, Clock m cl', Monad m) => C
               e <- MSFExcept.try runningClock
               let cl' = handler e
               (runningClock', _) <- once_ $ initClock cl'
-              safe $ runningClock' >>> arr (second Left)
+              safe $ runningClock' >>> arr (second Right)
         return (catchingClock, initTime)
-      Left e -> (fmap (first (>>> arr (second Left))) . initClock) $ handler e
+      Left e -> (fmap (first (>>> arr (second Right))) . initClock) $ handler e
 
 instance (GetClockProxy (CatchClock cl e cl'))
 
--- FIXME cl1 cl2 convention everywhere?
-catchClSF :: (Time cl1 ~ Time cl2, Monad m) => ClSF m cl1 a b -> ClSF m cl2 a b -> ClSF m (CatchClock cl1 e cl2) a b
-catchClSF clsf1 clsf2 = readerS $ proc (timeInfo, a) -> do
-  case tag timeInfo of
-    Right tag1 -> runReaderS clsf1 -< (retag (const tag1) timeInfo, a)
-    Left tag2 -> runReaderS clsf2 -< (retag (const tag2) timeInfo, a)
-
--- | A clock that throws no exceptions.
 type SafeClock m = HoistClock (ExceptT Void m) m
 
--- | Hoist the monad of a clock into 'ExceptT', without throwing an exception.
 safeClock :: (Functor m) => cl -> SafeClock m cl
 safeClock unhoistedClock =
   HoistClock
@@ -108,17 +62,10 @@ safeClock unhoistedClock =
     , monadMorphism = fmap (either absurd id) . runExceptT
     }
 
-{- | A clock that emits a single tick, and then throws an exception.
-
-The tag, time measurement and exception have to be supplied as clock value.
--}
 data Single m time tag e = Single
   { singleTag :: tag
-  -- ^ The tag that will be emitted on the tick.
   , getTime :: m time
-  -- ^ A method to measure the current time.
   , exception :: e
-  -- ^ The exception to throw after the single tick.
   }
 
 instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) where
@@ -133,67 +80,39 @@ instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) wher
         errorT = (>>= liftEither)
     return (runningClock, initTime)
 
-{- | Catch an exception in clock @cl@ and throw it after one time step.
-
-This is particularly useful if you want to give your signal network a chance to save its current state in some way.
--}
 type DelayException m time cl e e' = CatchClock cl e (Single m time e e')
 
--- | Construct a 'DelayException' clock.
-delayException ::
-  (Monad m, Clock (ExceptT e m) cl, MonadError e' m) =>
-  -- | The clock that will throw an exception @e@
-  cl ->
-  -- | How to transform the exception into the new exception that will be thrown later
-  (e -> e') ->
-  -- | How to measure the current time
-  m (Time cl) ->
-  DelayException m (Time cl) cl e e'
+delayException :: (Monad m, Clock (ExceptT e m) cl, MonadError e' m) => cl -> (e -> e') -> m (Time cl) -> DelayException m (Time cl) cl e e'
 delayException cl handler mTime = CatchClock cl $ \e -> Single e mTime $ handler e
 
--- | Like 'delayException', but the exception thrown by @cl@ and by the @DelayException@ clock are the same.
 delayException' :: (Monad m, MonadError e m, Clock (ExceptT e m) cl) => cl -> m (Time cl) -> DelayException m (Time cl) cl e e
 delayException' cl = delayException cl id
 
--- | Catch an 'IO' 'Exception', and throw it after one time step.
 type DelayMonadIOException m cl e e' = DelayException m UTCTime (ExceptClock cl e) e e'
 
--- | Build a 'DelayMonadIOException'. The time will be measured using the system time.
 delayMonadIOException :: (Exception e, MonadIO m, MonadError e' m, Clock IO cl, Time cl ~ UTCTime) => cl -> (e -> e') -> DelayMonadIOException m cl e e'
 delayMonadIOException cl handler = delayException (ExceptClock cl) handler $ liftIO getCurrentTime
 
--- | 'DelayMonadIOException' specialised to 'IOError'.
 type DelayMonadIOError m cl e = DelayMonadIOException m cl IOError e
 
--- | 'delayMonadIOException' specialised to 'IOError'.
 delayMonadIOError :: (Exception e, MonadError e m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> (IOError -> e) -> DelayMonadIOError m cl e
 delayMonadIOError = delayMonadIOException
 
--- | Like 'delayMonadIOError', but throw the error without transforming it.
 delayMonadIOError' :: (MonadError IOError m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayMonadIOError m cl IOError
 delayMonadIOError' cl = delayMonadIOError cl id
 
-{- | 'DelayMonadIOException' specialised to the monad @'ExceptT' e' 'IO'@.
-
-This is sometimes helpful when the type checker complains about an ambigous monad type variable.
--}
 type DelayIOException cl e e' = DelayException (ExceptT e' IO) UTCTime (ExceptClock cl e) e e'
 
--- | 'delayMonadIOException' specialised to the monad @'ExceptT' e' 'IO'@.
 delayIOException :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> (e -> e') -> DelayIOException cl e e'
-delayIOException = delayMonadIOException
+delayIOException cl handler = delayException (ExceptClock cl) handler $ liftIO getCurrentTime
 
--- | 'delayIOException'', but throw the error without transforming it.
 delayIOException' :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayIOException cl e e
 delayIOException' cl = delayIOException cl id
 
--- | 'DelayIOException' specialised to 'IOError'.
 type DelayIOError cl e = DelayIOException cl IOError e
 
--- | 'delayIOException' specialised to 'IOError'.
 delayIOError :: (Time cl ~ UTCTime, Clock IO cl) => cl -> (IOError -> e) -> DelayIOError cl e
 delayIOError = delayIOException
 
--- | 'delayIOError', but throw the error without transforming it.
 delayIOError' :: (Time cl ~ UTCTime, Clock IO cl) => cl -> DelayIOError cl IOError
 delayIOError' cl = delayIOException cl id
diff --git a/rhine/test/Clock.hs b/rhine/test/Clock.hs
index 8a75fac4..0019dcf5 100644
--- a/rhine/test/Clock.hs
+++ b/rhine/test/Clock.hs
@@ -4,6 +4,10 @@ module Clock where
 import Test.Tasty
 
 -- rhine
+<<<<<<< HEAD
+=======
+import Clock.Catch
+>>>>>>> f7d003c (WIP)
 import Clock.Except
 import Clock.FixedStep
 import Clock.Millisecond
@@ -11,7 +15,12 @@ import Clock.Millisecond
 tests =
   testGroup
     "Clock"
+<<<<<<< HEAD
     [ Clock.Except.tests
+=======
+    [ Clock.Catch.tests
+    , Clock.Except.tests
+>>>>>>> f7d003c (WIP)
     , Clock.FixedStep.tests
     , Clock.Millisecond.tests
     ]
diff --git a/rhine/test/Clock/Catch.hs b/rhine/test/Clock/Catch.hs
new file mode 100644
index 00000000..699607b5
--- /dev/null
+++ b/rhine/test/Clock/Catch.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Clock.Catch where
+
+-- base
+import Control.Exception
+import Data.Bifunctor (first)
+import GHC.IO.Handle (hDuplicateTo)
+import System.IO (IOMode (ReadMode), stdin, withFile)
+import System.IO.Error (isEOFError)
+
+-- text
+import Data.Text
+
+-- tasty
+import Test.Tasty (testGroup)
+
+-- tasty-hunit
+import Test.Tasty.HUnit (testCase, (@?=))
+
+-- rhine
+import FRP.Rhine
+import FRP.Rhine.Clock.Catch
+import Paths_rhine
+
+type CatchStdin = CatchOnceIOError StdinClock
+
+newtype MyException = MyException [Text]
+  deriving (Show)
+
+instance Exception MyException
+
+cl :: CatchStdin
+cl = catchOnce StdinClock isEOFError
+
+clsf :: ClSF IO CatchStdin () ()
+clsf = proc () -> do
+  tag <- tagS -< ()
+  allText <- mappendS -< either (const []) pure tag
+  left $ arrMCl $ Control.Exception.throw . MyException -< Data.Bifunctor.first (const allText) tag
+  returnA -< ()
+
+tests =
+  testGroup
+    "Catch"
+    [ testCase "Outputs the exception on EOF" $ do
+        testdataFile <- getDataFileName "test/assets/testdata.txt"
+        withFile testdataFile ReadMode $ \h -> do
+          hDuplicateTo h stdin
+          catch (flow $ clsf @@ cl) $ \(MyException outputs) ->
+            outputs @?= ["data", "test"]
+    ]
diff --git a/rhine/test/Clock/Except.hs b/rhine/test/Clock/Except.hs
index 6b0bd696..d70ff1b0 100644
--- a/rhine/test/Clock/Except.hs
+++ b/rhine/test/Clock/Except.hs
@@ -20,34 +20,19 @@ import Control.Monad.Trans.Writer.Strict hiding (tell)
 import Data.Text (Text)
 
 -- tasty
-import Test.Tasty (TestTree, testGroup)
+import Test.Tasty (testGroup)
 
 -- tasty-hunit
 import Test.Tasty.HUnit (testCase, (@?), (@?=))
 
 -- rhine
 import FRP.Rhine
-import FRP.Rhine.Clock.Except (
-  CatchClock (CatchClock),
-  DelayIOError,
-  DelayMonadIOError,
-  ExceptClock (ExceptClock),
-  catchClSF,
-  delayIOError,
-  delayMonadIOError',
- )
+import FRP.Rhine.Clock.Except (CatchClock (CatchClock), DelayIOError, DelayMonadIOError, ExceptClock (ExceptClock), delayIOError, delayMonadIOError')
 import Paths_rhine
 
-tests :: TestTree
-tests =
-  testGroup
-    "ExceptClock"
-    [catchClockTests, delayedClockTests, innerWriterTests]
-
--- ** 'CatchClock'
-
-type WT = WriterT [Text]
+-- FIXME organisation: group functions & clock values closer to their test cases
 type E = ExceptT IOError IO
+type WT = WriterT [Text]
 type M = WT E
 type EClock = ExceptClock StdinClock IOError
 
@@ -58,78 +43,66 @@ type TestClock =
     ( CatchClock
         EClock
         IOError
-        StdinClock
+        EClock
     )
 
 -- FIXME also need to test the other branch of CatchClock
 testClock :: TestClock
-testClock = liftClock $ CatchClock (ExceptClock StdinClock) $ const StdinClock
-
-catchClockTests :: TestTree
-catchClockTests =
-  testGroup
-    "CatchClock"
-    [ testCase "Outputs the exception on EOF" $ withTestStdin $ do
-        let
-          tellStdin :: ClSF M TestClock () ()
-          tellStdin = proc () -> do
-            tag <- tagS -< ()
-            arrMCl tell -< either (const []) pure tag
-
-        Left result <- runExceptT $ runWriterT $ flow $ tellStdin @@ testClock
-        isEOFError result @? "It's an EOF error"
-    ]
+testClock = liftClock $ CatchClock (ExceptClock StdinClock) $ const $ ExceptClock StdinClock
 
--- ** 'DelayException'
+clsf :: ClSF M TestClock () ()
+clsf = proc () -> do
+  tag <- tagS -< ()
+  arrMCl tell -< either (const ["weird"]) pure tag
 
 type DelayedClock = DelayIOError StdinClock (Maybe [Text])
 
+-- type DelayedClock = DelayException IO UTCTime (ExceptClock StdinClock IOError) IOError (Maybe [Text])
+
 delayedClock :: DelayedClock
 delayedClock = delayIOError StdinClock $ const Nothing
 
-delayedClockTests :: TestTree
-delayedClockTests =
+-- FIXME it would be cool if there were a utility that combines two clsfs under the two parts of the catchclock
+clsf2 :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()
+clsf2 = proc () -> do
+  tag <- tagS -< ()
+  textSoFar <- mappendS -< either pure (const []) tag
+  throwOn' -< (isRight tag, Just textSoFar)
+
+clsf3 :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()
+clsf3 = proc () -> do
+  tag <- tagS -< ()
+  _textSoFar <- mappendS -< either pure (const []) tag
+  returnA -< ()
+
+-- clsf4 :: ClSF (ExceptT IOError (WriterT [Text] IO)) (LiftClock (WriterT [Text] IO) (ExceptT IOError) (DelayIOError StdinClock IOError)) () ()
+clsf4 :: (Tag cl ~ Either Text a) => (MonadWriter [Text] m) => ClSF m cl () ()
+clsf4 =
+  tagS >>> proc tag -> case tag of
+    Left text -> arrMCl tell -< [text]
+    Right _ -> returnA -< ()
+
+tests =
   testGroup
-    "DelayedClock"
-    [ testCase "DelayException delays error by 1 step" $ withTestStdin $ do
-        let
-          -- FIXME it would be cool if there were a utility that combines two clsfs under the two parts of the catchclock
-          throwCollectedText :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()
-          throwCollectedText = proc () -> do
-            tag <- tagS -< ()
-            textSoFar <- mappendS -< either (const []) pure tag
-            throwOn' -< (isRight tag, Just textSoFar)
-        result <- runExceptT $ flow $ throwCollectedText @@ delayedClock
+    "ExceptClock"
+    [ testCase "Outputs the exception on EOF" $ withTestStdin $ do
+        Left result <- runExceptT $ runWriterT $ flow $ clsf @@ testClock
+        isEOFError result @? "It's an EOF error"
+    , testCase "DelayException delays error by 1 step" $ withTestStdin $ do
+        result <- runExceptT $ flow $ clsf2 @@ delayedClock
         result @?= Left (Just ["data", "test"])
     , testCase "DelayException throws error after 1 step" $ withTestStdin $ do
-        let
-          dontThrow :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()
-          dontThrow = clId
-        result <- runExceptT $ flow $ dontThrow @@ delayedClock
+        result <- runExceptT $ flow $ clsf3 @@ delayedClock
         result @?= Left Nothing
+    , testCase "DelayException throws error after 1 step, but can write down results" $ withTestStdin $ do
+        (Left e, result) <- runWriterT $ runExceptT $ flow $ clsf4 @@ clWriterExcept
+        isEOFError e @? "is EOF"
+        result @?= ["test", "data"]
     ]
 
-{- | 'WriterT' is now the inner monad, meaning that the log survives exceptions.
-This way, the state is not lost.
--}
-type ClWriterExcept = DelayMonadIOError (ExceptT IOError (WriterT [Text] IO)) StdinClock IOError
-
-clWriterExcept :: ClWriterExcept
+clWriterExcept :: DelayMonadIOError (ExceptT IOError (WriterT [Text] IO)) StdinClock IOError
 clWriterExcept = delayMonadIOError' StdinClock
 
-innerWriterTests :: TestTree
-innerWriterTests = testCase "DelayException throws error after 1 step, but can write down results" $ withTestStdin $ do
-  let
-    tellStdin :: (MonadWriter [Text] m) => ClSF m ClWriterExcept () ()
-    tellStdin = catchClSF (tagS >>> arrMCl (tell . pure)) clId
-
-  (Left e, result) <- runWriterT $ runExceptT $ flow $ tellStdin @@ clWriterExcept
-  isEOFError e @? "is EOF"
-  result @?= ["test", "data"]
-
--- * Test helpers
-
--- | Emulate test standard input
 withTestStdin :: IO a -> IO a
 withTestStdin action = do
   testdataFile <- getDataFileName "test/assets/testdata.txt"