From db2ddf6d7f52dfb6344ed5a5f65ddac5b7bef941 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 29 Oct 2019 14:15:52 -0400 Subject: [PATCH 1/6] Add a skeleton test suite. --- fused-effects-exceptions.cabal | 11 +++++++++++ test/Main.hs | 4 ++++ 2 files changed, 15 insertions(+) create mode 100644 test/Main.hs diff --git a/fused-effects-exceptions.cabal b/fused-effects-exceptions.cabal index 0a17efd..a104594 100644 --- a/fused-effects-exceptions.cabal +++ b/fused-effects-exceptions.cabal @@ -33,6 +33,17 @@ library , fused-effects >= 1 , transformers >= 0.4 && < 0.6 +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base + , fused-effects + , tasty ^>= 1.2 + , tasty-hunit ^>= 0.10 + , transformers + source-repository head type: git location: https://github.com/fused-effects/fused-effects-exceptions diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..89ad4b3 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = pure () From a685909638a6401be7822d2c2ed61747411cdc9e Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 29 Oct 2019 14:47:13 -0400 Subject: [PATCH 2/6] Test `finally` in the presence of State.Strict and State.IORef. --- fused-effects-exceptions.cabal | 1 + test/Main.hs | 38 +++++++++++++++++++++++++++++++++- 2 files changed, 38 insertions(+), 1 deletion(-) 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 + From 3191eadf9bc14fb932b0c1a76584cd3ecd4a2f66 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 29 Oct 2019 14:50:52 -0400 Subject: [PATCH 3/6] Adjust example in the README. --- README.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 1032029..e35ff3c 100644 --- a/README.md +++ b/README.md @@ -9,8 +9,9 @@ This package provides `Control.Effect.Exception`, a module that wraps the [`Cont Please be aware that injudicious use of these functions may provoke surprising interactions with carriers that thread a monadic state as a parameter, à la the `Control.Carrier.State` types provided by `fused-effects`. For example, a function like `finally`, which does not thread any state from its body to its handler block, may discard state writes in cleanup handlers: ```haskell -λ runM (runResource (runState 'a' (modify (succ @Char) `finally` modify (succ . succ @Char)))) -('b', ()) +λ runM (runState 'a' ((throwIO (userError "urk") `finally` put @Char 'z') + `catch` (\(_ :: IOException) -> pure ()))) +('a', ()) ``` If this behavior is a concern, a `Control.Carrier.State.IORef` carrier is provided, which fixes this issue given access to a `MonadIO` constraint. If it is not a concern (such as if the cleanup block is only run for its effects in `IO`), then the `StateC` carriers from `fused-effects` will suffice. For more information about the issues associated with this approach, consult Alexis King's excellent [Demystifying `MonadBaseControl`](https://lexi-lambda.github.io/blog/2019/09/07/demystifying-monadbasecontrol/). From 56b9169cd90b0bdeca647510f332487a4d3a965e Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 29 Oct 2019 14:56:11 -0400 Subject: [PATCH 4/6] Forgot a language clause. --- fused-effects-exceptions.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/fused-effects-exceptions.cabal b/fused-effects-exceptions.cabal index 920a06d..a322e2b 100644 --- a/fused-effects-exceptions.cabal +++ b/fused-effects-exceptions.cabal @@ -35,6 +35,7 @@ library test-suite test type: exitcode-stdio-1.0 + default-language: Haskell2010 hs-source-dirs: test main-is: Main.hs build-depends: From 0ca568cbced6d8b5c4f9adce24fe057f66aa9649 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 31 Oct 2019 15:40:29 -0400 Subject: [PATCH 5/6] No need for a runM. --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 111be14..065328e 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ This package provides `Control.Effect.Exception`, a module that wraps the [`Cont Please be aware that injudicious use of these functions may provoke surprising interactions with carriers that thread a monadic state as a parameter, à la the `Control.Carrier.State` types provided by `fused-effects`. For example, a function like `finally`, which does not thread any state from its body to its handler block, may discard state writes in cleanup handlers: ```haskell -λ runM (runState 'a' ((throwIO (userError "urk") `finally` put @Char 'z') +λ run (runState 'a' ((throwIO (userError "urk") `finally` put @Char 'z') `catch` (\(_ :: IOException) -> pure ()))) ('a', ()) ``` From f168d094d3920df68c7fdf91457f800cee2f503a Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 31 Oct 2019 16:00:58 -0400 Subject: [PATCH 6/6] Run the tests in CI now that we have them. --- .github/workflows/haskell.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 84adab5..e61f342 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -24,13 +24,13 @@ jobs: - name: Install dependencies run: | cabal v2-update - cabal v2-configure --write-ghc-environment-files=always -j2 + cabal v2-configure --enable-tests --write-ghc-environment-files=always -j2 cabal v2-build --only-dependencies - name: Build & test run: | cabal v2-build - cabal v2-run examples + cabal v2-test cabal v2-haddock cabal v2-sdist cabal check