Skip to content

Commit

Permalink
WIP
Browse files Browse the repository at this point in the history
turion committed Mar 13, 2024
1 parent 5737c22 commit 698a01e
Showing 6 changed files with 216 additions and 167 deletions.
23 changes: 23 additions & 0 deletions rhine/rhine.cabal
Original file line number Diff line number Diff line change
@@ -26,7 +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
@@ -47,6 +52,8 @@ common opts
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
@@ -83,6 +90,10 @@ 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
@@ -133,6 +144,7 @@ library
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
@@ -144,20 +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.
72 changes: 72 additions & 0 deletions rhine/src/FRP/Rhine/Clock/Catch.hs
Original file line number Diff line number Diff line change
@@ -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
109 changes: 14 additions & 95 deletions rhine/src/FRP/Rhine/Clock/Except.hs
Original file line number Diff line number Diff line change
@@ -2,49 +2,20 @@

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 ((<=<), (>=>))
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

-- 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
@@ -62,63 +33,39 @@ instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio

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)
type Tag (CatchClock cl e cl') = Either (Tag cl) (Tag cl')
initClock (CatchClock cl handler) = do
tryToInit <- runExceptT $ first (>>> arr (second Right)) <$> 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 = safely $ do
e <- MSFExcept.try runningClock
let cl' = handler e
(runningClock', _) <- once_ $ initClock cl'
safe $ runningClock' >>> arr (second Left)
safe $ runningClock' >>> arr (second Right)
return (catchingClock, initTime)
Left e -> (fmap (first (>>> arr (second Left))) . initClock) $ handler e
Left e -> (fmap (first (>>> arr (second Right))) . 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
@@ -133,67 +80,39 @@ instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) wher
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 :: (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

-- | 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 cl handler = delayException (ExceptClock cl) handler $ liftIO getCurrentTime

-- | '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
9 changes: 9 additions & 0 deletions rhine/test/Clock.hs
Original file line number Diff line number Diff line change
@@ -4,14 +4,23 @@ module Clock where
import Test.Tasty

-- rhine
<<<<<<< HEAD

Check failure on line 7 in rhine/test/Clock.hs

GitHub Actions / Run hlint

Error: Parse error: on input `<<<<<<<' ▫︎ Found: " -- rhine\n> <<<<<<< HEAD\n =======\n import Clock.Catch\n"
=======
import Clock.Catch
>>>>>>> f7d003c (WIP)
import Clock.Except
import Clock.FixedStep
import Clock.Millisecond

tests =
testGroup
"Clock"
<<<<<<< HEAD
[ Clock.Except.tests
=======
[ Clock.Catch.tests
, Clock.Except.tests
>>>>>>> f7d003c (WIP)
, Clock.FixedStep.tests
, Clock.Millisecond.tests
]
53 changes: 53 additions & 0 deletions rhine/test/Clock/Catch.hs
Original file line number Diff line number Diff line change
@@ -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"]
]
117 changes: 45 additions & 72 deletions rhine/test/Clock/Except.hs
Original file line number Diff line number Diff line change
@@ -20,34 +20,19 @@ import Control.Monad.Trans.Writer.Strict hiding (tell)
import Data.Text (Text)

-- tasty
import Test.Tasty (TestTree, testGroup)
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),
catchClSF,
delayIOError,
delayMonadIOError',
)
import FRP.Rhine.Clock.Except (CatchClock (CatchClock), DelayIOError, DelayMonadIOError, ExceptClock (ExceptClock), delayIOError, delayMonadIOError')
import Paths_rhine

tests :: TestTree
tests =
testGroup
"ExceptClock"
[catchClockTests, delayedClockTests, innerWriterTests]

-- ** 'CatchClock'

type WT = WriterT [Text]
-- 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

@@ -58,78 +43,66 @@ type TestClock =
( CatchClock
EClock
IOError
StdinClock
EClock
)

-- 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"
]
testClock = liftClock $ CatchClock (ExceptClock StdinClock) $ const $ ExceptClock StdinClock

-- ** 'DelayException'
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

delayedClockTests :: TestTree
delayedClockTests =
-- 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
"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
"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
let
dontThrow :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()
dontThrow = clId
result <- runExceptT $ flow $ dontThrow @@ delayedClock
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"]
]

{- | '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 (ExceptT IOError (WriterT [Text] IO)) StdinClock IOError
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"

0 comments on commit 698a01e

Please sign in to comment.