WIP extend except tests

rhine/test/Clock/Except.hs

@@ -4,7 +4,7 @@
 module Clock.Except where
 
 -- base
-import Data.Either (isRight)
+import Data.Either (isLeft)
 import GHC.IO.Handle (hDuplicateTo)
 import System.IO (IOMode (ReadMode), stdin, withFile)
 import System.IO.Error (isEOFError)
@@ -26,6 +26,9 @@ import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (testCase, (@?), (@?=))
 
 -- rhine
+
+import Control.Applicative (Alternative (empty))
+import Control.Monad.Trans.Maybe (MaybeT (..))
 import FRP.Rhine
 import FRP.Rhine.Clock.Except (
   CatchClock (CatchClock),
@@ -34,50 +37,92 @@ import FRP.Rhine.Clock.Except (
   ExceptClock (ExceptClock),
   catchClSF,
   delayIOError,
-  delayMonadIOError',
+  delayMonadIOError', SafeClock, safeClock,
  )
 import Paths_rhine
+import Data.Void (Void)
 
 tests :: TestTree
 tests =
   testGroup
-    "ExceptClock"
-    [catchClockTests, delayedClockTests, innerWriterTests]
+    "Except"
+    [exceptClockTests, catchClockTests, delayedClockTests, innerWriterTests]
 
--- ** 'CatchClock'
+-- * 'Except'
 
-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
-    )
+exceptClock :: EClock
+exceptClock = ExceptClock StdinClock
+
+exceptClockTests :: TestTree
+exceptClockTests =
+  testGroup
+    "ExceptClock"
+    [ testCase "Raises the exception in ExceptT on EOF" $ withTestStdin $ do
+        Left result <- runExceptT $ flow $ clId @@ exceptClock
+        isEOFError result @? "It's an EOF error"
+    ]
+
+-- ** 'CatchClock'
+
+type TestCatchClock = CatchClock EClock IOError EClock
 
 -- FIXME also need to test the other branch of CatchClock
-testClock :: TestClock
-testClock = liftClock $ CatchClock (ExceptClock StdinClock) $ const StdinClock
+testClock :: TestCatchClock
+testClock = CatchClock exceptClock $ const exceptClock
+
+type ME = MaybeT E
+type TestCatchClockMaybe = CatchClock EClock IOError (LiftClock E MaybeT (LiftClock IO (ExceptT IOError) Busy))
+
+testClockMaybe :: TestCatchClockMaybe
+testClockMaybe = CatchClock exceptClock (const (liftClock (liftClock Busy))) `isClockIn` (ThisMonad @ME)
 
 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
+    [ testCase "Outputs the exception of the second clock as well" $ withTestStdin $ do
+        Left result <- runExceptT $ flow $ clId @@ testClock
         isEOFError result @? "It's an EOF error"
+    , testCase "Can recover from an exception" $ withTestStdin $ do
+        let stopInClsf :: ClSF ME TestCatchClockMaybe () ()
+            stopInClsf = catchClSF clId $ constMCl empty
+        result <- runExceptT $ runMaybeT $ flow $ stopInClsf @@ testClockMaybe
+        result @?= Right Nothing
+    ]
+
+-- ** Clock failing at init
+
+-- | This clock throws an exception at initialization
+data FailingClock = FailingClock
+
+instance (Monad m) => Clock (ExceptT () m) FailingClock where
+  type Time FailingClock = UTCTime
+  type Tag FailingClock = ()
+  initClock FailingClock = throwE ()
+
+instance GetClockProxy FailingClock
+
+type CatchFailingClock = CatchClock FailingClock () (SafeClock (MaybeT IO) Busy)
+
+catchFailingClock :: CatchFailingClock
+catchFailingClock = CatchClock FailingClock $ const $ safeClock Busy
+
+failingClockTests :: TestTree
+failingClockTests =
+  testGroup
+    "FailingClock"
+    [ testCase "flow fails immediately" $ do
+        result <- runExceptT $ flow $ clId @@ FailingClock
+        result @?= Left ()
+    , testCase "CatchClock recovers from failure at init" $ do
+        let
+            clsfStops :: ClSF (ExceptT () (MaybeT IO)) CatchFailingClock () ()
+            clsfStops = catchClSF clId $ constM empty
+        result <- runMaybeT $ runExceptT $ flow $ clsfStops @@ catchFailingClock
+        _
     ]
 
 -- ** 'DelayException'
@@ -98,7 +143,7 @@ delayedClockTests =
           throwCollectedText = proc () -> do
             tag <- tagS -< ()
             textSoFar <- mappendS -< either (const []) pure tag
-            throwOn' -< (isRight tag, Just textSoFar)
+            throwOn' -< (isLeft tag, Just textSoFar)
         result <- runExceptT $ flow $ throwCollectedText @@ delayedClock
         result @?= Left (Just ["data", "test"])
     , testCase "DelayException throws error after 1 step" $ withTestStdin $ do
@@ -109,6 +154,8 @@ delayedClockTests =
         result @?= Left Nothing
     ]
 
+-- ** Inner writer
+
 {- | 'WriterT' is now the inner monad, meaning that the log survives exceptions.
 This way, the state is not lost.
 -}