From 2c9017eb63a61ea69e665dbb16a81a90f7aa950f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20B=C3=A4renz?= Date: Tue, 13 Feb 2024 16:51:56 +0100 Subject: [PATCH] works more generally --- rhine/rhine.cabal | 1 + rhine/src/FRP/Rhine/Clock/Except.hs | 66 ++++++++++++++++------------- rhine/test/Clock/Except.hs | 30 ++++++++----- 3 files changed, 56 insertions(+), 41 deletions(-) diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index e5a5d41f..ddc3060c 100644 --- a/rhine/rhine.cabal +++ b/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. diff --git a/rhine/src/FRP/Rhine/Clock/Except.hs b/rhine/src/FRP/Rhine/Clock/Except.hs index b3904b66..667ae318 100644 --- a/rhine/src/FRP/Rhine/Clock/Except.hs +++ b/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 diff --git a/rhine/test/Clock/Except.hs b/rhine/test/Clock/Except.hs index fc2b4315..d70ff1b0 100644 --- a/rhine/test/Clock/Except.hs +++ b/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"