Catch io exceptions in clocks

rhine/rhine.cabal

@@ -26,6 +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
@@ -43,7 +49,11 @@ source-repository this
 common opts
   build-depends:
     base >=4.14 && <4.18,
+    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
@@ -53,6 +63,7 @@ common opts
     -Wno-unticked-promoted-constructors
 
   default-extensions:
+    Arrows
     DataKinds
     FlexibleContexts
     FlexibleInstances
@@ -79,6 +90,11 @@ 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
     FRP.Rhine.Clock.Proxy
@@ -121,12 +137,14 @@ 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,
     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
@@ -138,16 +156,31 @@ test-suite test
   main-is: Main.hs
   other-modules:
     Clock
+<<<<<<< HEAD
+=======
+    Clock.Catch
+>>>>>>> f7d003c (WIP)
+    Clock.Except
     Clock.FixedStep
     Clock.Millisecond
+    Paths_rhine
     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.

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

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

@@ -0,0 +1,118 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module FRP.Rhine.Clock.Except where
+
+import Control.Exception
+import Control.Exception qualified as Exception
+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
+
+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)
+
+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 Left)) <$> 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 Right)
+        return (catchingClock, initTime)
+      Left e -> (fmap (first (>>> arr (second Right))) . initClock) $ handler e
+
+instance (GetClockProxy (CatchClock cl e cl'))
+
+type SafeClock m = HoistClock (ExceptT Void m) m
+
+safeClock :: (Functor m) => cl -> SafeClock m cl
+safeClock unhoistedClock =
+  HoistClock
+    { unhoistedClock
+    , monadMorphism = fmap (either absurd id) . runExceptT
+    }
+
+data Single m time tag e = Single
+  { singleTag :: tag
+  , getTime :: m time
+  , exception :: e
+  }
+
+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)
+
+type DelayException m time cl e e' = CatchClock cl e (Single m time 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
+
+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 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 $ liftIO getCurrentTime
+
+delayIOException' :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayIOException cl e e
+delayIOException' cl = delayIOException cl id
+
+type DelayIOError cl e = DelayIOException cl IOError e
+
+delayIOError :: (Time cl ~ UTCTime, Clock IO cl) => cl -> (IOError -> e) -> DelayIOError cl e
+delayIOError = delayIOException
+
+delayIOError' :: (Time cl ~ UTCTime, Clock IO cl) => cl -> DelayIOError cl IOError
+delayIOError' cl = delayIOException cl id

rhine/test/Clock.hs

@@ -4,12 +4,23 @@
 import Test.Tasty
 
 -- rhine
+<<<<<<< HEAD
+=======
+import Clock.Catch
+>>>>>>> f7d003c (WIP)
+import Clock.Except
 import Clock.FixedStep
 import Clock.Millisecond
 
 tests =
   testGroup
     "Clock"
-    [ Clock.FixedStep.tests
+<<<<<<< HEAD
+    [ Clock.Except.tests
+=======
+    [ Clock.Catch.tests
+    , Clock.Except.tests
+>>>>>>> f7d003c (WIP)
+    , Clock.FixedStep.tests
     , Clock.Millisecond.tests
     ]

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"]
+    ]