content: {-# LANGUAGE OverloadedStrings #-}
  
  module Clock.Except where
  
  -- base
  import Control.Applicative (Alternative (empty))
  import Data.Either (isLeft)
  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.Class (lift)
  import Control.Monad.Trans.Maybe (MaybeT (..))
  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
      "Except"
      [exceptClockTests, catchClockTests, delayedClockTests, innerWriterTests]
  
  -- * 'Except'
  
  type E = ExceptT IOError IO
  type EClock = ExceptClock StdinClock IOError
  
  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
  
  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)))
  
  catchClockTests :: TestTree
  catchClockTests =
    testGroup
      "CatchClock"
      [ 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.
  
  Useful for testing clock initialization.
  -}
  data FailingClock = FailingClock
  
  instance (Monad m) => Clock (ExceptT () m) FailingClock where
    type Time FailingClock = UTCTime
    type Tag FailingClock = ()
    initClock FailingClock = throwE ()
    {-# INLINE initClock #-}
  
  instance GetClockProxy FailingClock
  
  type CatchFailingClock = CatchClock FailingClock () Busy
  
  catchFailingClock :: CatchFailingClock
  catchFailingClock = CatchClock FailingClock $ const 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 (MaybeT IO) CatchFailingClock () ()
            clsfStops = catchClSF clId $ constM $ lift empty
          result <- runMaybeT $ flow_ $ clsfStops @@ catchFailingClock
          result @?= Nothing -- The ClSF stopped the execution, not the clock
      ]
  
  -- ** '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
            throwCollectedText :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()
            throwCollectedText = proc () -> do
              tag <- tagS -< ()
              textSoFar <- mappendS -< either (const []) pure tag
              throwOn' -< (isLeft 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
      ]
  
  -- ** Inner writer
  
  {- | '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
  