diff --git a/rhine/rhine.cabal b/rhine/rhine.cabal index 438b609a..b601130b 100644 --- a/rhine/rhine.cabal +++ b/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. 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 new file mode 100644 index 00000000..667ae318 --- /dev/null +++ b/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 diff --git a/rhine/test/Clock.hs b/rhine/test/Clock.hs index df0e4f80..0019dcf5 100644 --- a/rhine/test/Clock.hs +++ b/rhine/test/Clock.hs @@ -4,12 +4,23 @@ module Clock where 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 ] 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 new file mode 100644 index 00000000..d70ff1b0 --- /dev/null +++ b/rhine/test/Clock/Except.hs @@ -0,0 +1,111 @@ +{-# 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 (testGroup) + +-- tasty-hunit +import Test.Tasty.HUnit (testCase, (@?), (@?=)) + +-- rhine +import FRP.Rhine +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 +type E = ExceptT IOError IO +type WT = WriterT [Text] +type M = WT E +type EClock = ExceptClock StdinClock IOError + +type TestClock = + LiftClock + E + WT + ( CatchClock + EClock + IOError + EClock + ) + +-- FIXME also need to test the other branch of CatchClock +testClock :: TestClock +testClock = liftClock $ CatchClock (ExceptClock StdinClock) $ const $ ExceptClock StdinClock + +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 + +-- 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 + "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 + 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"] + ] + +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" + 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