diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,12 @@ ## [Unreleased] +## [0.7.3.0] - 2026-10-02 + +### Added + +- `Atelier.Effects.FileSystem.getModificationTime`: Lifted `System.Directory.getModificationTime`. + ## [0.7.2.0] - 2026-09-21 ### Added diff --git a/atelier-core.cabal b/atelier-core.cabal --- a/atelier-core.cabal +++ b/atelier-core.cabal @@ -5,13 +5,13 @@ -- see: https://github.com/sol/hpack name: atelier-core -version: 0.7.2.0 +version: 0.7.3.0 synopsis: Foundational Effectful-based effects and utilities description: Core effects and utilities for effect-based applications, built on Effectful — part of the atelier toolkit. category: Control homepage: https://github.com/tweag/tricorder#readme bug-reports: https://github.com/tweag/tricorder/issues -author: Victor Nascimento Bakke +author: Christian Georgii maintainer: victor.bakke@tweag.io license: MIT license-file: LICENSE @@ -204,12 +204,11 @@ , effectful-core ==2.7.* , effectful-plugin ==2.2.* , hedgehog ==1.7.* - , hspec ==2.11.* - , hspec-hedgehog ==0.3.* , stm ==2.5.* , stm-containers ==1.2.* , tasty ==1.5.* - , tasty-hspec ==1.2.* + , tasty-hedgehog ==1.4.* + , tasty-hunit >=0.10.2 && <0.11 , time >=1.12 && <1.17 mixins: base hiding (Prelude) diff --git a/src/Atelier/Effects/FileSystem.hs b/src/Atelier/Effects/FileSystem.hs --- a/src/Atelier/Effects/FileSystem.hs +++ b/src/Atelier/Effects/FileSystem.hs @@ -19,6 +19,7 @@ , writeFileBS , writeFileLBS , canonicalizePath + , getModificationTime , getCurrentDirectory , getXdgRuntimeDir , runFileSystemIO @@ -28,6 +29,7 @@ where import Control.Exception (bracket) +import Data.Time (UTCTime (..)) import Effectful (Effect, IOE) import Effectful.Dispatch.Dynamic (interpret_) import Effectful.Exception (throwIO) @@ -40,6 +42,7 @@ import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Map.Strict qualified as M +import Data.Time.Calendar.OrdinalDate qualified as Day import System.Directory qualified as Dir import System.Posix.IO qualified as Posix @@ -78,6 +81,8 @@ GetCurrentDirectory :: FileSystem m FilePath -- | The XDG runtime directory (@$XDG_RUNTIME_DIR@), falling back to @\/tmp@. GetXdgRuntimeDir :: FileSystem m FilePath + -- | Obtain the time at which the file or directory was last modified. + GetModificationTime :: FilePath -> FileSystem m UTCTime makeEffect ''FileSystem @@ -125,6 +130,7 @@ CanonicalizePath path -> liftIO $ Dir.canonicalizePath path GetCurrentDirectory -> liftIO Dir.getCurrentDirectory GetXdgRuntimeDir -> liftIO $ fromMaybe "/tmp" <$> lookupEnv "XDG_RUNTIME_DIR" + GetModificationTime path -> liftIO $ Dir.getModificationTime path -- | Interpret 'FileSystem' with inert results: reads return empty, existence @@ -144,6 +150,7 @@ CanonicalizePath path -> pure path GetCurrentDirectory -> pure "." GetXdgRuntimeDir -> pure "/tmp" + GetModificationTime _ -> pure $ UTCTime (Day.fromOrdinalDate 1970 1) 0 -- | Run `FileSystem` effect backed by a `State` effect with a `Map`. The keys @@ -175,3 +182,4 @@ CanonicalizePath fp -> pure fp GetCurrentDirectory -> pure "/" GetXdgRuntimeDir -> pure "/tmp" + GetModificationTime _ -> pure $ UTCTime (Day.fromOrdinalDate 1970 1) 0 diff --git a/test/Unit/Atelier/ConfigSpec.hs b/test/Unit/Atelier/ConfigSpec.hs --- a/test/Unit/Atelier/ConfigSpec.hs +++ b/test/Unit/Atelier/ConfigSpec.hs @@ -1,9 +1,10 @@ -module Unit.Atelier.ConfigSpec (spec_Config) where +module Unit.Atelier.ConfigSpec (test_Config) where import Data.Aeson (FromJSON, ToJSON) import Data.Default (Default (..)) import GHC.Generics (Generically (..)) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as KM @@ -13,18 +14,20 @@ import Atelier.Types.WithDefaults (WithDefaults (..)) -spec_Config :: Spec -spec_Config = do - describe "extractNestedConfig" testExtractNestedConfig +test_Config :: TestTree +test_Config = + testGroup + "Config" + [ testGroup "extractNestedConfig" testExtractNestedConfig + ] -testExtractNestedConfig :: Spec -testExtractNestedConfig = do - it "should use default value for non-object Values" do +testExtractNestedConfig :: [TestTree] +testExtractNestedConfig = + [ testCase "should use default value for non-object Values" do let actual = extractNestedConfig @"foo" $ LoadedConfig $ Aeson.String "foo" - actual `shouldBe` Val "default" - - it "should fetch top-level property" do + actual @?= Val "default" + , testCase "should fetch top-level property" do let actual = extractNestedConfig @"foo" $ LoadedConfig @@ -33,16 +36,14 @@ $ Aeson.Object $ KM.singleton "value" $ Aeson.String "actual" - actual `shouldBe` Val "actual" - - it "should return default for a missing key" do + actual @?= Val "actual" + , testCase "should return default for a missing key" do let actual = extractNestedConfig @"missing" $ LoadedConfig $ Aeson.Object KM.empty - actual `shouldBe` Val "default" - - it "should fetch a nested property via dot notation" do + actual @?= Val "default" + , testCase "should fetch a nested property via dot notation" do let actual = extractNestedConfig @"foo.bar" $ LoadedConfig @@ -53,41 +54,38 @@ $ Aeson.Object $ KM.singleton "value" $ Aeson.String "nested" - actual `shouldBe` Val "nested" - - it "should return default for a missing intermediate segment" do + actual @?= Val "nested" + , testCase "should return default for a missing intermediate segment" do let actual = extractNestedConfig @"foo.bar" $ LoadedConfig $ Aeson.Object KM.empty - actual `shouldBe` Val "default" - - it "should return default for a missing leaf segment" do + actual @?= Val "default" + , testCase "should return default for a missing leaf segment" do let actual = extractNestedConfig @"foo.bar" $ LoadedConfig $ Aeson.Object $ KM.singleton "foo" $ Aeson.Object KM.empty - actual `shouldBe` Val "default" - - it "should return default when an intermediate value is not an object" do + actual @?= Val "default" + , testCase "should return default when an intermediate value is not an object" do let actual = extractNestedConfig @"foo.bar" $ LoadedConfig $ Aeson.Object $ KM.singleton "foo" $ Aeson.String "not-an-object" - actual `shouldBe` Val "default" - - it "should return default when the leaf value fails to decode" do + actual @?= Val "default" + , testCase "should return default when the leaf value fails to decode" do let actual = extractNestedConfig @"foo" $ LoadedConfig $ Aeson.Object $ KM.singleton "foo" $ Aeson.String "not-an-object" - actual `shouldBe` Val "default" + actual @?= Val "default" + ] data Val = Val {value :: Text} diff --git a/test/Unit/Atelier/Effects/AwaitSpec.hs b/test/Unit/Atelier/Effects/AwaitSpec.hs --- a/test/Unit/Atelier/Effects/AwaitSpec.hs +++ b/test/Unit/Atelier/Effects/AwaitSpec.hs @@ -1,10 +1,11 @@ -module Unit.Atelier.Effects.AwaitSpec (spec_Await) where +module Unit.Atelier.Effects.AwaitSpec (test_Await) where import Effectful (runEff, runPureEff) import Effectful.Concurrent (runConcurrent) import Effectful.State.Static.Shared (evalState, state) import Effectful.Writer.Static.Shared (runWriter, tell) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Data.List qualified as List import Effectful.Concurrent.STM qualified as STM @@ -16,55 +17,61 @@ import Atelier.Effects.Yield qualified as Yield -spec_Await :: Spec -spec_Await = do - describe "eachAwait" testEachAwait - describe "takeAwait" testTakeAwait - describe "awaitYield" testAwaitYield +test_Await :: TestTree +test_Await = + testGroup + "Await" + [ testGroup "eachAwait" testEachAwait + , testGroup "takeAwait" testTakeAwait + , testGroup "awaitYield" testAwaitYield + ] -testEachAwait :: Spec -testEachAwait = do - it "answers each await with the given action's result" do +testEachAwait :: [TestTree] +testEachAwait = + [ testCase "answers each await with the given action's result" do let xs = runPureEff . evalState @Int 0 . Await.eachAwait (state \s -> (s, s + 1)) $ replicateM 4 Await.await - xs `shouldBe` [0, 1, 2, 3] + xs @?= [0, 1, 2, 3] + ] -testTakeAwait :: Spec -testTakeAwait = do - it "yields exactly N values from the await stream" do +testTakeAwait :: [TestTree] +testTakeAwait = + [ testCase "yields exactly N values from the await stream" do let (_, xs) = runPureEff . evalState @Int 0 . Yield.yieldToList . Await.eachAwait @Int (state \s -> (s, s + 1)) $ Await.takeAwait 3 - xs `shouldBe` [0, 1, 2] - - describe "when N is zero" $ it "yields nothing" do - let (_, xs) = - runPureEff - . Yield.yieldToList - . Await.eachAwait @Int (pure 7) - $ Await.takeAwait 0 - xs `shouldBe` [] + xs @?= [0, 1, 2] + , testGroup + "when N is zero" + [ testCase "yields nothing" do + let (_, xs) = + runPureEff + . Yield.yieldToList + . Await.eachAwait @Int (pure 7) + $ Await.takeAwait 0 + xs @?= [] + ] + ] -testAwaitYield :: Spec -testAwaitYield = do - it "pipes yielded values into the await stream" do +testAwaitYield :: [TestTree] +testAwaitYield = + [ testCase "pipes yielded values into the await stream" do (_, result) <- runTest $ Await.awaitYield (Yield.inFoldable @Int [1, 2, 3] >> blockForever) $ replicateM 3 Await.await >>= tell - result `shouldBe` [1, 2, 3] - - it "returns the result of the awaiting computation" do + result @?= [1, 2, 3] + , testCase "returns the result of the awaiting computation" do -- The yielder blocks after yielding so the awaiter reliably wins the -- termination race and its 'tell' is observed; otherwise the yielder can -- finish first and cancel the awaiter before it writes (flaky under load). @@ -72,24 +79,27 @@ runTest $ Await.awaitYield @Int (Yield.yield 99 >> blockForever) $ fmap (* 2) Await.await >>= tell . List.singleton - result `shouldBe` [198] - - describe "when the awaiter finishes before the yielder" - $ it "terminates with the awaiter's result" do + result @?= [198] + , testGroup + "when the awaiter finishes before the yielder" + [ testCase "terminates with the awaiter's result" do (result, _) <- runTest . runConcurrent $ do Await.awaitYield @Int (Yield.inFoldable [1 .. 100] >> blockForever) Await.await - result `shouldBe` 1 - - describe "when the yielder finishes before the awaiter" - $ it "terminates with the yielder's result" do + result @?= 1 + ] + , testGroup + "when the yielder finishes before the awaiter" + [ testCase "terminates with the yielder's result" do (result :: Int, _) <- runTest $ Await.awaitYield @Int (Yield.yield 1 >> pure 2) $ Await.await >> Await.await >> pure 1 - result `shouldBe` 2 + result @?= 2 + ] + ] where runTest = runEff . runConcurrent . runConc . runChan . runWriter -- Block the current (forked) computation indefinitely; used to keep a yielder diff --git a/test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs b/test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs --- a/test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs +++ b/test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs @@ -1,10 +1,12 @@ -module Unit.Atelier.Effects.Cache.SingleflightSpec (spec_Singleflight) where +module Unit.Atelier.Effects.Cache.SingleflightSpec (test_Singleflight) where +import Control.Exception (try) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) import Effectful.Exception (catch, throwIO) import Effectful.State.Static.Shared (State, modify, runState) -import Test.Hspec (Spec, describe, it, shouldBe, shouldThrow) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Atelier.Effects.Cache.Singleflight (Singleflight, runSingleflight, updateCache, withCache) import Atelier.Effects.Conc (Conc, runConc) @@ -52,188 +54,200 @@ pure value -spec_Singleflight :: Spec -spec_Singleflight = do - describe "Basic Behaviors" $ do - describe "First request executes computation" $ do - it "executes the computation on first request" $ do - (result, execCount) <- runSingleflightTest $ do - withCache 1 (compute 42) - result `shouldBe` 42 - execCount `shouldBe` 1 - - describe "Cached value returned on second request" $ do - it "returns cached value without re-executing" $ do - (result, execCount) <- runSingleflightTest $ do - r1 <- withCache 1 (compute 42) - r2 <- withCache 1 (compute 42) - pure (r1, r2) - result `shouldBe` (42, 42) - execCount `shouldBe` 1 - - it "returns cached value across multiple sequential requests" $ do - (results, execCount) <- runSingleflightTest $ do - r1 <- withCache 1 (compute 42) - r2 <- withCache 1 (compute 42) - r3 <- withCache 1 (compute 42) - pure [r1, r2, r3] - results `shouldBe` [42, 42, 42] - execCount `shouldBe` 1 - - describe "Concurrent requests are deduplicated" $ do - it "executes computation once for concurrent requests" $ do - (results, execCount) <- runSingleflightTest $ do - -- Launch 10 concurrent requests for the same key - asyncs <- replicateM 10 do +test_Singleflight :: TestTree +test_Singleflight = + testGroup + "Singleflight" + [ testGroup + "Basic Behaviors" + [ testGroup + "First request executes computation" + [ testCase "executes the computation on first request" $ do + (result, execCount) <- runSingleflightTest $ do + withCache 1 (compute 42) + result @?= 42 + execCount @?= 1 + ] + , testGroup + "Cached value returned on second request" + [ testCase "returns cached value without re-executing" $ do + (result, execCount) <- runSingleflightTest $ do + r1 <- withCache 1 (compute 42) + r2 <- withCache 1 (compute 42) + pure (r1, r2) + result @?= (42, 42) + execCount @?= 1 + , testCase "returns cached value across multiple sequential requests" $ do + (results, execCount) <- runSingleflightTest $ do + r1 <- withCache 1 (compute 42) + r2 <- withCache 1 (compute 42) + r3 <- withCache 1 (compute 42) + pure [r1, r2, r3] + results @?= [42, 42, 42] + execCount @?= 1 + ] + , testGroup + "Concurrent requests are deduplicated" + [ testCase "executes computation once for concurrent requests" $ do + (results, execCount) <- runSingleflightTest $ do + -- Launch 10 concurrent requests for the same key + asyncs <- replicateM 10 do + sem <- Sem.new + async <- Conc.fork $ withCache 1 (slowCompute sem 42) + pure (sem, async) + traverse_ Sem.set $ fst <$> asyncs + traverse Conc.await $ snd <$> asyncs + all (== 42) results @?= True + length results @?= 10 + execCount @?= 1 + , testCase "all concurrent waiters receive the same result" $ do + (results, execCount) <- runSingleflightTest $ do sem <- Sem.new - async <- Conc.fork $ withCache 1 (slowCompute sem 42) - pure (sem, async) - traverse_ Sem.set $ fst <$> asyncs - traverse Conc.await $ snd <$> asyncs - all (== 42) results `shouldBe` True - length results `shouldBe` 10 - execCount `shouldBe` 1 - - it "all concurrent waiters receive the same result" $ do - (results, execCount) <- runSingleflightTest $ do - sem <- Sem.new - -- Launch concurrent requests with different delays - a1 <- Conc.fork $ withCache 1 (slowCompute sem 99) - Delay.wait (1 :: Millisecond) -- Ensure first request starts - a2 <- Conc.fork $ withCache 1 (compute 99) - a3 <- Conc.fork $ withCache 1 (compute 99) - Sem.signal sem -- Let first request continue - r1 <- Conc.await a1 - r2 <- Conc.await a2 - r3 <- Conc.await a3 - pure [r1, r2, r3] - results `shouldBe` [99, 99, 99] - execCount `shouldBe` 1 - - describe "Different keys execute independently" $ do - it "executes separate computations for different keys" $ do - (results, execCount) <- runSingleflightTest $ do - r1 <- withCache 1 (compute 10) - r2 <- withCache 2 (compute 20) - r3 <- withCache 3 (compute 30) - pure [r1, r2, r3] - results `shouldBe` [10, 20, 30] - execCount `shouldBe` 3 - - it "different keys can run concurrently" $ do - (results, execCount) <- runSingleflightTest $ do - sem <- Sem.newSet - a1 <- Conc.fork $ withCache 1 (slowCompute sem 10) - a2 <- Conc.fork $ withCache 2 (slowCompute sem 20) - a3 <- Conc.fork $ withCache 3 (slowCompute sem 30) - replicateM_ 3 $ Sem.signal sem - r1 <- Conc.await a1 - r2 <- Conc.await a2 - r3 <- Conc.await a3 - pure [r1, r2, r3] - all (\r -> r `elem` [10, 20, 30]) results `shouldBe` True - execCount `shouldBe` 3 - - describe "UpdateCache pre-populates the cache" $ do - it "returns pre-populated value without executing computation" $ do - (result, execCount) <- runSingleflightTest $ do - updateCache [(1, 99)] - withCache 1 (compute 42) - result `shouldBe` 99 - execCount `shouldBe` 0 - - it "pre-populated values are returned by subsequent requests" $ do - (results, execCount) <- runSingleflightTest $ do - updateCache [(1, 99)] - r1 <- withCache 1 (compute 42) - r2 <- withCache 1 (compute 42) - pure [r1, r2] - results `shouldBe` [99, 99] - execCount `shouldBe` 0 - - describe "UpdateCache handles multiple entries" $ do - it "correctly handles multiple key-value pairs" $ do - (results, execCount) <- runSingleflightTest $ do - updateCache [(1, 10), (2, 20), (3, 30)] - r1 <- withCache 1 (compute 99) - r2 <- withCache 2 (compute 99) - r3 <- withCache 3 (compute 99) - pure [r1, r2, r3] - results `shouldBe` [10, 20, 30] - execCount `shouldBe` 0 - - describe "All concurrent waiters receive the result" $ do - it "broadcasts result to all waiting requests" $ do - (results, execCount) <- runSingleflightTest $ do - -- Start one slow computation and many fast waiters - asyncs <- replicateM 20 do + -- Launch concurrent requests with different delays + a1 <- Conc.fork $ withCache 1 (slowCompute sem 99) + Delay.wait (1 :: Millisecond) -- Ensure first request starts + a2 <- Conc.fork $ withCache 1 (compute 99) + a3 <- Conc.fork $ withCache 1 (compute 99) + Sem.signal sem -- Let first request continue + r1 <- Conc.await a1 + r2 <- Conc.await a2 + r3 <- Conc.await a3 + pure [r1, r2, r3] + results @?= [99, 99, 99] + execCount @?= 1 + ] + , testGroup + "Different keys execute independently" + [ testCase "executes separate computations for different keys" $ do + (results, execCount) <- runSingleflightTest $ do + r1 <- withCache 1 (compute 10) + r2 <- withCache 2 (compute 20) + r3 <- withCache 3 (compute 30) + pure [r1, r2, r3] + results @?= [10, 20, 30] + execCount @?= 3 + , testCase "different keys can run concurrently" $ do + (results, execCount) <- runSingleflightTest $ do + sem <- Sem.newSet + a1 <- Conc.fork $ withCache 1 (slowCompute sem 10) + a2 <- Conc.fork $ withCache 2 (slowCompute sem 20) + a3 <- Conc.fork $ withCache 3 (slowCompute sem 30) + replicateM_ 3 $ Sem.signal sem + r1 <- Conc.await a1 + r2 <- Conc.await a2 + r3 <- Conc.await a3 + pure [r1, r2, r3] + all (\r -> r `elem` [10, 20, 30]) results @?= True + execCount @?= 3 + ] + , testGroup + "UpdateCache pre-populates the cache" + [ testCase "returns pre-populated value without executing computation" $ do + (result, execCount) <- runSingleflightTest $ do + updateCache [(1, 99)] + withCache 1 (compute 42) + result @?= 99 + execCount @?= 0 + , testCase "pre-populated values are returned by subsequent requests" $ do + (results, execCount) <- runSingleflightTest $ do + updateCache [(1, 99)] + r1 <- withCache 1 (compute 42) + r2 <- withCache 1 (compute 42) + pure [r1, r2] + results @?= [99, 99] + execCount @?= 0 + ] + , testGroup + "UpdateCache handles multiple entries" + [ testCase "correctly handles multiple key-value pairs" $ do + (results, execCount) <- runSingleflightTest $ do + updateCache [(1, 10), (2, 20), (3, 30)] + r1 <- withCache 1 (compute 99) + r2 <- withCache 2 (compute 99) + r3 <- withCache 3 (compute 99) + pure [r1, r2, r3] + results @?= [10, 20, 30] + execCount @?= 0 + ] + , testGroup + "All concurrent waiters receive the result" + [ testCase "broadcasts result to all waiting requests" $ do + (results, execCount) <- runSingleflightTest $ do + -- Start one slow computation and many fast waiters + asyncs <- replicateM 20 do + sem <- Sem.new + async <- Conc.fork $ withCache 1 (slowCompute sem 777) + pure (sem, async) + traverse_ Sem.signal $ fst <$> asyncs + traverse Conc.await $ snd <$> asyncs + all (== 777) results @?= True + length results @?= 20 + execCount @?= 1 + ] + ] + , testGroup + "Edge Cases" + [ testGroup + "Computation throws exception" + [ testCase "propagates exception to the first caller" $ do + let action = runSingleflightTest $ do + withCache @Int @Int 1 (throwIO $ TestException "boom") + result <- try action + result @?= Left (TestException "boom") + , testCase "exception does not get cached" $ do + (result, execCount) <- runSingleflightTest $ do + -- First request throws + _ <- + (withCache @Int @Int 1 (throwIO $ TestException "boom")) + `catch` \(_ :: TestException) -> pure 0 + -- Second request should re-execute + withCache 1 (compute 42) + result @?= 42 + execCount @?= 1 + , testCase "propagates exception to all concurrent waiters" $ do + let action = runSingleflightTest $ do + sem <- Sem.new + a1 <- + Conc.fork $ withCache @Int @Int 1 (slowCompute sem 42 >> throwIO (TestException "concurrent-boom")) + Delay.wait (1 :: Millisecond) + a2 <- Conc.fork $ withCache @Int @Int 1 (compute 99) + Sem.signal sem + _ <- Conc.await a1 + Conc.await a2 + result <- try action + result @?= Left (TestException "concurrent-boom") + ] + , testGroup + "UpdateCache on in-flight computation" + [ testCase "overrides result of in-flight computation" $ do + (result, execCount) <- runSingleflightTest $ do sem <- Sem.new - async <- Conc.fork $ withCache 1 (slowCompute sem 777) - pure (sem, async) - traverse_ Sem.signal $ fst <$> asyncs - traverse Conc.await $ snd <$> asyncs - all (== 777) results `shouldBe` True - length results `shouldBe` 20 - execCount `shouldBe` 1 - - describe "Edge Cases" $ do - describe "Computation throws exception" $ do - it "propagates exception to the first caller" $ do - let action = runSingleflightTest $ do - withCache @Int @Int 1 (throwIO $ TestException "boom") - action `shouldThrow` (\(TestException msg) -> msg == "boom") - - it "exception does not get cached" $ do - (result, execCount) <- runSingleflightTest $ do - -- First request throws - _ <- - (withCache @Int @Int 1 (throwIO $ TestException "boom")) - `catch` \(_ :: TestException) -> pure 0 - -- Second request should re-execute - withCache 1 (compute 42) - result `shouldBe` 42 - execCount `shouldBe` 1 - - it "propagates exception to all concurrent waiters" $ do - let action = runSingleflightTest $ do + -- Start slow computation + a1 <- Conc.fork $ withCache 1 (slowCompute sem 42) + Delay.wait (1 :: Millisecond) -- Let it start + -- Update cache while computation is running + updateCache [(1, 999)] + -- Both should get the updated value + Sem.signal sem + Conc.await a1 + result @?= 999 + execCount @?= 1 + , testCase "waiting requests receive updated value" $ do + (results, execCount) <- runSingleflightTest $ do sem <- Sem.new - a1 <- - Conc.fork $ withCache @Int @Int 1 (slowCompute sem 42 >> throwIO (TestException "concurrent-boom")) + -- Start slow computation and waiters + a1 <- Conc.fork $ withCache 1 (slowCompute sem 42) Delay.wait (1 :: Millisecond) - a2 <- Conc.fork $ withCache @Int @Int 1 (compute 99) + a2 <- Conc.fork $ withCache 1 (compute 42) + Delay.wait (1 :: Millisecond) + -- Update while they're all waiting/running + updateCache [(1, 888)] Sem.signal sem - _ <- Conc.await a1 - Conc.await a2 - action `shouldThrow` (\(TestException msg) -> msg == "concurrent-boom") - - describe "UpdateCache on in-flight computation" $ do - it "overrides result of in-flight computation" $ do - (result, execCount) <- runSingleflightTest $ do - sem <- Sem.new - -- Start slow computation - a1 <- Conc.fork $ withCache 1 (slowCompute sem 42) - Delay.wait (1 :: Millisecond) -- Let it start - -- Update cache while computation is running - updateCache [(1, 999)] - -- Both should get the updated value - Sem.signal sem - Conc.await a1 - result `shouldBe` 999 - execCount `shouldBe` 1 - - it "waiting requests receive updated value" $ do - (results, execCount) <- runSingleflightTest $ do - sem <- Sem.new - -- Start slow computation and waiters - a1 <- Conc.fork $ withCache 1 (slowCompute sem 42) - Delay.wait (1 :: Millisecond) - a2 <- Conc.fork $ withCache 1 (compute 42) - Delay.wait (1 :: Millisecond) - -- Update while they're all waiting/running - updateCache [(1, 888)] - Sem.signal sem - r1 <- Conc.await a1 - r2 <- Conc.await a2 - pure [r1, r2] - all (== 888) results `shouldBe` True - execCount `shouldBe` 1 + r1 <- Conc.await a1 + r2 <- Conc.await a2 + pure [r1, r2] + all (== 888) results @?= True + execCount @?= 1 + ] + ] + ] diff --git a/test/Unit/Atelier/Effects/CacheSpec.hs b/test/Unit/Atelier/Effects/CacheSpec.hs --- a/test/Unit/Atelier/Effects/CacheSpec.hs +++ b/test/Unit/Atelier/Effects/CacheSpec.hs @@ -1,4 +1,4 @@ -module Unit.Atelier.Effects.CacheSpec (spec_Cache) where +module Unit.Atelier.Effects.CacheSpec (test_Cache) where import Data.Time (UTCTime (..), addUTCTime, fromGregorian) import Data.Time.Clock (NominalDiffTime) @@ -6,9 +6,10 @@ import Effectful.Concurrent (runConcurrent) import Effectful.Reader.Static (runReader) import Effectful.State.Static.Shared (evalState, modify) -import Hedgehog (forAll, (===)) -import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Hspec.Hedgehog (hedgehog) +import Hedgehog (forAll, property, (===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.Hedgehog (testProperty) import Effectful.Concurrent.STM qualified as STM import Hedgehog.Gen qualified as Gen @@ -28,158 +29,153 @@ import Atelier.Effects.Log (runLogNoOp) -spec_Cache :: Spec -spec_Cache = do - describe "Basic Operations" do - it "lookup on absent key returns Nothing" do - result <- runCacheTest $ cacheLookup 1 - result `shouldBe` Nothing - - it "lookup after insert returns Just value" do - result <- runCacheTest do - cacheInsert 1 42 - cacheLookup 1 - result `shouldBe` Just 42 - - it "lookup after delete returns Nothing" do - result <- runCacheTest $ do - cacheInsert 1 42 - cacheDelete 1 - cacheLookup 1 - result `shouldBe` Nothing - - it "insert twice updates value" do - result <- runCacheTest $ do - cacheInsert 1 42 - cacheInsert 1 99 - cacheLookup 1 - result `shouldBe` Just 99 - - it "delete on absent key is a no-op" do - result <- runCacheTest $ do - cacheDelete 1 - cacheLookup 1 - result `shouldBe` Nothing - - describe "Modify" do - it "modify on absent key uses Nothing branch" do - result <- runCacheTest $ cacheModify @Int @Int 1 (maybe 0 (+ 1)) - result `shouldBe` 0 - - it "modify on present key uses Just branch" do - result <- runCacheTest $ do - cacheInsert 1 10 - cacheModify 1 (maybe 0 (+ 1)) - result `shouldBe` 11 - - it "modify returns the new value" do - result <- runCacheTest $ do - _ <- cacheModify 1 (maybe 5 (+ 5)) - cacheModify 1 (maybe 5 (+ 5)) - result `shouldBe` 10 - - describe "TTL Eviction" do - it "entry is present before TTL expires" do - result <- runBase . runCacheTestWithWait (STM.atomically STM.retry) $ do - cacheInsert 1 42 - cacheLookup 1 - result `shouldBe` Just 42 - - it "entry is evicted after cleanup thread fires past TTL" do - result <- runBase do - trigger <- STM.atomically STM.newEmptyTMVar - done <- STM.atomically STM.newEmptyTMVar - runCacheTestWithWait (cleanupBarrier done trigger) do - awaitReady done +test_Cache :: TestTree +test_Cache = + testGroup + "Cache" + [ testGroup + "Basic Operations" + [ testCase "lookup on absent key returns Nothing" do + result <- runCacheTest $ cacheLookup 1 + result @?= Nothing + , testCase "lookup after insert returns Just value" do + result <- runCacheTest do cacheInsert 1 42 - v1 <- cacheLookup 1 - modify (addUTCTime (ttl + 1)) - stepCleanup trigger done -- run one cleanup, block until it finishes - v2 <- cacheLookup 1 - pure (v1, v2) - result `shouldBe` (Just 42, Nothing) - - it "entry within TTL survives cleanup" do - result <- runBase do - trigger <- STM.atomically STM.newEmptyTMVar - done <- STM.atomically STM.newEmptyTMVar - runCacheTestWithWait (cleanupBarrier done trigger) do - awaitReady done + cacheLookup 1 + result @?= Just 42 + , testCase "lookup after delete returns Nothing" do + result <- runCacheTest $ do cacheInsert 1 42 - modify (addUTCTime (ttl - 1)) - stepCleanup trigger done + cacheDelete 1 cacheLookup 1 - result `shouldBe` Just 42 - - it "re-inserted entry retains original TTL window" do - result <- runBase do - trigger <- STM.atomically STM.newEmptyTMVar - done <- STM.atomically STM.newEmptyTMVar - runCacheTestWithWait (cleanupBarrier done trigger) do - awaitReady done + result @?= Nothing + , testCase "insert twice updates value" do + result <- runCacheTest $ do cacheInsert 1 42 - v1 <- cacheLookup 1 - - -- re-insert before TTL expires: updates value but preserves createdAt = t0 - modify (addUTCTime (ttl - 1)) - stepCleanup trigger done cacheInsert 1 99 - v2 <- cacheLookup 1 - - -- advance clock past original TTL - modify (addUTCTime 2) - stepCleanup trigger done - v3 <- cacheLookup 1 - - pure (v1, v2, v3) - -- createdAt was preserved from the first insert, so the entry is expired and evicted - result `shouldBe` (Just 42, Just 99, Nothing) - - describe "Properties" do - it "insert then lookup roundtrips value" $ hedgehog do - v <- forAll $ Gen.int (Range.linear 0 1000) - result <- liftIO $ runCacheTest $ do - cacheInsert 1 v - cacheLookup 1 - result === Just v - - it "distinct keys have independent values" $ hedgehog do - m <- forAll $ Gen.int (Range.linear 1 20) - n <- forAll $ Gen.int (Range.linear 1 20) - (a, b) <- liftIO $ runCacheTest $ do - cacheInsert 1 m - cacheInsert 2 n - va <- cacheLookup 1 - vb <- cacheLookup 2 - pure (va, vb) - a === Just m - b === Just n + cacheLookup 1 + result @?= Just 99 + , testCase "delete on absent key is a no-op" do + result <- runCacheTest $ do + cacheDelete 1 + cacheLookup 1 + result @?= Nothing + ] + , testGroup + "Modify" + [ testCase "modify on absent key uses Nothing branch" do + result <- runCacheTest $ cacheModify @Int @Int 1 (maybe 0 (+ 1)) + result @?= 0 + , testCase "modify on present key uses Just branch" do + result <- runCacheTest $ do + cacheInsert 1 10 + cacheModify 1 (maybe 0 (+ 1)) + result @?= 11 + , testCase "modify returns the new value" do + result <- runCacheTest $ do + _ <- cacheModify 1 (maybe 5 (+ 5)) + cacheModify 1 (maybe 5 (+ 5)) + result @?= 10 + ] + , testGroup + "TTL Eviction" + [ testCase "entry is present before TTL expires" do + result <- runBase . runCacheTestWithWait (STM.atomically STM.retry) $ do + cacheInsert 1 42 + cacheLookup 1 + result @?= Just 42 + , testCase "entry is evicted after cleanup thread fires past TTL" do + result <- runBase do + trigger <- STM.atomically STM.newEmptyTMVar + done <- STM.atomically STM.newEmptyTMVar + runCacheTestWithWait (cleanupBarrier done trigger) do + awaitReady done + cacheInsert 1 42 + v1 <- cacheLookup 1 + modify (addUTCTime (ttl + 1)) + stepCleanup trigger done -- run one cleanup, block until it finishes + v2 <- cacheLookup 1 + pure (v1, v2) + result @?= (Just 42, Nothing) + , testCase "entry within TTL survives cleanup" do + result <- runBase do + trigger <- STM.atomically STM.newEmptyTMVar + done <- STM.atomically STM.newEmptyTMVar + runCacheTestWithWait (cleanupBarrier done trigger) do + awaitReady done + cacheInsert 1 42 + modify (addUTCTime (ttl - 1)) + stepCleanup trigger done + cacheLookup 1 + result @?= Just 42 + , testCase "re-inserted entry retains original TTL window" do + result <- runBase do + trigger <- STM.atomically STM.newEmptyTMVar + done <- STM.atomically STM.newEmptyTMVar + runCacheTestWithWait (cleanupBarrier done trigger) do + awaitReady done + cacheInsert 1 42 + v1 <- cacheLookup 1 - it "interleaved key access is independent" $ hedgehog do - keys <- forAll $ Gen.list (Range.linear 1 50) Gen.bool - -- count inserts per key by interleaving - counts <- liftIO $ runCacheTest $ do - let step True = cacheModify @Int 1 (maybe 1 (+ 1)) - step False = cacheModify @Int 2 (maybe 1 (+ 1)) - traverse step keys - let key1Counts = [c | (k, c) <- zip keys counts, k] - key2Counts = [c | (k, c) <- zip keys counts, not k] - key1Counts === [1 .. length key1Counts] - key2Counts === [1 .. length key2Counts] + -- re-insert before TTL expires: updates value but preserves createdAt = t0 + modify (addUTCTime (ttl - 1)) + stepCleanup trigger done + cacheInsert 1 99 + v2 <- cacheLookup 1 - it "concurrent inserts to different keys don't interfere" $ hedgehog do - n <- forAll $ Gen.int (Range.linear 1 20) - results <- liftIO $ runCacheTest $ do - for_ [1 .. n] \i -> cacheInsert i i - traverse (\i -> cacheLookup i) [1 .. n] - results === map (Just . id) [1 .. n] + -- advance clock past original TTL + modify (addUTCTime 2) + stepCleanup trigger done + v3 <- cacheLookup 1 - it "modify is atomic under concurrency" $ hedgehog do - n <- forAll $ Gen.int (Range.linear 1 50) - finalVal <- liftIO $ runCacheTest $ do - for_ [1 .. n] \_ -> cacheModify 1 (maybe 1 (+ 1)) - cacheLookup 1 - finalVal === Just n + pure (v1, v2, v3) + -- createdAt was preserved from the first insert, so the entry is expired and evicted + result @?= (Just 42, Just 99, Nothing) + ] + , testGroup + "Properties" + [ testProperty "insert then lookup roundtrips value" $ property do + v <- forAll $ Gen.int (Range.linear 0 1000) + result <- liftIO $ runCacheTest $ do + cacheInsert 1 v + cacheLookup 1 + result === Just v + , testProperty "distinct keys have independent values" $ property do + m <- forAll $ Gen.int (Range.linear 1 20) + n <- forAll $ Gen.int (Range.linear 1 20) + (a, b) <- liftIO $ runCacheTest $ do + cacheInsert 1 m + cacheInsert 2 n + va <- cacheLookup 1 + vb <- cacheLookup 2 + pure (va, vb) + a === Just m + b === Just n + , testProperty "interleaved key access is independent" $ property do + keys <- forAll $ Gen.list (Range.linear 1 50) Gen.bool + -- count inserts per key by interleaving + counts <- liftIO $ runCacheTest $ do + let step True = cacheModify @Int 1 (maybe 1 (+ 1)) + step False = cacheModify @Int 2 (maybe 1 (+ 1)) + traverse step keys + let key1Counts = [c | (k, c) <- zip keys counts, k] + key2Counts = [c | (k, c) <- zip keys counts, not k] + key1Counts === [1 .. length key1Counts] + key2Counts === [1 .. length key2Counts] + , testProperty "concurrent inserts to different keys don't interfere" $ property do + n <- forAll $ Gen.int (Range.linear 1 20) + results <- liftIO $ runCacheTest $ do + for_ [1 .. n] \i -> cacheInsert i i + traverse (\i -> cacheLookup i) [1 .. n] + results === map (Just . id) [1 .. n] + , testProperty "modify is atomic under concurrency" $ property do + n <- forAll $ Gen.int (Range.linear 1 50) + finalVal <- liftIO $ runCacheTest $ do + for_ [1 .. n] \_ -> cacheModify 1 (maybe 1 (+ 1)) + cacheLookup 1 + finalVal === Just n + ] + ] where runBase = runEff . runConcurrent runCacheTest = runBase . runCacheTestWithWait (STM.atomically STM.retry) diff --git a/test/Unit/Atelier/Effects/ChanSpec.hs b/test/Unit/Atelier/Effects/ChanSpec.hs --- a/test/Unit/Atelier/Effects/ChanSpec.hs +++ b/test/Unit/Atelier/Effects/ChanSpec.hs @@ -1,10 +1,11 @@ -module Unit.Atelier.Effects.ChanSpec (spec_Chan) where +module Unit.Atelier.Effects.ChanSpec (test_Chan) where import Effectful (IOE, runEff) import Effectful.Timeout (Timeout, runTimeout) -import Hedgehog (forAll, (===)) -import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Hspec.Hedgehog (hedgehog) +import Hedgehog (forAll, property, (===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.Hedgehog (testProperty) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -13,68 +14,73 @@ import Atelier.Time (Millisecond, Second) -spec_Chan :: Spec -spec_Chan = do - describe "Basic Operations" do - it "writeChan then readChan roundtrips a value" do - result <- runChanTest $ do - (inChan, outChan) <- newChan - writeChan inChan (42 :: Int) - readChan outChan - result `shouldBe` 42 - - it "preserves FIFO order" $ hedgehog do - xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int Range.linearBounded) - result <- liftIO $ runChanTest $ do - (inChan, outChan) <- newChan - traverse_ (writeChan inChan) xs - replicateM (length xs) (readChan outChan) - result === xs - - it "dupChan creates an independent reader that receives the same messages" do - result <- runChanTest $ do - (inChan, outChan1) <- newChan - outChan2 <- dupChan inChan - writeChan inChan (42 :: Int) - v1 <- readChan outChan1 - v2 <- readChan outChan2 - pure (v1, v2) - result `shouldBe` (42, 42) - - describe "readChanBatched" do - describe "when items fill the batch before timeout" do - it "returns a full batch" do +test_Chan :: TestTree +test_Chan = + testGroup + "Chan" + [ testGroup + "Basic Operations" + [ testCase "writeChan then readChan roundtrips a value" do result <- runChanTest $ do (inChan, outChan) <- newChan - traverse_ (writeChan inChan) [1, 2, 3 :: Int] - readChanBatched (1 :: Second) 3 outChan - result `shouldBe` (1 :| [2, 3]) - - it "caps at batchSize even when more items are available" $ hedgehog do - batchSize <- forAll $ Gen.int (Range.linear 1 20) - extra <- forAll $ Gen.int (Range.linear 1 10) - let n = batchSize + extra + writeChan inChan (42 :: Int) + readChan outChan + result @?= 42 + , testProperty "preserves FIFO order" $ property do + xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int Range.linearBounded) result <- liftIO $ runChanTest $ do (inChan, outChan) <- newChan - traverse_ (writeChan inChan) [1 .. n] - readChanBatched (1 :: Second) batchSize outChan - length result === batchSize - - describe "when timeout fires before batch is full" do - it "returns a singleton when only one item is in the channel" do - result <- runChanTest $ do - (inChan, outChan) <- newChan - writeChan inChan (1 :: Int) - readChanBatched (1 :: Millisecond) 5 outChan - result `shouldBe` (1 :| []) - - it "returns a partial batch" do + traverse_ (writeChan inChan) xs + replicateM (length xs) (readChan outChan) + result === xs + , testCase "dupChan creates an independent reader that receives the same messages" do result <- runChanTest $ do - (inChan, outChan) <- newChan - writeChan inChan (1 :: Int) - writeChan inChan 2 - readChanBatched (1 :: Millisecond) 5 outChan - result `shouldBe` (1 :| [2]) + (inChan, outChan1) <- newChan + outChan2 <- dupChan inChan + writeChan inChan (42 :: Int) + v1 <- readChan outChan1 + v2 <- readChan outChan2 + pure (v1, v2) + result @?= (42, 42) + ] + , testGroup + "readChanBatched" + [ testGroup + "when items fill the batch before timeout" + [ testCase "returns a full batch" do + result <- runChanTest $ do + (inChan, outChan) <- newChan + traverse_ (writeChan inChan) [1, 2, 3 :: Int] + readChanBatched (1 :: Second) 3 outChan + result @?= (1 :| [2, 3]) + , testProperty "caps at batchSize even when more items are available" $ property do + batchSize <- forAll $ Gen.int (Range.linear 1 20) + extra <- forAll $ Gen.int (Range.linear 1 10) + let n = batchSize + extra + result <- liftIO $ runChanTest $ do + (inChan, outChan) <- newChan + traverse_ (writeChan inChan) [1 .. n] + readChanBatched (1 :: Second) batchSize outChan + length result === batchSize + ] + , testGroup + "when timeout fires before batch is full" + [ testCase "returns a singleton when only one item is in the channel" do + result <- runChanTest $ do + (inChan, outChan) <- newChan + writeChan inChan (1 :: Int) + readChanBatched (1 :: Millisecond) 5 outChan + result @?= (1 :| []) + , testCase "returns a partial batch" do + result <- runChanTest $ do + (inChan, outChan) <- newChan + writeChan inChan (1 :: Int) + writeChan inChan 2 + readChanBatched (1 :: Millisecond) 5 outChan + result @?= (1 :| [2]) + ] + ] + ] -------------------------------------------------------------------------------- diff --git a/test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs b/test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs --- a/test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs +++ b/test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs @@ -13,7 +13,7 @@ -- @ATELIER_CONC_STRESS_N@ (crank it up under @yes@-load to reproduce). Each -- test is wrapped in a 'timeout' so a real teardown hang fails loudly instead -- of wedging the run. -module Unit.Atelier.Effects.Conc.TeardownStressSpec (spec_ConcTeardownStress) where +module Unit.Atelier.Effects.Conc.TeardownStressSpec (test_ConcTeardownStress) where import Control.Concurrent (threadDelay) import Control.Exception (evaluate) @@ -22,7 +22,8 @@ import Effectful.Concurrent.STM (atomically, retry) import System.Environment (lookupEnv) import System.Timeout (timeout) -import Test.Hspec (Spec, describe, it, runIO, shouldBe) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Atelier.Effects.Chan (Chan, runChan) import Atelier.Effects.Clock (Clock, runClock) @@ -35,74 +36,80 @@ import Atelier.Effects.Publishing.Pub qualified as Pub -spec_ConcTeardownStress :: Spec -spec_ConcTeardownStress = do +test_ConcTeardownStress :: IO TestTree +test_ConcTeardownStress = do iterations <- - runIO (fromMaybe defaultIterations . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_N") + fromMaybe defaultIterations . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_N" timeoutSecs <- - runIO (fromMaybe defaultTimeoutSecs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_TIMEOUT_S") - runSpin <- runIO (isJust <$> lookupEnv "ATELIER_CONC_SPIN") + fromMaybe defaultTimeoutSecs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_TIMEOUT_S" + runSpin <- isJust <$> lookupEnv "ATELIER_CONC_SPIN" publishDelayUs <- - runIO - (fromMaybe defaultPublishDelayUs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_DELAY_US") + fromMaybe defaultPublishDelayUs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_DELAY_US" let testTimeoutMicros = timeoutSecs * 1_000_000 - describe "Conc.scoped teardown stress" do - it "reaps an STM-blocked fork_ across many scopes" do - completed <- - timeout testTimeoutMicros - $ runConcTest - $ replicateM_ iterations - $ scoped (void (fork_ blockForever)) - completed `shouldBe` Just () - - it "reaps a two-child scope (one parked, one transient) across many scopes" do - completed <- - timeout testTimeoutMicros - $ runConcTest - $ replicateM_ iterations - $ scoped do - _ <- fork (liftIO (threadDelay 5)) - void (fork_ blockForever) - completed `shouldBe` Just () - - -- Faithful repro of the actual full-suite victim: the 'fromEvents' Iterator - -- pattern over its real effect stack, looped. The producer's 10us delay is - -- the ONLY thing giving the forked listener time to subscribe before the - -- first publish; under load that race can drop early events and wedge the - -- consumer's 'Iter.next' (it reads exactly as many as were published, so any - -- dropped event blocks forever). Also exercises the deep-stack - -- 'Conc.scoped' unlift/teardown that the bare tests above strip away. - describe "fromEvents Iterator pattern stress (full stack)" do - it "drives the producer/listener fromEvents scope across many iterations" do - completed <- - timeout testTimeoutMicros - $ runIterTest - $ replicateM_ iterations - $ Iter.fromEvents @Int \iter -> do - _ <- fork do - liftIO (threadDelay publishDelayUs) - traverse_ Pub.publish [1, 2, 3 :: Int] - _ <- replicateM 3 (Iter.next iter) - pure () - completed `shouldBe` Just () - - -- A non-allocating fork_ is UN-KILLABLE under -O: -fomit-yields strips the - -- loop's safe point, so the async exception Ki throws at scope close — and - -- the one 'timeout' would throw — can never be delivered. It would wedge an - -- optimized build permanently and burn a core. Hence opt-in, and only safe - -- on a -O0 build (where the boxed-Int loop still allocates and stays - -- killable). This is the discriminating probe for the omit-yields theory. - when runSpin - $ describe "Conc.scoped teardown of a NON-ALLOCATING fork_ (ATELIER_CONC_SPIN=1; -O0 only)" do - it "reaps a non-allocating spin at scope exit" do - completed <- - timeout testTimeoutMicros - $ runConcTest - $ scoped (void (fork_ nonAllocatingSpin)) - completed `shouldBe` Just () + pure + $ testGroup "ConcTeardownStress" + $ [ testGroup + "Conc.scoped teardown stress" + [ testCase "reaps an STM-blocked fork_ across many scopes" do + completed <- + timeout testTimeoutMicros + $ runConcTest + $ replicateM_ iterations + $ scoped (void (fork_ blockForever)) + completed @?= Just () + , testCase "reaps a two-child scope (one parked, one transient) across many scopes" do + completed <- + timeout testTimeoutMicros + $ runConcTest + $ replicateM_ iterations + $ scoped do + _ <- fork (liftIO (threadDelay 5)) + void (fork_ blockForever) + completed @?= Just () + ] + , -- Faithful repro of the actual full-suite victim: the 'fromEvents' Iterator + -- pattern over its real effect stack, looped. The producer's 10us delay is + -- the ONLY thing giving the forked listener time to subscribe before the + -- first publish; under load that race can drop early events and wedge the + -- consumer's 'Iter.next' (it reads exactly as many as were published, so any + -- dropped event blocks forever). Also exercises the deep-stack + -- 'Conc.scoped' unlift/teardown that the bare tests above strip away. + testGroup + "fromEvents Iterator pattern stress (full stack)" + [ testCase "drives the producer/listener fromEvents scope across many iterations" do + completed <- + timeout testTimeoutMicros + $ runIterTest + $ replicateM_ iterations + $ Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO (threadDelay publishDelayUs) + traverse_ Pub.publish [1, 2, 3 :: Int] + _ <- replicateM 3 (Iter.next iter) + pure () + completed @?= Just () + ] + ] + -- A non-allocating fork_ is UN-KILLABLE under -O: -fomit-yields strips the + -- loop's safe point, so the async exception Ki throws at scope close — and + -- the one 'timeout' would throw — can never be delivered. It would wedge an + -- optimized build permanently and burn a core. Hence opt-in, and only safe + -- on a -O0 build (where the boxed-Int loop still allocates and stays + -- killable). This is the discriminating probe for the omit-yields theory. + <> [ testGroup + "Conc.scoped teardown of a NON-ALLOCATING fork_ (ATELIER_CONC_SPIN=1; -O0 only)" + [ testCase "reaps a non-allocating spin at scope exit" do + completed <- + timeout testTimeoutMicros + $ runConcTest + $ scoped (void (fork_ nonAllocatingSpin)) + completed @?= Just () + ] + | runSpin + ] where defaultIterations = 300 :: Int defaultTimeoutSecs = 15 :: Int diff --git a/test/Unit/Atelier/Effects/ConcSpec.hs b/test/Unit/Atelier/Effects/ConcSpec.hs --- a/test/Unit/Atelier/Effects/ConcSpec.hs +++ b/test/Unit/Atelier/Effects/ConcSpec.hs @@ -1,12 +1,13 @@ -module Unit.Atelier.Effects.ConcSpec (spec_Conc) where +module Unit.Atelier.Effects.ConcSpec (test_Conc) where -import Control.Exception (ErrorCall (..), throwIO) +import Control.Exception (ErrorCall (..), throwIO, try) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) import Effectful.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, retry) -import Hedgehog (forAll, (===)) -import Test.Hspec (Spec, anyException, context, describe, it, shouldBe, shouldSatisfy, shouldThrow) -import Test.Hspec.Hedgehog (hedgehog) +import Hedgehog (forAll, property, (===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import Test.Tasty.Hedgehog (testProperty) import Data.IORef qualified as IORef import Hedgehog.Gen qualified as Gen @@ -19,98 +20,109 @@ import Atelier.Effects.Delay qualified as Delay -spec_Conc :: Spec -spec_Conc = do - describe "Thread cleanup" do - context "without scoped" do - it "demonstrates thread lifetime" $ runTest do - -- This test shows threads live for the duration of their scope - counter <- newTVarIO (0 :: Int) - - -- Thread we fork here will live until the root scope (in - -- 'runTest') exits. - fork_ $ forever $ atomically $ modifyTVar' counter (+ 1) - - let waitFor n = atomically do - v <- readTVar counter - if v >= n then pure v else retry - - countAfter <- waitFor 1 - finalCount <- waitFor (countAfter + 1) - - liftIO $ finalCount `shouldSatisfy` (> countAfter) - - context "with scoped" do - it "kills nested threads when scope exits" $ runTest do - counter <- newTVarIO (0 :: Int) - - let waitFor n = atomically do - v <- readTVar counter - if v >= n then pure v else retry +test_Conc :: TestTree +test_Conc = + testGroup + "Conc" + [ testGroup + "Thread cleanup" + [ testGroup + "without scoped" + [ testCase "demonstrates thread lifetime" $ runTest do + -- This test shows threads live for the duration of their scope + counter <- newTVarIO (0 :: Int) - -- Create nested scope that will clean up its threads - scoped do + -- Thread we fork here will live until the root scope (in + -- 'runTest') exits. fork_ $ forever $ atomically $ modifyTVar' counter (+ 1) - -- Ensure the thread has incremented at least once - _ <- waitFor 1 - pure () - -- Inner scope exits here - thread should be KILLED - -- Capture count after scope exit - countAfter <- atomically $ readTVar counter - - -- Give any leaked thread a brief window to advance the counter - Delay.wait (1 :: Millisecond) + let waitFor n = atomically do + v <- readTVar counter + if v >= n then pure v else retry - -- Count should NOT increase after scope exit - finalCount <- atomically $ readTVar counter + countAfter <- waitFor 1 + finalCount <- waitFor (countAfter + 1) - liftIO $ finalCount `shouldBe` countAfter + liftIO $ assertBool "expected the thread to keep running" $ finalCount > countAfter + ] + , testGroup + "with scoped" + [ testCase "kills nested threads when scope exits" $ runTest do + counter <- newTVarIO (0 :: Int) - describe "fork and await" do - it "returns the result of the forked computation" do - result <- runTestSimple $ do - t <- fork $ pure (42 :: Int) - await t - result `shouldBe` 42 + let waitFor n = atomically do + v <- readTVar counter + if v >= n then pure v else retry - it "executes the forked action" do - result <- runTestSimple $ do - ref <- liftIO $ IORef.newIORef False - t <- fork $ liftIO $ IORef.writeIORef ref True - await t - liftIO $ IORef.readIORef ref - result `shouldBe` True + -- Create nested scope that will clean up its threads + scoped do + fork_ $ forever $ atomically $ modifyTVar' counter (+ 1) + -- Ensure the thread has incremented at least once + _ <- waitFor 1 + pure () + -- Inner scope exits here - thread should be KILLED - describe "awaitAll" do - it "waits for all forked threads to complete" $ hedgehog do - n <- forAll $ Gen.int (Range.linear 1 20) - result <- liftIO $ runTestSimple $ do - ref <- liftIO $ IORef.newIORef (0 :: Int) - replicateM_ n $ fork $ liftIO $ IORef.atomicModifyIORef' ref (\x -> (x + 1, ())) - awaitAll - liftIO $ IORef.readIORef ref - result === n + -- Capture count after scope exit + countAfter <- atomically $ readTVar counter - describe "forkTry" do - it "returns Right for a successful computation" do - result <- runTestSimple $ do - t <- forkTry @ErrorCall $ pure (42 :: Int) - await t - result `shouldBe` Right 42 + -- Give any leaked thread a brief window to advance the counter + Delay.wait (1 :: Millisecond) - it "returns Left when the forked thread throws" do - result <- runTestSimple $ do - t <- forkTry @ErrorCall $ liftIO $ throwIO $ ErrorCall "boom" - await t - (result :: Either ErrorCall Int) `shouldSatisfy` isLeft + -- Count should NOT increase after scope exit + finalCount <- atomically $ readTVar counter - describe "exception propagation" do - it "uncaught exception in forked thread propagates to the scope" do - let action = runTestSimple $ do - _ <- fork $ liftIO $ throwIO $ ErrorCall "boom" + liftIO $ finalCount @?= countAfter + ] + ] + , testGroup + "fork and await" + [ testCase "returns the result of the forked computation" do + result <- runTestSimple $ do + t <- fork $ pure (42 :: Int) + await t + result @?= 42 + , testCase "executes the forked action" do + result <- runTestSimple $ do + ref <- liftIO $ IORef.newIORef False + t <- fork $ liftIO $ IORef.writeIORef ref True + await t + liftIO $ IORef.readIORef ref + result @?= True + ] + , testGroup + "awaitAll" + [ testProperty "waits for all forked threads to complete" $ property do + n <- forAll $ Gen.int (Range.linear 1 20) + result <- liftIO $ runTestSimple $ do + ref <- liftIO $ IORef.newIORef (0 :: Int) + replicateM_ n $ fork $ liftIO $ IORef.atomicModifyIORef' ref (\x -> (x + 1, ())) awaitAll - action `shouldThrow` anyException + liftIO $ IORef.readIORef ref + result === n + ] + , testGroup + "forkTry" + [ testCase "returns Right for a successful computation" do + result <- runTestSimple $ do + t <- forkTry @ErrorCall $ pure (42 :: Int) + await t + result @?= Right 42 + , testCase "returns Left when the forked thread throws" do + result <- runTestSimple $ do + t <- forkTry @ErrorCall $ liftIO $ throwIO $ ErrorCall "boom" + await t + assertBool "expected Left" $ isLeft (result :: Either ErrorCall Int) + ] + , testGroup + "exception propagation" + [ testCase "uncaught exception in forked thread propagates to the scope" do + let action = runTestSimple $ do + _ <- fork $ liftIO $ throwIO $ ErrorCall "boom" + awaitAll + result <- try @SomeException action + isLeft result @?= True + ] + ] -------------------------------------------------------------------------------- diff --git a/test/Unit/Atelier/Effects/ConsoleSpec.hs b/test/Unit/Atelier/Effects/ConsoleSpec.hs --- a/test/Unit/Atelier/Effects/ConsoleSpec.hs +++ b/test/Unit/Atelier/Effects/ConsoleSpec.hs @@ -1,40 +1,48 @@ -module Unit.Atelier.Effects.ConsoleSpec (spec_Console) where +module Unit.Atelier.Effects.ConsoleSpec (test_Console) where import Effectful (runPureEff) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Atelier.Effects.Console (runConsoleToList) import Atelier.Effects.Console qualified as Console -spec_Console :: Spec -spec_Console = do - describe "runConsoleToList" $ do - describe "when nothing is logged" $ it "returns an empty list" $ do - let (_, msgs) = runPureEff $ runConsoleToList $ pure () - msgs `shouldBe` [] - - describe "when logging once" $ it "collects a single traced message" $ do - let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStr "hello" - msgs `shouldBe` ["hello"] - - it "collects multiple logged messages in order" $ do - let (_, msgs) = - runPureEff . runConsoleToList $ do - Console.putStr "first" - Console.putStr "second" - Console.putStr "third" - msgs `shouldBe` ["first", "second", "third"] - - it "returns the result alongside the traced messages" $ do - let (result, msgs) = - runPureEff . runConsoleToList $ do - Console.putStr "side effect" - pure (42 :: Int) - result `shouldBe` 42 - msgs `shouldBe` ["side effect"] - - it "traceLn appends a newline to the message" $ do - let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStrLn "line" - msgs `shouldBe` ["line\n"] +test_Console :: TestTree +test_Console = + testGroup + "Console" + [ testGroup + "runConsoleToList" + [ testGroup + "when nothing is logged" + [ testCase "returns an empty list" $ do + let (_, msgs) = runPureEff $ runConsoleToList $ pure () + msgs @?= [] + ] + , testGroup + "when logging once" + [ testCase "collects a single traced message" $ do + let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStr "hello" + msgs @?= ["hello"] + ] + , testCase "collects multiple logged messages in order" $ do + let (_, msgs) = + runPureEff . runConsoleToList $ do + Console.putStr "first" + Console.putStr "second" + Console.putStr "third" + msgs @?= ["first", "second", "third"] + , testCase "returns the result alongside the traced messages" $ do + let (result, msgs) = + runPureEff . runConsoleToList $ do + Console.putStr "side effect" + pure (42 :: Int) + result @?= 42 + msgs @?= ["side effect"] + , testCase "traceLn appends a newline to the message" $ do + let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStrLn "line" + msgs @?= ["line\n"] + ] + ] diff --git a/test/Unit/Atelier/Effects/DebounceSpec.hs b/test/Unit/Atelier/Effects/DebounceSpec.hs --- a/test/Unit/Atelier/Effects/DebounceSpec.hs +++ b/test/Unit/Atelier/Effects/DebounceSpec.hs @@ -1,9 +1,10 @@ -module Unit.Atelier.Effects.DebounceSpec (spec_Debounce) where +module Unit.Atelier.Effects.DebounceSpec (test_Debounce) where import Data.Dynamic (fromDynamic, toDyn) import Effectful (runEff) import Effectful.Concurrent (runConcurrent) -import Test.Hspec +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) import Data.IORef qualified as IORef import Effectful.Concurrent.STM qualified as STM @@ -26,71 +27,77 @@ import Atelier.Effects.Delay qualified as Delay -spec_Debounce :: Spec -spec_Debounce = do - describe "runDebounce" testRunDebounce - describe "ensureEntry" testEnsureEntry - describe "ensureCallback" testEnsureCallback +test_Debounce :: TestTree +test_Debounce = + testGroup + "Debounce" + [ testGroup "runDebounce" testRunDebounce + , testGroup "ensureEntry" testEnsureEntry + , testGroup "ensureCallback" testEnsureCallback + ] -testEnsureEntry :: Spec -testEnsureEntry = do - describe "new key" do - it "gets generation 0" do +testEnsureEntry :: [TestTree] +testEnsureEntry = + [ testGroup + "new key" + [ testCase "gets generation 0" do state <- runSTM Map.new entry <- runSTM $ mkEntry 1 42 state (+) - entry.generation `shouldBe` 0 - - it "stores value as arg" do + entry.generation @?= 0 + , testCase "stores value as arg" do state <- runSTM Map.new entry <- runSTM $ mkEntry 1 42 state (+) - (entry.arg >>= fromDynamic) `shouldBe` Just @Int 42 - - describe "existing key" do - it "increments generation" do + (entry.arg >>= fromDynamic) @?= Just @Int 42 + ] + , testGroup + "existing key" + [ testCase "increments generation" do state <- runSTM Map.new _ <- runSTM $ mkEntry 1 2 state (+) entry <- runSTM $ mkEntry 1 3 state (+) - entry.generation `shouldBe` 1 - - it "applies merge function to old and new value" do + entry.generation @?= 1 + , testCase "applies merge function to old and new value" do state <- runSTM Map.new _ <- runSTM $ mkEntry 1 5 state (+) entry <- runSTM $ mkEntry 1 10 state (+) - (entry.arg >>= fromDynamic) `shouldBe` Just @Int 15 - - describe "multiple updates" do - it "accumulates generation" do + (entry.arg >>= fromDynamic) @?= Just @Int 15 + ] + , testGroup + "multiple updates" + [ testCase "accumulates generation" do state <- runSTM Map.new _ <- runSTM $ mkEntry 1 1 state (+) _ <- runSTM $ mkEntry 1 2 state (+) entry <- runSTM $ mkEntry 1 3 state (+) - entry.generation `shouldBe` 2 - - it "applies merge cumulatively" do + entry.generation @?= 2 + , testCase "applies merge cumulatively" do state <- runSTM Map.new _ <- runSTM $ mkEntry 1 1 state (+) _ <- runSTM $ mkEntry 1 2 state (+) entry <- runSTM $ mkEntry 1 3 state (+) - (entry.arg >>= fromDynamic) `shouldBe` Just @Int 6 - - describe "independent keys" do - it "do not interfere with each other" do + (entry.arg >>= fromDynamic) @?= Just @Int 6 + ] + , testGroup + "independent keys" + [ testCase "do not interfere with each other" do state <- runSTM Map.new entryA <- runSTM $ mkEntry 1 10 state (+) entryB <- runSTM $ mkEntry 2 20 state (+) - (entryA.arg >>= fromDynamic) `shouldBe` Just @Int 10 - (entryB.arg >>= fromDynamic) `shouldBe` Just @Int 20 - entryA.generation `shouldBe` 0 - entryB.generation `shouldBe` 0 + (entryA.arg >>= fromDynamic) @?= Just @Int 10 + (entryB.arg >>= fromDynamic) @?= Just @Int 20 + entryA.generation @?= 0 + entryB.generation @?= 0 + ] + ] where mkEntry = ensureEntry @Int @Int runSTM action = runEff . runConcurrent $ STM.atomically action -testEnsureCallback :: Spec -testEnsureCallback = do - it "fires callback when entry's generation still matches" do +testEnsureCallback :: [TestTree] +testEnsureCallback = + [ testCase "fires callback when entry's generation still matches" do actual <- runCallbackTest do state <- STM.atomically Map.new STM.atomically $ Map.insert (entry 0) (1 :: Int) state @@ -101,20 +108,21 @@ $ liftIO . IORef.writeIORef ref Conc.await t liftIO $ IORef.readIORef ref - actual `shouldBe` 10 - it "skips callback when generation has been bumped" do + actual @?= 10 + , testCase "skips callback when generation has been bumped" do runCallbackTest do state <- STM.atomically Map.new -- A newer event has already bumped generation to 1 STM.atomically $ Map.insert (entry 1) (1 :: Int) state -- This fork was scheduled for generation 0; it should skip ensureCallback @Int @Int 1 state 1 0 \_ -> - liftIO $ False `shouldBe` True - it "skips callback when entry has been removed" do + liftIO $ False @?= True + , testCase "skips callback when entry has been removed" do runCallbackTest do state <- STM.atomically Map.new ensureCallback @Int @Int 1 state 1 0 \_ -> - liftIO $ False `shouldBe` True + liftIO $ False @?= True + ] where runCallbackTest = runEff @@ -135,62 +143,76 @@ -- fires. Multi-burst tests sequence by waiting for each burst's fire, so bursts -- cannot merge regardless of timing. A short grace after the fire guards against -- a spurious second fire. -testRunDebounce :: Spec -testRunDebounce = do - describe "debounced" do - describe "when invoked once" $ it "fires once" do - n <- runTest do - (count, fired) <- newCounter - debounced 50 () (bump count fired) - awaitFire fired - Delay.wait @Millisecond 80 - readCount count - n `shouldBe` 1 - - describe "when invoked multiple times" $ it "fires once" do - n <- runTest do - (count, fired) <- newCounter - debounced 50 () (bump count fired) - debounced 50 () (bump count fired) - debounced 50 () (bump count fired) - awaitFire fired - Delay.wait @Millisecond 80 - readCount count - n `shouldBe` 1 - - describe "when invoked multiple times with a delay between" $ it "fires once per burst" do - n <- runTest do - (count, fired) <- newCounter - debounced 50 () (bump count fired) - debounced 50 () (bump count fired) - awaitFire fired -- burst 1 settled and cleared the entry - debounced 50 () (bump count fired) - debounced 50 () (bump count fired) - awaitFire fired -- burst 2 is therefore independent - readCount count - n `shouldBe` 2 - - describe "when invoked many times" $ it "should not crash" do - n <- runTest do - (count, fired) <- newCounter - replicateM_ 10_000 $ debounced 50 () (bump count fired) - awaitFire fired - Delay.wait @Millisecond 80 - readCount count - n `shouldBe` 1 - - describe "debouncedWith" do - describe "when invoked once" $ it "fires callback with the provided arg" do - got <- runTest do - result <- STM.atomically STM.newEmptyTMVar - debouncedWith 50 (+) () (42 :: Int) (signal result) - awaitValue result - got `shouldBe` Just 42 - - describe "when invoked multiple times rapidly" do - it "fires once" do +testRunDebounce :: [TestTree] +testRunDebounce = + [ testGroup + "debounced" + [ testGroup + "when invoked once" + [ testCase "fires once" do n <- runTest do (count, fired) <- newCounter + debounced 50 () (bump count fired) + awaitFire fired + Delay.wait @Millisecond 80 + readCount count + n @?= 1 + ] + , testGroup + "when invoked multiple times" + [ testCase "fires once" do + n <- runTest do + (count, fired) <- newCounter + debounced 50 () (bump count fired) + debounced 50 () (bump count fired) + debounced 50 () (bump count fired) + awaitFire fired + Delay.wait @Millisecond 80 + readCount count + n @?= 1 + ] + , testGroup + "when invoked multiple times with a delay between" + [ testCase "fires once per burst" do + n <- runTest do + (count, fired) <- newCounter + debounced 50 () (bump count fired) + debounced 50 () (bump count fired) + awaitFire fired -- burst 1 settled and cleared the entry + debounced 50 () (bump count fired) + debounced 50 () (bump count fired) + awaitFire fired -- burst 2 is therefore independent + readCount count + n @?= 2 + ] + , testGroup + "when invoked many times" + [ testCase "should not crash" do + n <- runTest do + (count, fired) <- newCounter + replicateM_ 10_000 $ debounced 50 () (bump count fired) + awaitFire fired + Delay.wait @Millisecond 80 + readCount count + n @?= 1 + ] + ] + , testGroup + "debouncedWith" + [ testGroup + "when invoked once" + [ testCase "fires callback with the provided arg" do + got <- runTest do + result <- STM.atomically STM.newEmptyTMVar + debouncedWith 50 (+) () (42 :: Int) (signal result) + awaitValue result + got @?= Just 42 + ] + , testGroup + "when invoked multiple times rapidly" + [ testCase "fires once" do + n <- runTest do + (count, fired) <- newCounter let cb _ = bump count fired debouncedWith 50 (+) () (1 :: Int) cb debouncedWith 50 (+) () (2 :: Int) cb @@ -198,9 +220,8 @@ awaitFire fired Delay.wait @Millisecond 80 readCount count - n `shouldBe` 1 - - it "fires callback with merged arg" do + n @?= 1 + , testCase "fires callback with merged arg" do got <- runTest do result <- STM.atomically STM.newEmptyTMVar let cb = signal result @@ -208,21 +229,26 @@ debouncedWith 50 (+) () (2 :: Int) cb debouncedWith 50 (+) () (3 :: Int) cb awaitValue result - got `shouldBe` Just 6 - - describe "when invoked multiple times with a delay between" $ it "fires once per burst with merged arg" do - xs <- runTest do - fired <- STM.atomically STM.newEmptyTMVar - ref <- STM.atomically (STM.newTVar @[Int] []) - let cb v = STM.atomically (STM.modifyTVar' ref (<> [v]) >> void (STM.tryPutTMVar fired ())) - debouncedWith 50 (+) () (1 :: Int) cb - debouncedWith 50 (+) () (2 :: Int) cb - awaitFire fired -- burst 1 fired (1+2=3); entry cleared - debouncedWith 50 (+) () (10 :: Int) cb - debouncedWith 50 (+) () (20 :: Int) cb - awaitFire fired -- burst 2 fired (10+20=30) - STM.atomically (STM.readTVar ref) - xs `shouldBe` [3, 30] + got @?= Just 6 + ] + , testGroup + "when invoked multiple times with a delay between" + [ testCase "fires once per burst with merged arg" do + xs <- runTest do + fired <- STM.atomically STM.newEmptyTMVar + ref <- STM.atomically (STM.newTVar @[Int] []) + let cb v = STM.atomically (STM.modifyTVar' ref (<> [v]) >> void (STM.tryPutTMVar fired ())) + debouncedWith 50 (+) () (1 :: Int) cb + debouncedWith 50 (+) () (2 :: Int) cb + awaitFire fired -- burst 1 fired (1+2=3); entry cleared + debouncedWith 50 (+) () (10 :: Int) cb + debouncedWith 50 (+) () (20 :: Int) cb + awaitFire fired -- burst 2 fired (10+20=30) + STM.atomically (STM.readTVar ref) + xs @?= [3, 30] + ] + ] + ] where runTest = runEff @@ -247,7 +273,7 @@ awaitFire fired = awaitValue fired >>= \case Just () -> pure () - Nothing -> liftIO $ expectationFailure "debounce callback did not fire within 5s" + Nothing -> liftIO $ assertFailure "debounce callback did not fire within 5s" awaitValue tmv = either (const Nothing) Just <$> Conc.race (Delay.wait @Millisecond 5000) (STM.atomically (STM.takeTMVar tmv)) diff --git a/test/Unit/Atelier/Effects/FileSystemSpec.hs b/test/Unit/Atelier/Effects/FileSystemSpec.hs --- a/test/Unit/Atelier/Effects/FileSystemSpec.hs +++ b/test/Unit/Atelier/Effects/FileSystemSpec.hs @@ -1,9 +1,10 @@ -module Unit.Atelier.Effects.FileSystemSpec (spec_FileSystem) where +module Unit.Atelier.Effects.FileSystemSpec (test_FileSystem) where -import Control.Exception (evaluate) +import Control.Exception (IOException, evaluate, try) import Effectful (runPureEff) import Effectful.State.Static.Shared (State, evalState) -import Test.Hspec (Spec, anyIOException, describe, it, shouldBe, shouldThrow) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Data.ByteString.Lazy qualified as LBS import Data.Map.Strict qualified as M @@ -11,124 +12,129 @@ import Atelier.Effects.FileSystem -spec_FileSystem :: Spec -spec_FileSystem = describe "runFileSystemState" testFileSystemState +test_FileSystem :: TestTree +test_FileSystem = + testGroup + "FileSystem" + [ testGroup "runFileSystemState" testFileSystemState + ] -testFileSystemState :: Spec -testFileSystemState = do - describe "readFileBs" do - it "reads bytes of a file present in the state" do +testFileSystemState :: [TestTree] +testFileSystemState = + [ testGroup + "readFileBs" + [ testCase "reads bytes of a file present in the state" do run (M.singleton "/a" "hello") (readFileBs "/a") - `shouldBe` "hello" - - it "errors when the file is absent" do - evaluate (run M.empty (readFileBs "/missing")) - `shouldThrow` anyIOException - - describe "readFileLbs" do - it "reads the entire file as lazy bytes" do + @?= "hello" + , testCase "errors when the file is absent" do + result <- try @IOException $ evaluate (run M.empty (readFileBs "/missing")) + isLeft result @?= True + ] + , testGroup + "readFileLbs" + [ testCase "reads the entire file as lazy bytes" do run (M.singleton "/a" "hello") (readFileLbs "/a") - `shouldBe` ("hello" :: LBS.ByteString) - - it "errors when the file is absent" do - evaluate (run M.empty (readFileLbs "/missing")) - `shouldThrow` anyIOException - - describe "readFileLbsFrom" do - it "returns full content when offset is 0" do + @?= ("hello" :: LBS.ByteString) + , testCase "errors when the file is absent" do + result <- try @IOException $ evaluate (run M.empty (readFileLbs "/missing")) + isLeft result @?= True + ] + , testGroup + "readFileLbsFrom" + [ testCase "returns full content when offset is 0" do run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 0) - `shouldBe` ("hello" :: LBS.ByteString) - - it "skips the leading bytes up to the given offset" do + @?= ("hello" :: LBS.ByteString) + , testCase "skips the leading bytes up to the given offset" do run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 2) - `shouldBe` ("llo" :: LBS.ByteString) - - it "returns empty when offset equals the file length" do + @?= ("llo" :: LBS.ByteString) + , testCase "returns empty when offset equals the file length" do run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 5) - `shouldBe` ("" :: LBS.ByteString) - - it "errors when the file is absent" do - evaluate (run M.empty (readFileLbsFrom "/missing" 0)) - `shouldThrow` anyIOException - - describe "doesFileExist" do - it "returns True for a key present in the state" do + @?= ("" :: LBS.ByteString) + , testCase "errors when the file is absent" do + result <- try @IOException $ evaluate (run M.empty (readFileLbsFrom "/missing" 0)) + isLeft result @?= True + ] + , testGroup + "doesFileExist" + [ testCase "returns True for a key present in the state" do run (M.singleton "/a" "") (doesFileExist "/a") - `shouldBe` True - - it "returns False when the key is absent" do + @?= True + , testCase "returns False when the key is absent" do run M.empty (doesFileExist "/a") - `shouldBe` False - - describe "doesPathExist" do - it "returns True when a key with the path as a string prefix exists" do + @?= False + ] + , testGroup + "doesPathExist" + [ testCase "returns True when a key with the path as a string prefix exists" do run (M.singleton "/dir/file" "") (doesPathExist "/dir") - `shouldBe` True - - it "returns False when no key shares the prefix" do + @?= True + , testCase "returns False when no key shares the prefix" do run M.empty (doesPathExist "/dir") - `shouldBe` False - - it "returns False for an exact-match key with no children" do + @?= False + , testCase "returns False for an exact-match key with no children" do run (M.singleton "/dir" "") (doesPathExist "/dir") - `shouldBe` False - - describe "listDirectory" do - it "returns all keys that start with the given path" do + @?= False + ] + , testGroup + "listDirectory" + [ testCase "returns all keys that start with the given path" do let fs = M.fromList [("/dir/a", ""), ("/dir/b", ""), ("/other/c", "")] sort (run fs (listDirectory "/dir")) - `shouldBe` ["/dir/a", "/dir/b"] - - it "returns empty list when no keys share the prefix" do + @?= ["/dir/a", "/dir/b"] + , testCase "returns empty list when no keys share the prefix" do run M.empty (listDirectory "/dir") - `shouldBe` [] - - it "excludes an exact-match key" do + @?= [] + , testCase "excludes an exact-match key" do let fs = M.fromList [("/dir", ""), ("/dir/a", "")] run fs (listDirectory "/dir") - `shouldBe` ["/dir/a"] - - describe "removeFile" do - it "removes the file from the state" do + @?= ["/dir/a"] + ] + , testGroup + "removeFile" + [ testCase "removes the file from the state" do let result = run (M.singleton "/a" "x") do removeFile "/a" doesFileExist "/a" - result `shouldBe` False - - it "leaves other files unaffected" do + result @?= False + , testCase "leaves other files unaffected" do let result = run (M.fromList [("/a", "x"), ("/b", "y")]) do removeFile "/a" doesFileExist "/b" - result `shouldBe` True - - it "is a no-op when the file is absent" do + result @?= True + , testCase "is a no-op when the file is absent" do let result = run M.empty do removeFile "/missing" doesFileExist "/missing" - result `shouldBe` False - - describe "createDirectoryIfMissing" do - it "is a no-op — does not add any entries to the state" do + result @?= False + ] + , testGroup + "createDirectoryIfMissing" + [ testCase "is a no-op — does not add any entries to the state" do let result = run M.empty do createDirectoryIfMissing True "/new/dir" doesPathExist "/new/dir" - result `shouldBe` False - - describe "canonicalizePath" do - it "returns the path unchanged" do + result @?= False + ] + , testGroup + "canonicalizePath" + [ testCase "returns the path unchanged" do run M.empty (canonicalizePath "/some/./path") - `shouldBe` "/some/./path" - - describe "getCurrentDirectory" do - it "returns /" do + @?= "/some/./path" + ] + , testGroup + "getCurrentDirectory" + [ testCase "returns /" do run M.empty getCurrentDirectory - `shouldBe` "/" - - describe "getXdgRuntimeDir" do - it "returns /tmp" do + @?= "/" + ] + , testGroup + "getXdgRuntimeDir" + [ testCase "returns /tmp" do run M.empty getXdgRuntimeDir - `shouldBe` "/tmp" + @?= "/tmp" + ] + ] run diff --git a/test/Unit/Atelier/Effects/FileWatcherSpec.hs b/test/Unit/Atelier/Effects/FileWatcherSpec.hs --- a/test/Unit/Atelier/Effects/FileWatcherSpec.hs +++ b/test/Unit/Atelier/Effects/FileWatcherSpec.hs @@ -1,13 +1,14 @@ -module Unit.Atelier.Effects.FileWatcherSpec (spec_FileWatcher) where +module Unit.Atelier.Effects.FileWatcherSpec (test_FileWatcher) where import Control.Concurrent (forkIO, killThread, newQSem, signalQSem, waitQSem) import Data.IORef (modifyIORef, newIORef, readIORef) import Data.List (isSuffixOf) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) -import Hedgehog (Gen, PropertyT, forAll, (===)) -import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Hspec.Hedgehog (hedgehog) +import Hedgehog (Gen, PropertyT, forAll, property, (===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.Hedgehog (testProperty) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -25,69 +26,74 @@ ) -spec_FileWatcher :: Spec -spec_FileWatcher = do - describe "deduplicateDirs" do - describe "properties" do - it "result is an antichain: no element is an ancestor of another" - $ hedgehog propAntichain - it "result covers all inputs: every input has an ancestor-or-equal in the result" - $ hedgehog propCoverage - it "is idempotent" - $ hedgehog propIdempotent - it "result is a subset of the input" - $ hedgehog propSubset - - describe "edge cases" do - it "returns empty list unchanged" do - deduplicateDirs [] `shouldBe` [] - - it "does not treat a dir as an ancestor of a similarly named dir" do - deduplicateDirs ["/src", "/srcover"] `shouldBe` ["/src", "/srcover"] - - describe "matchesAny" do - it "matches a file under a watched directory" do - matchesAny [dir "/proj/src"] "/proj/src/Foo.hs" - `shouldBe` True - - it "does not match a relative watch dir against an absolute event path" do - -- runFileWatcherIO must canonicalize Watch paths to absolute before - -- calling matchesAny, because fsnotify always reports absolute paths. - matchesAny [dir "src"] "/proj/src/Foo.hs" - `shouldBe` False - - it "applies the file predicate" do - matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.hs" - `shouldBe` True - matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.js" - `shouldBe` False - - describe "runFileWatcherScripted" testScripted +test_FileWatcher :: TestTree +test_FileWatcher = + testGroup + "FileWatcher" + [ testGroup + "deduplicateDirs" + [ testGroup + "properties" + [ testProperty "result is an antichain: no element is an ancestor of another" + $ property propAntichain + , testProperty "result covers all inputs: every input has an ancestor-or-equal in the result" + $ property propCoverage + , testProperty "is idempotent" + $ property propIdempotent + , testProperty "result is a subset of the input" + $ property propSubset + ] + , testGroup + "edge cases" + [ testCase "returns empty list unchanged" do + deduplicateDirs [] @?= [] + , testCase "does not treat a dir as an ancestor of a similarly named dir" do + deduplicateDirs ["/src", "/srcover"] @?= ["/src", "/srcover"] + ] + ] + , testGroup + "matchesAny" + [ testCase "matches a file under a watched directory" do + matchesAny [dir "/proj/src"] "/proj/src/Foo.hs" + @?= True + , testCase "does not match a relative watch dir against an absolute event path" do + -- runFileWatcherIO must canonicalize Watch paths to absolute before + -- calling matchesAny, because fsnotify always reports absolute paths. + matchesAny [dir "src"] "/proj/src/Foo.hs" + @?= False + , testCase "applies the file predicate" do + matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.hs" + @?= True + matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.js" + @?= False + ] + , testGroup "runFileWatcherScripted" testScripted + ] -------------------------------------------------------------------------------- -- Scripted interpreter tests -------------------------------------------------------------------------------- -testScripted :: Spec -testScripted = do - describe "watchFilePaths" do - it "calls the callback with the scripted path" do +testScripted :: [TestTree] +testScripted = + [ testGroup + "watchFilePaths" + [ testCase "calls the callback with the scripted path" do paths <- collectPaths ["/src/Foo.hs"] - paths `shouldBe` ["/src/Foo.hs"] - - it "calls the callback with each path in order" do + paths @?= ["/src/Foo.hs"] + , testCase "calls the callback with each path in order" do paths <- collectPaths ["/src/Foo.hs", "/src/Bar.hs"] - paths `shouldBe` ["/src/Foo.hs", "/src/Bar.hs"] - - it "ignores the watch specification" do + paths @?= ["/src/Foo.hs", "/src/Bar.hs"] + , testCase "ignores the watch specification" do paths <- collectPathsWith [dir "/any"] ["/src/Foo.hs"] - paths `shouldBe` ["/src/Foo.hs"] - - it "passes the full path to the callback unchanged" do + paths @?= ["/src/Foo.hs"] + , testCase "passes the full path to the callback unchanged" do let path = "/home/user/project/src/Some/Deep/Module.hs" paths <- collectPaths [path] - paths `shouldBe` [path] + paths @?= [path] + ] + ] -------------------------------------------------------------------------------- diff --git a/test/Unit/Atelier/Effects/IteratorSpec.hs b/test/Unit/Atelier/Effects/IteratorSpec.hs --- a/test/Unit/Atelier/Effects/IteratorSpec.hs +++ b/test/Unit/Atelier/Effects/IteratorSpec.hs @@ -1,9 +1,10 @@ -module Unit.Atelier.Effects.IteratorSpec (spec_Iterator) where +module Unit.Atelier.Effects.IteratorSpec (test_Iterator) where import Control.Concurrent (threadDelay) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Atelier.Effects.Chan (Chan, runChan) import Atelier.Effects.Clock (Clock, runClock) @@ -16,34 +17,35 @@ import Atelier.Effects.Publishing.Pub qualified as Pub -spec_Iterator :: Spec -spec_Iterator = do - describe "fromEvents" testFromEvents - describe "filter" testFilter - describe "changes" testChanges +test_Iterator :: TestTree +test_Iterator = + testGroup + "Iterator" + [ testGroup "fromEvents" testFromEvents + , testGroup "filter" testFilter + , testGroup "changes" testChanges + ] -testFromEvents :: Spec -testFromEvents = do - it "yields a published event" do +testFromEvents :: [TestTree] +testFromEvents = + [ testCase "yields a published event" do result <- runTest $ do Iter.fromEvents @Int \iter -> do _ <- fork do liftIO $ threadDelay 10 Pub.publish (42 :: Int) Iter.next iter - result `shouldBe` 42 - - it "yields events in publication order" do + result @?= 42 + , testCase "yields events in publication order" do result <- runTest $ do Iter.fromEvents @Int \iter -> do _ <- fork do liftIO $ threadDelay 10 traverse_ Pub.publish [1, 2, 3] replicateM 3 (Iter.next iter) - result `shouldBe` [1, 2, 3] - - it "buffers events so next can catch up" do + result @?= [1, 2, 3] + , testCase "buffers events so next can catch up" do result <- runTest $ do Iter.fromEvents @Int \iter -> do _ <- fork do @@ -51,58 +53,58 @@ traverse_ Pub.publish [1, 2, 3] liftIO $ threadDelay 5_000 replicateM 3 (Iter.next iter) - result `shouldBe` [1, 2, 3] + result @?= [1, 2, 3] + ] -testFilter :: Spec -testFilter = do - it "passes values that satisfy the predicate" do +testFilter :: [TestTree] +testFilter = + [ testCase "passes values that satisfy the predicate" do result <- runTest $ do Iter.fromEvents @Int \iter -> do _ <- fork do liftIO $ threadDelay 10 traverse_ Pub.publish [1 .. 4] Iter.next (Iter.filter even iter) - result `shouldBe` 2 - - it "skips values that do not satisfy the predicate" do + result @?= 2 + , testCase "skips values that do not satisfy the predicate" do result <- runTest $ do Iter.fromEvents @Int \iter -> do _ <- fork do liftIO $ threadDelay 10 traverse_ Pub.publish [1 .. 6] replicateM 3 (Iter.next (Iter.filter even iter)) - result `shouldBe` [2, 4, 6] + result @?= [2, 4, 6] + ] -testChanges :: Spec -testChanges = do - it "skips values equal to the initial value" do +testChanges :: [TestTree] +testChanges = + [ testCase "skips values equal to the initial value" do result <- runTest $ do Iter.fromEvents @Int \iter -> do _ <- fork do liftIO $ threadDelay 10 traverse_ Pub.publish [0, 0, 1] Iter.next (Iter.changes 0 iter) - result `shouldBe` 1 - - it "yields values that differ from the initial value" do + result @?= 1 + , testCase "yields values that differ from the initial value" do result <- runTest $ do Iter.fromEvents @Int \iter -> do _ <- fork do liftIO $ threadDelay 10 traverse_ Pub.publish [1, 2, 3] replicateM 3 (Iter.next (Iter.changes 0 iter)) - result `shouldBe` [1, 2, 3] - - it "skips initial values interspersed with non-initial values" do + result @?= [1, 2, 3] + , testCase "skips initial values interspersed with non-initial values" do result <- runTest $ do Iter.fromEvents @Int \iter -> do _ <- fork do liftIO $ threadDelay 10 traverse_ Pub.publish [0, 1, 0, 2, 0, 3] replicateM 3 (Iter.next (Iter.changes 0 iter)) - result `shouldBe` [1, 2, 3] + result @?= [1, 2, 3] + ] -------------------------------------------------------------------------------- diff --git a/test/Unit/Atelier/Effects/LogSpec.hs b/test/Unit/Atelier/Effects/LogSpec.hs --- a/test/Unit/Atelier/Effects/LogSpec.hs +++ b/test/Unit/Atelier/Effects/LogSpec.hs @@ -1,8 +1,9 @@ -module Unit.Atelier.Effects.LogSpec (spec_Log) where +module Unit.Atelier.Effects.LogSpec (test_Log) where import Effectful (runPureEff) import Effectful.Writer.Static.Shared (Writer, execWriter) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Atelier.Effects.Log (Log, Message (..), info, runLogWriter, withNamespace) @@ -14,74 +15,78 @@ . runLogWriter -spec_Log :: Spec -spec_Log = do - describe "Log with namespace" $ do - it "logs without namespace when not provided" $ do - let logs = - fmap (\m -> (m.namespace, m.text)) - . runLogTest - $ info "test message" - logs `shouldBe` [("", "test message")] - - it "prepends a namespace to the logged message" $ do - let logs = - fmap (\m -> (m.namespace, m.text)) - . runLogTest - . withNamespace "component" - $ info "test message" - logs `shouldBe` [("component", "test message")] - - describe "nested namespaces" $ do - it "appends a namespace to the current namespace" $ do +test_Log :: TestTree +test_Log = + testGroup + "Log" + [ testGroup + "Log with namespace" + [ testCase "logs without namespace when not provided" $ do let logs = fmap (\m -> (m.namespace, m.text)) . runLogTest - . withNamespace "parent" - . withNamespace "child" $ info "test message" - logs `shouldBe` [("parent.child", "test message")] - - it "handles multiple levels of nesting" $ do + logs @?= [("", "test message")] + , testCase "prepends a namespace to the logged message" $ do let logs = fmap (\m -> (m.namespace, m.text)) . runLogTest - . withNamespace "level1" - . withNamespace "level2" - . withNamespace "level3" + . withNamespace "component" $ info "test message" - logs `shouldBe` [("level1.level2.level3", "test message")] - - describe "namespace scoping" $ do - it "only applies namespace within its scope" $ do - let logs = - fmap (\m -> (m.namespace, m.text)) - . runPureEff - . execWriter @[Message] - . runLogWriter - $ do - info "before" - withNamespace "scoped" $ info "inside" - info "after" - logs - `shouldBe` [ ("", "before") - , ("scoped", "inside") - , ("", "after") - ] - - it "handles partially nested scopes" $ do - let logs = - fmap (\m -> (m.namespace, m.text)) - . runPureEff - . execWriter @[Message] - . runLogWriter - . withNamespace "outer" - $ do - info "outer msg" - withNamespace "inner" $ info "inner msg" - info "outer again" - logs - `shouldBe` [ ("outer", "outer msg") - , ("outer.inner", "inner msg") - , ("outer", "outer again") - ] + logs @?= [("component", "test message")] + , testGroup + "nested namespaces" + [ testCase "appends a namespace to the current namespace" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runLogTest + . withNamespace "parent" + . withNamespace "child" + $ info "test message" + logs @?= [("parent.child", "test message")] + , testCase "handles multiple levels of nesting" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runLogTest + . withNamespace "level1" + . withNamespace "level2" + . withNamespace "level3" + $ info "test message" + logs @?= [("level1.level2.level3", "test message")] + ] + , testGroup + "namespace scoping" + [ testCase "only applies namespace within its scope" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runPureEff + . execWriter @[Message] + . runLogWriter + $ do + info "before" + withNamespace "scoped" $ info "inside" + info "after" + logs + @?= [ ("", "before") + , ("scoped", "inside") + , ("", "after") + ] + , testCase "handles partially nested scopes" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runPureEff + . execWriter @[Message] + . runLogWriter + . withNamespace "outer" + $ do + info "outer msg" + withNamespace "inner" $ info "inner msg" + info "outer again" + logs + @?= [ ("outer", "outer msg") + , ("outer.inner", "inner msg") + , ("outer", "outer again") + ] + ] + ] + ] diff --git a/test/Unit/Atelier/Effects/Publishing/PubSpec.hs b/test/Unit/Atelier/Effects/Publishing/PubSpec.hs --- a/test/Unit/Atelier/Effects/Publishing/PubSpec.hs +++ b/test/Unit/Atelier/Effects/Publishing/PubSpec.hs @@ -1,8 +1,9 @@ -module Unit.Atelier.Effects.Publishing.PubSpec (spec_Pub) where +module Unit.Atelier.Effects.Publishing.PubSpec (test_Pub) where import Effectful (runPureEff) import Effectful.Writer.Static.Shared (execWriter) -import Test.Hspec (Spec, context, describe, it, shouldMatchList) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Atelier.Effects.Publishing.Pub qualified as Pub @@ -11,43 +12,51 @@ deriving stock (Eq, Show) -spec_Pub :: Spec -spec_Pub = do - describe "toWriter" do - context "no events published" do - it "doesn't record events" do - let events = - runPureEff . execWriter . Pub.toWriter @TestEvent - $ pure () +test_Pub :: TestTree +test_Pub = + testGroup + "Pub" + [ testGroup + "toWriter" + [ testGroup + "no events published" + [ testCase "doesn't record events" do + let events = + runPureEff . execWriter . Pub.toWriter @TestEvent + $ pure () - events `shouldMatchList` [] + events @?= [] + ] + , testGroup + "events published" + [ testCase "records events" do + let events = + runPureEff . execWriter . Pub.toWriter @TestEvent $ do + Pub.publish $ TestEvent "payload" + pure () - context "events published" do - it "records events" do + events @?= [TestEvent "payload"] + ] + ] + , testGroup + "map" + [ testCase "maps over one event" do let events = - runPureEff . execWriter . Pub.toWriter @TestEvent $ do - Pub.publish $ TestEvent "payload" - pure () - - events `shouldMatchList` [TestEvent "payload"] - - describe "map" do - it "maps over one event" do - let events = - runPureEff - . execWriter - . Pub.toWriter @Text - . Pub.map show - $ Pub.publish @Int 1 - - events `shouldMatchList` ["1"] + runPureEff + . execWriter + . Pub.toWriter @Text + . Pub.map show + $ Pub.publish @Int 1 - it "maps over many events" do - let events = - runPureEff - . execWriter - . Pub.toWriter @Text - . Pub.map show - $ traverse Pub.publish [1 .. 10 :: Int] + events @?= ["1"] + , testCase "maps over many events" do + let events = + runPureEff + . execWriter + . Pub.toWriter @Text + . Pub.map show + $ traverse Pub.publish [1 .. 10 :: Int] - events `shouldMatchList` ["1", "2", "3", "4", "5", "6", "7", "8", "9", "10"] + events @?= ["1", "2", "3", "4", "5", "6", "7", "8", "9", "10"] + ] + ] diff --git a/test/Unit/Atelier/Effects/PublishingSpec.hs b/test/Unit/Atelier/Effects/PublishingSpec.hs --- a/test/Unit/Atelier/Effects/PublishingSpec.hs +++ b/test/Unit/Atelier/Effects/PublishingSpec.hs @@ -1,10 +1,11 @@ -module Unit.Atelier.Effects.PublishingSpec (spec_Publishing) where +module Unit.Atelier.Effects.PublishingSpec (test_Publishing) where import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Data.Time (UTCTime, getCurrentTime) import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Atelier.Effects.Chan (Chan, runChan) import Atelier.Effects.Clock (Clock, runClock, runClockConst) @@ -21,39 +22,42 @@ deriving stock (Eq, Show) -spec_Publishing :: Spec -spec_Publishing = do - describe "runPubSub" do - it "listener receives a published event" do - result <- runPubSubTest $ do - received <- liftIO newEmptyMVar - Sub.forkListener_ @TestEvent \event -> - liftIO $ putMVar received event - Pub.publish (TestEvent "hello") - liftIO $ takeMVar received - result `shouldBe` TestEvent "hello" - - it "event timestamp matches Clock at publish time" do - t0 <- getCurrentTime - result <- runPubSubTestWithClock t0 $ do - received <- liftIO newEmptyMVar - Sub.forkListener @TestEvent \ts _event -> - liftIO $ putMVar received ts - Pub.publish (TestEvent "hello") - liftIO $ takeMVar received - result `shouldBe` t0 - - it "multiple listeners each receive the published event" do - result <- runPubSubTest $ do - recv1 <- liftIO newEmptyMVar - recv2 <- liftIO newEmptyMVar - Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv1 event - Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv2 event - Pub.publish (TestEvent "hello") - e1 <- liftIO $ takeMVar recv1 - e2 <- liftIO $ takeMVar recv2 - pure (e1, e2) - result `shouldBe` (TestEvent "hello", TestEvent "hello") +test_Publishing :: TestTree +test_Publishing = + testGroup + "Publishing" + [ testGroup + "runPubSub" + [ testCase "listener receives a published event" do + result <- runPubSubTest $ do + received <- liftIO newEmptyMVar + Sub.forkListener_ @TestEvent \event -> + liftIO $ putMVar received event + Pub.publish (TestEvent "hello") + liftIO $ takeMVar received + result @?= TestEvent "hello" + , testCase "event timestamp matches Clock at publish time" do + t0 <- getCurrentTime + result <- runPubSubTestWithClock t0 $ do + received <- liftIO newEmptyMVar + Sub.forkListener @TestEvent \ts _event -> + liftIO $ putMVar received ts + Pub.publish (TestEvent "hello") + liftIO $ takeMVar received + result @?= t0 + , testCase "multiple listeners each receive the published event" do + result <- runPubSubTest $ do + recv1 <- liftIO newEmptyMVar + recv2 <- liftIO newEmptyMVar + Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv1 event + Sub.forkListener_ @TestEvent \event -> liftIO $ putMVar recv2 event + Pub.publish (TestEvent "hello") + e1 <- liftIO $ takeMVar recv1 + e2 <- liftIO $ takeMVar recv2 + pure (e1, e2) + result @?= (TestEvent "hello", TestEvent "hello") + ] + ] -------------------------------------------------------------------------------- diff --git a/test/Unit/Atelier/Effects/TallySpec.hs b/test/Unit/Atelier/Effects/TallySpec.hs --- a/test/Unit/Atelier/Effects/TallySpec.hs +++ b/test/Unit/Atelier/Effects/TallySpec.hs @@ -1,11 +1,12 @@ -module Unit.Atelier.Effects.TallySpec (spec_Tally) where +module Unit.Atelier.Effects.TallySpec (test_Tally) where import Effectful (IOE, runEff) import Effectful.Concurrent (Concurrent, runConcurrent) import Effectful.Reader.Static (Reader, runReader) -import Hedgehog (forAll, (===)) -import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Hspec.Hedgehog (hedgehog) +import Hedgehog (forAll, property, (===)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.Hedgehog (testProperty) import Data.IORef qualified as IORef import Data.Map.Strict qualified as Map @@ -19,61 +20,65 @@ import Atelier.Effects.Tally (Config (..), Tally, runTally, withTallyCheck) -spec_Tally :: Spec -spec_Tally = do - describe "Multiple Keys" do - it "works with integer keys" do - result <- runTallyTest $ checkCountsForKeys [1, 42, 999 :: Int] - result `shouldBe` Map.fromList [(1, 1), (42, 1), (999, 1)] - - describe "Custom Classifiers" do - it "identity classifier returns the raw hit count" do - result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 id pure) - result `shouldBe` [1, 2, 3, 4 :: Int] - - it "multi-mark classifier yields correct mark for each hit" do - -- Two thresholds: warning at >2, critical at >4 - let classify c - | c > 4 = Just True -- critical - | c > 2 = Just False -- warning - | otherwise = Nothing -- ok - result <- runTallyTest $ replicateM 6 (withTallyCheck @Int 1 classify pure) - result `shouldBe` [Nothing, Nothing, Just False, Just False, Just True, Just True] - - it "classifier producing tuples gives both count and flag" do - let classify c = (c, c > 2) - result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 classify pure) - result `shouldBe` [(1, False), (2, False), (3, True), (4, True)] - - describe "Action Execution" do - it "continuation with side effects executes correctly" do - result <- runTallyTest $ do - ref <- liftIO $ IORef.newIORef ([] :: [(Int, Bool)]) - replicateM_ 3 - $ withTallyCheck @Int 1 (\c -> (c, c > 2)) - $ \(count, exceeded) -> - liftIO $ IORef.modifyIORef' ref ((count, exceeded) :) - liftIO $ reverse <$> IORef.readIORef ref - result `shouldBe` [(1, False), (2, False), (3, True)] - - describe "Properties" do - it "kth call receives count k (count fidelity)" $ hedgehog $ do - n <- forAll $ Gen.int (Range.linear 1 100) - results <- liftIO $ runTallyTest $ replicateM n checkCount - results === [1 .. n] - - it "no lost updates under concurrency" $ hedgehog $ do - n <- forAll $ Gen.int (Range.linear 1 50) - finalCount <- liftIO $ runTallyTest $ do - replicateM_ n checkCount - checkCount - finalCount === n + 1 - - it "classifier output is passed through unchanged" $ hedgehog $ do - n <- forAll $ Gen.int (Range.linear 1 50) - offset <- forAll $ Gen.int (Range.linear 0 200) - results <- liftIO $ runTallyTest $ replicateM n (withTallyCheck @Int 1 (+ offset) pure) - results === map (+ offset) [1 .. n] +test_Tally :: TestTree +test_Tally = + testGroup + "Tally" + [ testGroup + "Multiple Keys" + [ testCase "works with integer keys" do + result <- runTallyTest $ checkCountsForKeys [1, 42, 999 :: Int] + result @?= Map.fromList [(1, 1), (42, 1), (999, 1)] + ] + , testGroup + "Custom Classifiers" + [ testCase "identity classifier returns the raw hit count" do + result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 id pure) + result @?= [1, 2, 3, 4 :: Int] + , testCase "multi-mark classifier yields correct mark for each hit" do + -- Two thresholds: warning at >2, critical at >4 + let classify c + | c > 4 = Just True -- critical + | c > 2 = Just False -- warning + | otherwise = Nothing -- ok + result <- runTallyTest $ replicateM 6 (withTallyCheck @Int 1 classify pure) + result @?= [Nothing, Nothing, Just False, Just False, Just True, Just True] + , testCase "classifier producing tuples gives both count and flag" do + let classify c = (c, c > 2) + result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 classify pure) + result @?= [(1, False), (2, False), (3, True), (4, True)] + ] + , testGroup + "Action Execution" + [ testCase "continuation with side effects executes correctly" do + result <- runTallyTest $ do + ref <- liftIO $ IORef.newIORef ([] :: [(Int, Bool)]) + replicateM_ 3 + $ withTallyCheck @Int 1 (\c -> (c, c > 2)) + $ \(count, exceeded) -> + liftIO $ IORef.modifyIORef' ref ((count, exceeded) :) + liftIO $ reverse <$> IORef.readIORef ref + result @?= [(1, False), (2, False), (3, True)] + ] + , testGroup + "Properties" + [ testProperty "kth call receives count k (count fidelity)" $ property $ do + n <- forAll $ Gen.int (Range.linear 1 100) + results <- liftIO $ runTallyTest $ replicateM n checkCount + results === [1 .. n] + , testProperty "no lost updates under concurrency" $ property $ do + n <- forAll $ Gen.int (Range.linear 1 50) + finalCount <- liftIO $ runTallyTest $ do + replicateM_ n checkCount + checkCount + finalCount === n + 1 + , testProperty "classifier output is passed through unchanged" $ property $ do + n <- forAll $ Gen.int (Range.linear 1 50) + offset <- forAll $ Gen.int (Range.linear 0 200) + results <- liftIO $ runTallyTest $ replicateM n (withTallyCheck @Int 1 (+ offset) pure) + results === map (+ offset) [1 .. n] + ] + ] -------------------------------------------------------------------------------- diff --git a/test/Unit/Atelier/Effects/YieldSpec.hs b/test/Unit/Atelier/Effects/YieldSpec.hs --- a/test/Unit/Atelier/Effects/YieldSpec.hs +++ b/test/Unit/Atelier/Effects/YieldSpec.hs @@ -1,10 +1,11 @@ -module Unit.Atelier.Effects.YieldSpec (spec_Yield) where +module Unit.Atelier.Effects.YieldSpec (test_Yield) where import Effectful (runEff, runPureEff) import Effectful.Concurrent (runConcurrent) import Effectful.State.Static.Shared (execState, modify) import Effectful.Writer.Static.Shared (execWriter, tell) -import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Atelier.Effects.Chan (runChan) import Atelier.Effects.Conc (runConc) @@ -13,233 +14,242 @@ import Atelier.Effects.Yield qualified as Yield -spec_Yield :: Spec -spec_Yield = do - describe "yieldToList" testYieldToList - describe "yieldToReverseList" testYieldToReverseList - describe "forEach" testForEach - describe "ignoreYield" testIgnoreYield - describe "inFoldable" testInFoldable - describe "cycleToYield" testCycleToYield - describe "withYieldToList" testWithYieldToList - describe "enumerate" testEnumerate - describe "enumerateFrom" testEnumerateFrom - describe "map" testMap - describe "mapMaybe" testMapMaybe - describe "catMaybes" testCatMaybes - describe "filter" testFilter - describe "changes" testChanges +test_Yield :: TestTree +test_Yield = + testGroup + "Yield" + [ testGroup "yieldToList" testYieldToList + , testGroup "yieldToReverseList" testYieldToReverseList + , testGroup "forEach" testForEach + , testGroup "ignoreYield" testIgnoreYield + , testGroup "inFoldable" testInFoldable + , testGroup "cycleToYield" testCycleToYield + , testGroup "withYieldToList" testWithYieldToList + , testGroup "enumerate" testEnumerate + , testGroup "enumerateFrom" testEnumerateFrom + , testGroup "map" testMap + , testGroup "mapMaybe" testMapMaybe + , testGroup "catMaybes" testCatMaybes + , testGroup "filter" testFilter + , testGroup "changes" testChanges + ] -testYieldToList :: Spec -testYieldToList = do - it "collects yields in order" do +testYieldToList :: [TestTree] +testYieldToList = + [ testCase "collects yields in order" do let ((), xs) = runPureEff $ Yield.yieldToList @Int do Yield.yield 1 Yield.yield 2 Yield.yield 3 - xs `shouldMatchList` [1, 2, 3] - - it "returns empty list when nothing is yielded" do + xs @?= [1, 2, 3] + , testCase "returns empty list when nothing is yielded" do let (_, xs) = runPureEff $ Yield.yieldToList @Int $ pure () - xs `shouldMatchList` [] - - it "also returns the result of the computation" do + xs @?= [] + , testCase "also returns the result of the computation" do let (r :: Text, xs) = runPureEff $ Yield.yieldToList do Yield.yield (1 :: Int) pure "result" - r `shouldBe` "result" - xs `shouldMatchList` [1] + r @?= "result" + xs @?= [1] + ] -testYieldToReverseList :: Spec -testYieldToReverseList = do - it "collects yields in reverse order" do +testYieldToReverseList :: [TestTree] +testYieldToReverseList = + [ testCase "collects yields in reverse order" do let ((), xs) = runPureEff $ Yield.yieldToReverseList @Int do Yield.yield 1 Yield.yield 2 Yield.yield 3 - xs `shouldBe` [3, 2, 1] + xs @?= [3, 2, 1] + ] -testForEach :: Spec -testForEach = do - it "calls the action for each yielded value" do +testForEach :: [TestTree] +testForEach = + [ testCase "calls the action for each yielded value" do let xs = runPureEff $ execState @[Int] mempty $ Yield.forEach (\x -> modify (x :)) do Yield.yield 1 Yield.yield 2 Yield.yield 3 - xs `shouldBe` [3, 2, 1] - - it "can discard values" do + xs @?= [3, 2, 1] + , testCase "can discard values" do let xs = runPureEff $ Yield.forEach @Int (const $ pure ()) do Yield.yield 1 - xs `shouldBe` () + xs @?= () + ] -testIgnoreYield :: Spec -testIgnoreYield = do - it "discards all yielded values" do +testIgnoreYield :: [TestTree] +testIgnoreYield = + [ testCase "discards all yielded values" do let x = runPureEff $ Yield.ignoreYield @Int do Yield.yield 1 Yield.yield 2 - x `shouldBe` () + x @?= () + ] -testInFoldable :: Spec -testInFoldable = do - it "yields all elements of a list in order" do +testInFoldable :: [TestTree] +testInFoldable = + [ testCase "yields all elements of a list in order" do let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.inFoldable @Int [1, 2, 3] - xs `shouldBe` [1, 2, 3] - - it "yields nothing for an empty list" do + xs @?= [1, 2, 3] + , testCase "yields nothing for an empty list" do let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.inFoldable @Int [] - xs `shouldBe` [] + xs @?= [] + ] -testCycleToYield :: Spec -testCycleToYield = do - it "yields elements of a list repeatedly in order" do +testCycleToYield :: [TestTree] +testCycleToYield = + [ testCase "yields elements of a list repeatedly in order" do xs <- runTest $ Await.awaitYield (Yield.cycleToYield @Int [1, 2, 3]) (replicateM_ 7 (Await.await >>= \x -> tell [x])) - xs `shouldBe` [1, 2, 3, 1, 2, 3, 1] + xs @?= [1, 2, 3, 1, 2, 3, 1] + ] where runTest = runEff . runConcurrent . runConc . runChan . execWriter -testWithYieldToList :: Spec -testWithYieldToList = do - it "passes the collected yields to the returned function" do +testWithYieldToList :: [TestTree] +testWithYieldToList = + [ testCase "passes the collected yields to the returned function" do let result = runPureEff $ Yield.withYieldToList @Int do Yield.yield 1 Yield.yield 2 Yield.yield 3 pure length - result `shouldBe` 3 - - it "passes yields in order to the function" do + result @?= 3 + , testCase "passes yields in order to the function" do let result = runPureEff $ Yield.withYieldToList @Int do Yield.yield 1 Yield.yield 2 Yield.yield 3 pure id - result `shouldBe` [1, 2, 3] - - it "passes an empty list when nothing is yielded" do + result @?= [1, 2, 3] + , testCase "passes an empty list when nothing is yielded" do let result = runPureEff $ Yield.withYieldToList @Int do pure null - result `shouldBe` True + result @?= True + ] -testEnumerate :: Spec -testEnumerate = do - it "pairs each value with its zero-based index" do +testEnumerate :: [TestTree] +testEnumerate = + [ testCase "pairs each value with its zero-based index" do let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.enumerate do Yield.yield 'a' Yield.yield 'b' Yield.yield 'c' - xs `shouldBe` [(0, 'a'), (1, 'b'), (2, 'c')] + xs @?= [(0, 'a'), (1, 'b'), (2, 'c')] + ] -testEnumerateFrom :: Spec -testEnumerateFrom = do - it "pairs each value with its index starting from the given value" do +testEnumerateFrom :: [TestTree] +testEnumerateFrom = + [ testCase "pairs each value with its index starting from the given value" do let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.enumerateFrom 5 do Yield.yield 'x' Yield.yield 'y' - xs `shouldBe` [(5, 'x'), (6, 'y')] + xs @?= [(5, 'x'), (6, 'y')] + ] -testMap :: Spec -testMap = do - it "transforms each yielded value" do +testMap :: [TestTree] +testMap = + [ testCase "transforms each yielded value" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.map @Int (* 2) do Yield.yield 1 Yield.yield 2 Yield.yield 3 - xs `shouldBe` [2, 4, 6] - - it "preserves order" do + xs @?= [2, 4, 6] + , testCase "preserves order" do let (_, xs :: [Text]) = runPureEff $ Yield.yieldToList $ Yield.map show do Yield.yield @Int 1 Yield.yield 2 - xs `shouldBe` ["1", "2"] + xs @?= ["1", "2"] + ] -testMapMaybe :: Spec -testMapMaybe = do - describe "when the function returns Just" $ it "yields transformed values" do - let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe (\x -> if even x then Just (x * 10) else Nothing) do - Yield.yield @Int 1 - Yield.yield 2 - Yield.yield 3 - Yield.yield 4 - xs `shouldMatchList` [20, 40] - - describe "when the function always returns Nothing" $ it "yields nothing" do - let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe @Int @Int (const Nothing) do - Yield.yield 1 - xs `shouldMatchList` [] +testMapMaybe :: [TestTree] +testMapMaybe = + [ testGroup + "when the function returns Just" + [ testCase "yields transformed values" do + let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe (\x -> if even x then Just (x * 10) else Nothing) do + Yield.yield @Int 1 + Yield.yield 2 + Yield.yield 3 + Yield.yield 4 + xs @?= [20, 40] + ] + , testGroup + "when the function always returns Nothing" + [ testCase "yields nothing" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe @Int @Int (const Nothing) do + Yield.yield 1 + xs @?= [] + ] + ] -testCatMaybes :: Spec -testCatMaybes = do - it "unwraps Just values and drops Nothings" do +testCatMaybes :: [TestTree] +testCatMaybes = + [ testCase "unwraps Just values and drops Nothings" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.catMaybes do Yield.yield (Just 1) Yield.yield Nothing Yield.yield (Just 2) - xs `shouldBe` [1 :: Int, 2] - - it "yields nothing when all values are Nothing" do + xs @?= [1 :: Int, 2] + , testCase "yields nothing when all values are Nothing" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.catMaybes do Yield.yield (Nothing :: Maybe Int) Yield.yield Nothing - xs `shouldBe` [] + xs @?= [] + ] -testFilter :: Spec -testFilter = do - it "passes values satisfying the predicate" do +testFilter :: [TestTree] +testFilter = + [ testCase "passes values satisfying the predicate" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter even do Yield.yield 1 Yield.yield 2 Yield.yield 3 Yield.yield 4 - xs `shouldBe` [2 :: Int, 4] - - it "drops all values when predicate is always false" do + xs @?= [2 :: Int, 4] + , testCase "drops all values when predicate is always false" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter (const False) do Yield.yield (1 :: Int) - xs `shouldBe` [] - - it "passes all values when predicate is always true" do + xs @?= [] + , testCase "passes all values when predicate is always true" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter (const True) do Yield.yield 1 Yield.yield 2 - xs `shouldBe` [1 :: Int, 2] + xs @?= [1 :: Int, 2] + ] -testChanges :: Spec -testChanges = do - it "suppresses yields equal to the initial value" do +testChanges :: [TestTree] +testChanges = + [ testCase "suppresses yields equal to the initial value" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do Yield.yield 0 Yield.yield 1 - xs `shouldBe` [1 :: Int] - - it "passes values that differ from the initial value" do + xs @?= [1 :: Int] + , testCase "passes values that differ from the initial value" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do Yield.yield 1 Yield.yield 2 - xs `shouldBe` [1 :: Int, 2] - - it "suppresses initial value interspersed with other values" do + xs @?= [1 :: Int, 2] + , testCase "suppresses initial value interspersed with other values" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do Yield.yield 0 Yield.yield 1 @@ -247,11 +257,11 @@ Yield.yield 2 Yield.yield 0 Yield.yield 3 - xs `shouldBe` [1 :: Int, 2, 3] - - it "does not suppress non-initial values even if they repeat" do + xs @?= [1 :: Int, 2, 3] + , testCase "does not suppress non-initial values even if they repeat" do let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do Yield.yield 1 Yield.yield 1 Yield.yield 2 - xs `shouldBe` [1 :: Int, 1, 2] + xs @?= [1 :: Int, 1, 2] + ] diff --git a/test/Unit/Atelier/Types/Semaphore/STMSpec.hs b/test/Unit/Atelier/Types/Semaphore/STMSpec.hs --- a/test/Unit/Atelier/Types/Semaphore/STMSpec.hs +++ b/test/Unit/Atelier/Types/Semaphore/STMSpec.hs @@ -1,10 +1,11 @@ -module Unit.Atelier.Types.Semaphore.STMSpec (spec_Semaphore_STM) where +module Unit.Atelier.Types.Semaphore.STMSpec (test_Semaphore_STM) where import Effectful (runEff) import Effectful.Concurrent (runConcurrent) import Effectful.Concurrent.STM (atomically) import Effectful.State.Static.Shared (evalState, get, put) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Data.IORef qualified as IORef @@ -12,115 +13,136 @@ import Atelier.Types.Semaphore.STM qualified as Sem -spec_Semaphore_STM :: Spec -spec_Semaphore_STM = do - describe "wait" $ it "should halt the computation" do - runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do - sem <- atomically Sem.new - - thread <- Conc.fork do - atomically $ Sem.wait sem - put 1 - - a1 <- get - liftIO $ a1 `shouldBe` 0 - - atomically $ Sem.signal sem - - Conc.await thread - - a2 <- get - liftIO $ a2 `shouldBe` 1 - - describe "signal" do - it "sets the semaphore" do - result <- runEff . runConcurrent . atomically $ do - sem <- Sem.new - Sem.signal sem - Sem.peek sem - result `shouldBe` True - - describe "clear" do - describe "when the semaphore was set" $ it "returns True" do - result <- runEff . runConcurrent . atomically $ do - sem <- Sem.newSet - Sem.unset sem - result `shouldBe` True - - describe "when the semaphore was not set" $ it "returns False" do - result <- runEff . runConcurrent . atomically $ do - sem <- Sem.new - Sem.unset sem - result `shouldBe` False - - it "leaves the semaphore clear" do - result <- runEff . runConcurrent . atomically $ do - sem <- Sem.newSet - _ <- Sem.unset sem - Sem.peek sem - result `shouldBe` False - - describe "reset" do - describe "when the semaphore was not set" $ it "returns True" do - result <- runEff . runConcurrent . atomically $ do - sem <- Sem.new - Sem.set sem - result `shouldBe` True - - describe "when the semaphore was already set" $ it "returns False" do - result <- runEff . runConcurrent . atomically $ do - sem <- Sem.newSet - Sem.set sem - result `shouldBe` False - - it "leaves the semaphore set" do - result <- runEff . runConcurrent . atomically $ do - sem <- Sem.new - _ <- Sem.set sem - Sem.peek sem - result `shouldBe` True - - describe "peek" do - describe "when the semaphore is set" $ it "returns True" do - result <- runEff . runConcurrent . atomically $ do - sem <- Sem.newSet - Sem.peek sem - result `shouldBe` True +test_Semaphore_STM :: TestTree +test_Semaphore_STM = + testGroup + "Semaphore.STM" + [ testGroup + "wait" + [ testCase "should halt the computation" do + runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do + sem <- atomically Sem.new - describe "when the semaphore is not set" $ it "returns False" do - result <- runEff . runConcurrent . atomically $ do - sem <- Sem.new - Sem.peek sem - result `shouldBe` False + thread <- Conc.fork do + atomically $ Sem.wait sem + put 1 - it "does not change the state of the semaphore" do - (before, after) <- runEff . runConcurrent . atomically $ do - sem <- Sem.newSet - before <- Sem.peek sem - after <- Sem.peek sem - pure (before, after) - (before, after) `shouldBe` (True, True) + a1 <- get + liftIO $ a1 @?= 0 - describe "withSemaphore" do - it "returns the result of the enclosed computation" do - result <- runEff . runConcurrent $ do - sem <- atomically Sem.newSet - Sem.withSemaphore sem $ pure (42 :: Int) - result `shouldBe` 42 + atomically $ Sem.signal sem - it "signals the semaphore after the computation" do - result <- runEff . runConcurrent $ do - sem <- atomically Sem.newSet - Sem.withSemaphore sem $ pure () - atomically $ Sem.peek sem - result `shouldBe` True + Conc.await thread - it "waits for the semaphore before running" do - result <- runEff . runConcurrent . Conc.runConc $ do - sem <- atomically Sem.new - ref <- liftIO $ IORef.newIORef False - _ <- Conc.fork $ do - liftIO $ IORef.writeIORef ref True - atomically $ Sem.signal sem - Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref - result `shouldBe` True + a2 <- get + liftIO $ a2 @?= 1 + ] + , testGroup + "signal" + [ testCase "sets the semaphore" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + Sem.signal sem + Sem.peek sem + result @?= True + ] + , testGroup + "clear" + [ testGroup + "when the semaphore was set" + [ testCase "returns True" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + Sem.unset sem + result @?= True + ] + , testGroup + "when the semaphore was not set" + [ testCase "returns False" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + Sem.unset sem + result @?= False + ] + , testCase "leaves the semaphore clear" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + _ <- Sem.unset sem + Sem.peek sem + result @?= False + ] + , testGroup + "reset" + [ testGroup + "when the semaphore was not set" + [ testCase "returns True" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + Sem.set sem + result @?= True + ] + , testGroup + "when the semaphore was already set" + [ testCase "returns False" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + Sem.set sem + result @?= False + ] + , testCase "leaves the semaphore set" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + _ <- Sem.set sem + Sem.peek sem + result @?= True + ] + , testGroup + "peek" + [ testGroup + "when the semaphore is set" + [ testCase "returns True" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + Sem.peek sem + result @?= True + ] + , testGroup + "when the semaphore is not set" + [ testCase "returns False" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + Sem.peek sem + result @?= False + ] + , testCase "does not change the state of the semaphore" do + (before, after) <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + before <- Sem.peek sem + after <- Sem.peek sem + pure (before, after) + (before, after) @?= (True, True) + ] + , testGroup + "withSemaphore" + [ testCase "returns the result of the enclosed computation" do + result <- runEff . runConcurrent $ do + sem <- atomically Sem.newSet + Sem.withSemaphore sem $ pure (42 :: Int) + result @?= 42 + , testCase "signals the semaphore after the computation" do + result <- runEff . runConcurrent $ do + sem <- atomically Sem.newSet + Sem.withSemaphore sem $ pure () + atomically $ Sem.peek sem + result @?= True + , testCase "waits for the semaphore before running" do + result <- runEff . runConcurrent . Conc.runConc $ do + sem <- atomically Sem.new + ref <- liftIO $ IORef.newIORef False + _ <- Conc.fork $ do + liftIO $ IORef.writeIORef ref True + atomically $ Sem.signal sem + Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref + result @?= True + ] + ] diff --git a/test/Unit/Atelier/Types/SemaphoreSpec.hs b/test/Unit/Atelier/Types/SemaphoreSpec.hs --- a/test/Unit/Atelier/Types/SemaphoreSpec.hs +++ b/test/Unit/Atelier/Types/SemaphoreSpec.hs @@ -1,9 +1,10 @@ -module Unit.Atelier.Types.SemaphoreSpec (spec_Semaphore) where +module Unit.Atelier.Types.SemaphoreSpec (test_Semaphore) where import Effectful (runEff) import Effectful.Concurrent (runConcurrent) import Effectful.State.Static.Shared (evalState, get, put) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Data.IORef qualified as IORef @@ -11,115 +12,136 @@ import Atelier.Types.Semaphore qualified as Sem -spec_Semaphore :: Spec -spec_Semaphore = do - describe "wait" $ it "should halt the computation" do - runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do - sem <- Sem.new - - thread <- Conc.fork do - Sem.wait sem - put 1 - - a1 <- get - liftIO $ a1 `shouldBe` 0 - - Sem.signal sem - - Conc.await thread - - a2 <- get - liftIO $ a2 `shouldBe` 1 - - describe "signal" do - it "sets the semaphore" do - result <- runEff . runConcurrent $ do - sem <- Sem.new - Sem.signal sem - Sem.peek sem - result `shouldBe` True - - describe "clear" do - describe "when the semaphore was set" $ it "returns True" do - result <- runEff . runConcurrent $ do - sem <- Sem.newSet - Sem.unset sem - result `shouldBe` True - - describe "when the semaphore was not set" $ it "returns False" do - result <- runEff . runConcurrent $ do - sem <- Sem.new - Sem.unset sem - result `shouldBe` False - - it "leaves the semaphore clear" do - result <- runEff . runConcurrent $ do - sem <- Sem.newSet - _ <- Sem.unset sem - Sem.peek sem - result `shouldBe` False - - describe "reset" do - describe "when the semaphore was not set" $ it "returns True" do - result <- runEff . runConcurrent $ do - sem <- Sem.new - Sem.set sem - result `shouldBe` True - - describe "when the semaphore was already set" $ it "returns False" do - result <- runEff . runConcurrent $ do - sem <- Sem.newSet - Sem.set sem - result `shouldBe` False - - it "leaves the semaphore set" do - result <- runEff . runConcurrent $ do - sem <- Sem.new - _ <- Sem.set sem - Sem.peek sem - result `shouldBe` True - - describe "peek" do - describe "when the semaphore is set" $ it "returns True" do - result <- runEff . runConcurrent $ do - sem <- Sem.newSet - Sem.peek sem - result `shouldBe` True +test_Semaphore :: TestTree +test_Semaphore = + testGroup + "Semaphore" + [ testGroup + "wait" + [ testCase "should halt the computation" do + runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do + sem <- Sem.new - describe "when the semaphore is not set" $ it "returns False" do - result <- runEff . runConcurrent $ do - sem <- Sem.new - Sem.peek sem - result `shouldBe` False + thread <- Conc.fork do + Sem.wait sem + put 1 - it "does not change the state of the semaphore" do - (before, after) <- runEff . runConcurrent $ do - sem <- Sem.newSet - before <- Sem.peek sem - after <- Sem.peek sem - pure (before, after) - (before, after) `shouldBe` (True, True) + a1 <- get + liftIO $ a1 @?= 0 - describe "withSemaphore" do - it "returns the result of the enclosed computation" do - result <- runEff . runConcurrent $ do - sem <- Sem.newSet - Sem.withSemaphore sem $ pure (42 :: Int) - result `shouldBe` 42 + Sem.signal sem - it "signals the semaphore after the computation" do - result <- runEff . runConcurrent $ do - sem <- Sem.newSet - Sem.withSemaphore sem $ pure () - Sem.peek sem - result `shouldBe` True + Conc.await thread - it "waits for the semaphore before running" do - result <- runEff . runConcurrent . Conc.runConc $ do - sem <- Sem.new - ref <- liftIO $ IORef.newIORef False - _ <- Conc.fork $ do - liftIO $ IORef.writeIORef ref True + a2 <- get + liftIO $ a2 @?= 1 + ] + , testGroup + "signal" + [ testCase "sets the semaphore" do + result <- runEff . runConcurrent $ do + sem <- Sem.new Sem.signal sem - Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref - result `shouldBe` True + Sem.peek sem + result @?= True + ] + , testGroup + "clear" + [ testGroup + "when the semaphore was set" + [ testCase "returns True" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.unset sem + result @?= True + ] + , testGroup + "when the semaphore was not set" + [ testCase "returns False" do + result <- runEff . runConcurrent $ do + sem <- Sem.new + Sem.unset sem + result @?= False + ] + , testCase "leaves the semaphore clear" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + _ <- Sem.unset sem + Sem.peek sem + result @?= False + ] + , testGroup + "reset" + [ testGroup + "when the semaphore was not set" + [ testCase "returns True" do + result <- runEff . runConcurrent $ do + sem <- Sem.new + Sem.set sem + result @?= True + ] + , testGroup + "when the semaphore was already set" + [ testCase "returns False" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.set sem + result @?= False + ] + , testCase "leaves the semaphore set" do + result <- runEff . runConcurrent $ do + sem <- Sem.new + _ <- Sem.set sem + Sem.peek sem + result @?= True + ] + , testGroup + "peek" + [ testGroup + "when the semaphore is set" + [ testCase "returns True" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.peek sem + result @?= True + ] + , testGroup + "when the semaphore is not set" + [ testCase "returns False" do + result <- runEff . runConcurrent $ do + sem <- Sem.new + Sem.peek sem + result @?= False + ] + , testCase "does not change the state of the semaphore" do + (before, after) <- runEff . runConcurrent $ do + sem <- Sem.newSet + before <- Sem.peek sem + after <- Sem.peek sem + pure (before, after) + (before, after) @?= (True, True) + ] + , testGroup + "withSemaphore" + [ testCase "returns the result of the enclosed computation" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.withSemaphore sem $ pure (42 :: Int) + result @?= 42 + , testCase "signals the semaphore after the computation" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.withSemaphore sem $ pure () + Sem.peek sem + result @?= True + , testCase "waits for the semaphore before running" do + result <- runEff . runConcurrent . Conc.runConc $ do + sem <- Sem.new + ref <- liftIO $ IORef.newIORef False + _ <- Conc.fork $ do + liftIO $ IORef.writeIORef ref True + Sem.signal sem + Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref + result @?= True + ] + ] diff --git a/test/Unit/Atelier/Types/WithDefaultsSpec.hs b/test/Unit/Atelier/Types/WithDefaultsSpec.hs --- a/test/Unit/Atelier/Types/WithDefaultsSpec.hs +++ b/test/Unit/Atelier/Types/WithDefaultsSpec.hs @@ -1,8 +1,9 @@ -module Unit.Atelier.Types.WithDefaultsSpec (spec_WithDefaults) where +module Unit.Atelier.Types.WithDefaultsSpec (test_WithDefaults) where import Data.Aeson (FromJSON, ToJSON, eitherDecode) import Data.Default (Default (..)) -import Test.Hspec +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) import Data.ByteString.Lazy qualified as LBS @@ -33,31 +34,33 @@ decodeWithDefaults bs = getQuietSnake . getWithDefaults <$> eitherDecode @(WithDefaults (QuietSnake Fixture)) bs -spec_WithDefaults :: Spec -spec_WithDefaults = do - describe "WithDefaults" do - it "falls back to Default values for missing non-Maybe fields" do - let result = decodeWithDefaults "{}" - result `shouldBe` Right def - - it "uses provided values when all fields are present" do - let result = - decodeWithDefaults - "{\"required_field\": \"hello\", \"items\": [\"a\", \"b\"], \"count\": 42}" - result - `shouldBe` Right - Fixture - { requiredField = "hello" - , items = ["a", "b"] - , count = 42 - } - - it "partial object: provided fields override defaults, missing fall back" do - let result = decodeWithDefaults "{\"count\": 7}" - result - `shouldBe` Right - def {count = 7} - - it "explicitly provided empty list overrides the default list" do - let result = decodeWithDefaults "{\"items\": []}" - result `shouldBe` Right def {items = []} +test_WithDefaults :: TestTree +test_WithDefaults = + testGroup + "WithDefaults" + [ testGroup + "WithDefaults" + [ testCase "falls back to Default values for missing non-Maybe fields" do + let result = decodeWithDefaults "{}" + result @?= Right def + , testCase "uses provided values when all fields are present" do + let result = + decodeWithDefaults + "{\"required_field\": \"hello\", \"items\": [\"a\", \"b\"], \"count\": 42}" + result + @?= Right + Fixture + { requiredField = "hello" + , items = ["a", "b"] + , count = 42 + } + , testCase "partial object: provided fields override defaults, missing fall back" do + let result = decodeWithDefaults "{\"count\": 7}" + result + @?= Right + def {count = 7} + , testCase "explicitly provided empty list overrides the default list" do + let result = decodeWithDefaults "{\"items\": []}" + result @?= Right def {items = []} + ] + ]