diff --git a/fused-effects-exceptions.cabal b/fused-effects-exceptions.cabal index a104594..920a06d 100644 --- a/fused-effects-exceptions.cabal +++ b/fused-effects-exceptions.cabal @@ -39,6 +39,7 @@ test-suite test main-is: Main.hs build-depends: base + , fused-effects-exceptions , fused-effects , tasty ^>= 1.2 , tasty-hunit ^>= 0.10 diff --git a/test/Main.hs b/test/Main.hs index 89ad4b3..6f79a86 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,40 @@ +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} + module Main where +import Prelude hiding (ioError) + +import qualified Control.Carrier.State.IORef as IOState +import qualified Control.Carrier.State.Strict as State +import Control.Carrier.Lift (runM) +import Control.Effect.Exception +import Control.Effect.State +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as HUnit + +problematic :: (Has (Lift IO) sig m, Has (State Char) sig m) => m () +problematic = + let throws = modify @Char succ *> throwIO (userError "should explode") `finally` put @Char 'x' + in throws `catch` (\(_ :: IOException) -> pure ()) + +testStateDropsWrites :: Tasty.TestTree +testStateDropsWrites = HUnit.testCase "State.Strict drops writes" $ do + result <- runM . State.execState 'a' $ problematic + result HUnit.@?= 'a' -- writes are lost + +testIOStatePreservesWrites :: Tasty.TestTree +testIOStatePreservesWrites = HUnit.testCase "State.IORef preserves writes" $ do + result <- runM . IOState.execState 'a' $ problematic + result HUnit.@?= 'x' + +tests :: Tasty.TestTree +tests = Tasty.testGroup "Control.Carrier.Exception" + [ Tasty.testGroup "finally" + [ testStateDropsWrites + , testIOStatePreservesWrites + ] + ] + main :: IO () -main = pure () +main = Tasty.defaultMain tests +