atelier-core 0.7.2.0 → 0.7.3.0
raw patch · 23 files changed
+1691/−1507 lines, 23 filesdep +tasty-hedgehogdep +tasty-hunitdep −hspecdep −hspec-hedgehogdep −tasty-hspecPVP ok
version bump matches the API change (PVP)
Dependencies added: tasty-hedgehog, tasty-hunit
Dependencies removed: hspec, hspec-hedgehog, tasty-hspec
API changes (from Hackage documentation)
+ Atelier.Effects.FileSystem: [GetModificationTime] :: forall (a :: Type -> Type). FilePath -> FileSystem a UTCTime
+ Atelier.Effects.FileSystem: getModificationTime :: forall (es :: [Effect]). (HasCallStack, FileSystem :> es) => FilePath -> Eff es UTCTime
Files
- CHANGELOG.md +6/−0
- atelier-core.cabal +4/−5
- src/Atelier/Effects/FileSystem.hs +8/−0
- test/Unit/Atelier/ConfigSpec.hs +28/−30
- test/Unit/Atelier/Effects/AwaitSpec.hs +48/−38
- test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs +196/−182
- test/Unit/Atelier/Effects/CacheSpec.hs +144/−148
- test/Unit/Atelier/Effects/ChanSpec.hs +67/−61
- test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs +70/−63
- test/Unit/Atelier/Effects/ConcSpec.hs +97/−85
- test/Unit/Atelier/Effects/ConsoleSpec.hs +40/−32
- test/Unit/Atelier/Effects/DebounceSpec.hs +143/−117
- test/Unit/Atelier/Effects/FileSystemSpec.hs +95/−89
- test/Unit/Atelier/Effects/FileWatcherSpec.hs +62/−56
- test/Unit/Atelier/Effects/IteratorSpec.hs +36/−34
- test/Unit/Atelier/Effects/LogSpec.hs +70/−65
- test/Unit/Atelier/Effects/Publishing/PubSpec.hs +46/−37
- test/Unit/Atelier/Effects/PublishingSpec.hs +39/−35
- test/Unit/Atelier/Effects/TallySpec.hs +64/−59
- test/Unit/Atelier/Effects/YieldSpec.hs +134/−124
- test/Unit/Atelier/Types/Semaphore/STMSpec.hs +131/−109
- test/Unit/Atelier/Types/SemaphoreSpec.hs +130/−108
- test/Unit/Atelier/Types/WithDefaultsSpec.hs +33/−30
CHANGELOG.md view
@@ -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
atelier-core.cabal view
@@ -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)
src/Atelier/Effects/FileSystem.hs view
@@ -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
test/Unit/Atelier/ConfigSpec.hs view
@@ -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}
test/Unit/Atelier/Effects/AwaitSpec.hs view
@@ -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
test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs view
@@ -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+ ]+ ]+ ]
test/Unit/Atelier/Effects/CacheSpec.hs view
@@ -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)
test/Unit/Atelier/Effects/ChanSpec.hs view
@@ -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])+ ]+ ]+ ] --------------------------------------------------------------------------------
test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs view
@@ -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
test/Unit/Atelier/Effects/ConcSpec.hs view
@@ -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+ ]+ ] --------------------------------------------------------------------------------
test/Unit/Atelier/Effects/ConsoleSpec.hs view
@@ -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"]+ ]+ ]
test/Unit/Atelier/Effects/DebounceSpec.hs view
@@ -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))
test/Unit/Atelier/Effects/FileSystemSpec.hs view
@@ -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
test/Unit/Atelier/Effects/FileWatcherSpec.hs view
@@ -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]+ ]+ ] --------------------------------------------------------------------------------
test/Unit/Atelier/Effects/IteratorSpec.hs view
@@ -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]+ ] --------------------------------------------------------------------------------
test/Unit/Atelier/Effects/LogSpec.hs view
@@ -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")+ ]+ ]+ ]+ ]
test/Unit/Atelier/Effects/Publishing/PubSpec.hs view
@@ -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"]+ ]+ ]
test/Unit/Atelier/Effects/PublishingSpec.hs view
@@ -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")+ ]+ ] --------------------------------------------------------------------------------
test/Unit/Atelier/Effects/TallySpec.hs view
@@ -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]+ ]+ ] --------------------------------------------------------------------------------
test/Unit/Atelier/Effects/YieldSpec.hs view
@@ -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]+ ]
test/Unit/Atelier/Types/Semaphore/STMSpec.hs view
@@ -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+ ]+ ]
test/Unit/Atelier/Types/SemaphoreSpec.hs view
@@ -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+ ]+ ]
test/Unit/Atelier/Types/WithDefaultsSpec.hs view
@@ -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 = []}+ ]+ ]