works more generally

rhine/rhine.cabal

@@ -160,6 +160,7 @@ test-suite test
     rhine,
     tasty ^>=1.4,
     tasty-hunit ^>=0.10,
+    mtl,
 
 flag dev
   description: Enable warnings as errors. Active on ci.

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

@@ -4,7 +4,7 @@ module FRP.Rhine.Clock.Except where
 
 import Control.Exception
 import Control.Exception qualified as Exception
-import Control.Monad ((<=<))
+import Control.Monad ((<=<), (>=>))
 import Control.Monad.Error.Class
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Trans.Class (lift)
@@ -33,29 +33,25 @@ instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio
 
 instance GetClockProxy (ExceptClock cl e)
 
-data CatchClock cl e cl' e' = CatchClock cl (e -> Either e' cl')
+data CatchClock cl e cl' = CatchClock cl (e -> cl')
 
-instance (Time cl ~ Time cl', Clock (ExceptT e m) cl, Clock (ExceptT e' m) cl', Monad m) => Clock (ExceptT e' m) (CatchClock cl e cl' e') where
-  type Time (CatchClock cl e cl' e') = Time cl
-  type Tag (CatchClock cl e cl' e') = Either (Tag cl) (Tag 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 <- lift $ runExceptT $ first (>>> arr (second Left)) <$> 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
-        let catchingClock = runMSFExcept $ do
+        let catchingClock = safely $ do
               e <- MSFExcept.try runningClock
-              case handler e of
-                Right cl' -> do
-                  tryToInit' <- once_ $ runExceptT $ initClock cl'
-                  case tryToInit' of
-                    Right (runningClock', _) -> MSFExcept.try $ runningClock' >>> arr (second Right)
-                    Left e' -> return e'
-                Left e' -> return e'
+              let cl' = handler e
+              (runningClock', _) <- once_ $ initClock cl'
+              safe $ runningClock' >>> arr (second Right)
         return (catchingClock, initTime)
-      Left e -> either throwE (fmap (first (>>> arr (second Right))) . initClock) $ handler e
+      Left e -> (fmap (first (>>> arr (second Right))) . initClock) $ handler e
 
-instance (GetClockProxy (CatchClock cl e cl' e'))
+instance (GetClockProxy (CatchClock cl e cl'))
 
 type SafeClock m = HoistClock (ExceptT Void m) m
 
@@ -66,39 +62,49 @@ safeClock unhoistedClock =
     , monadMorphism = fmap (either absurd id) . runExceptT
     }
 
-type CatchSafe cl e cl' m = SafeClock m (CatchClock cl e (LiftClock m (ExceptT Void) cl') Void)
-
-catchSafe :: (Monad m) => cl -> (e -> cl') -> CatchSafe cl e cl' m
-catchSafe cl handler = safeClock $ CatchClock cl $ Right . liftClock . handler
-
 data Single m time tag e = Single
   { singleTag :: tag
   , getTime :: m time
   , exception :: e
   }
 
-instance (TimeDomain time, Monad m) => Clock (ExceptT e m) (Single m time tag e) where
+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 <- lift getTime
-    let runningClock = runMSFExcept $ 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)
 
-type DelayException m time cl e e' = CatchClock cl e (Single m time e e') e'
+type DelayException m time cl e e' = CatchClock cl e (Single m time e e')
 
