diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index 438b609a7..1368e4898 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 000000000..1d85dbb74 --- /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 df0e4f806..8a75fac48 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 000000000..6b0bd696b --- /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 000000000..dfe77698a --- /dev/null +++ b/rhine/test/assets/testdata.txt @@ -0,0 +1,2 @@ +test +data