-delayException :: (Clock (ExceptT e m) cl) => cl -> (e -> e') -> m (Time cl) -> DelayException m (Time cl) cl e e'
-delayException cl handler mTime = CatchClock cl $ Right . (\e -> Single e mTime $ handler 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
 
-delayException' :: (Clock (ExceptT e m) cl) => cl -> m (Time cl) -> DelayException m (Time cl) cl e e
+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
 
-type DelayIOException cl e e' = DelayException IO UTCTime (ExceptClock cl e) e e'
+type DelayMonadIOException m cl e e' = DelayException m UTCTime (ExceptClock cl e) e e'
+
+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
+
+type DelayMonadIOError m cl e = DelayMonadIOException m cl IOError e
+
+delayMonadIOError :: (Exception e, MonadError e m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> (IOError -> e) -> DelayMonadIOError m cl e
+delayMonadIOError = delayMonadIOException
+
+delayMonadIOError' :: (MonadError IOError m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayMonadIOError m cl IOError
+delayMonadIOError' cl = delayMonadIOError cl id
+
+type DelayIOException cl e e' = DelayException (ExceptT e' IO) UTCTime (ExceptClock cl e) e e'
 
 delayIOException :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> (e -> e') -> DelayIOException cl e e'
-delayIOException cl handler = delayException (ExceptClock cl) handler getCurrentTime
+delayIOException cl handler = delayException (ExceptClock cl) handler $ liftIO getCurrentTime
 
 delayIOException' :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayIOException cl e e
 delayIOException' cl = delayIOException cl id

rhine/test/Clock/Except.hs

@@ -9,9 +9,12 @@ import GHC.IO.Handle (hDuplicateTo)
 import System.IO (IOMode (ReadMode), stdin, withFile)
 import System.IO.Error (isEOFError)
 
+-- mtl
+import Control.Monad.Writer.Class
+
 -- transformers
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Writer.CPS
+-- Replace Strict by CPS when bumping mtl to 2.3
+import Control.Monad.Trans.Writer.Strict hiding (tell)
 
 -- text
 import Data.Text (Text)
@@ -24,7 +27,7 @@ import Test.Tasty.HUnit (testCase, (@?), (@?=))
 
 -- rhine
 import FRP.Rhine
-import FRP.Rhine.Clock.Except (CatchClock (CatchClock), DelayIOError, ExceptClock (ExceptClock), delayIOError, delayIOError')
+import FRP.Rhine.Clock.Except (CatchClock (CatchClock), DelayIOError, DelayMonadIOError, ExceptClock (ExceptClock), delayIOError, delayMonadIOError')
 import Paths_rhine
 
 -- FIXME organisation: group functions & clock values closer to their test cases
@@ -41,12 +44,11 @@ type TestClock =
         EClock
         IOError
         EClock
-        IOError
     )
 
 -- FIXME also need to test the other branch of CatchClock
 testClock :: TestClock
-testClock = liftClock $ CatchClock (ExceptClock StdinClock) $ const $ Right $ ExceptClock StdinClock
+testClock = liftClock $ CatchClock (ExceptClock StdinClock) $ const $ ExceptClock StdinClock
 
 clsf :: ClSF M TestClock () ()
 clsf = proc () -> do
@@ -73,10 +75,12 @@ clsf3 = proc () -> do
   _textSoFar <- mappendS -< either pure (const []) tag
   returnA -< ()
 
-clsf4 :: ClSF (ExceptT IOError (WriterT [Text] IO)) (LiftClock (WriterT [Text] IO) (ExceptT IOError) (DelayIOError StdinClock IOError)) () ()
-clsf4 = tagS >>> proc tag -> case tag of
-  Left text -> arrMCl (lift . tell) -< [text]
-  Right _ -> 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
@@ -91,10 +95,14 @@ tests =
         result <- runExceptT $ flow $ clsf3 @@ delayedClock
         result @?= Left Nothing
     , testCase "DelayException throws error after 1 step, but can write down results" $ withTestStdin $ do
-        result <- runWriterT $ runExceptT $ flow $ clsf4 @@ liftClock (delayIOError' StdinClock)
-        result @?= (Left _, ["hi"])
+        (Left e, result) <- runWriterT $ runExceptT $ flow $ clsf4 @@ clWriterExcept
+        isEOFError e @? "is EOF"
+        result @?= ["test", "data"]
     ]
 
+clWriterExcept :: DelayMonadIOError (ExceptT IOError (WriterT [Text] IO)) StdinClock IOError
+clWriterExcept = delayMonadIOError' StdinClock
+
 withTestStdin :: IO a -> IO a
 withTestStdin action = do
   testdataFile <- getDataFileName "test/assets/testdata.txt"