linear-locks 0.1.0.0 → 0.1.0.1
raw patch · 10 files changed
+571/−594 lines, 10 filesdep +sydtestdep −hspec-expectations-pretty-diffdep −tastydep −tasty-hunit-compat
Dependencies added: sydtest
Dependencies removed: hspec-expectations-pretty-diff, tasty, tasty-hunit-compat
Files
- CHANGELOG.md +6/−2
- linear-locks.cabal +5/−6
- src/LinearLocks/Internal.hs +4/−4
- test/Spec.hs +1/−1
- test/Test/LinearLocks/LockSetSpec.hs +90/−96
- test/Test/LinearLocks/MutexSpec.hs +118/−127
- test/Test/LinearLocks/RWLockSpec.hs +120/−127
- test/Test/LinearLocks/StrictMutexSpec.hs +85/−92
- test/Test/LinearLocks/StrictRWLockSpec.hs +131/−139
- test/Test/LinearLocks/Utils.hs +11/−0
CHANGELOG.md view
@@ -6,6 +6,10 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## Unreleased+## 0.1.0.1 -## 0.1.0.0 - YYYY-MM-DD+Updated test dependencies so the package would be accepted into stackage.++## 0.1.0.0++Initial release
linear-locks.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: linear-locks-version: 0.1.0.0+version: 0.1.0.1 synopsis: Locking primitives free of deadlocks. description: `linear-locks` provides locking primitives that are statically guaranteed to be free of deadlocks. Please see the README on GitHub at <https://github.com/dcastro/linear-locks#readme>@@ -75,6 +75,7 @@ Test.LinearLocks.RWLockSpec Test.LinearLocks.StrictMutexSpec Test.LinearLocks.StrictRWLockSpec+ Test.LinearLocks.Utils Paths_linear_locks autogen-modules: Paths_linear_locks@@ -84,18 +85,16 @@ BlockArguments StrictData TypeFamilies- ghc-options: -Weverything -Wno-name-shadowing -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-export-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-missing-kind-signatures -Wno-missing-role-annotations+ ghc-options: -Weverything -Wno-name-shadowing -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-export-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-missing-kind-signatures -Wno-missing-role-annotations -threaded -rtsopts -with-rtsopts=-N build-tool-depends:- tasty-discover:tasty-discover+ sydtest-discover:sydtest-discover build-depends: base , concurrent-extra- , hspec-expectations-pretty-diff , linear-base , linear-locks , list-t , stm-containers- , tasty- , tasty-hunit-compat+ , sydtest , vector default-language: GHC2024
src/LinearLocks/Internal.hs view
@@ -187,16 +187,16 @@ newId <- Atomic.incrCounter 1 lockIdCounter pure (LockId newId) +----------------------------------------------------------------------------+-- Utils+----------------------------------------------------------------------------+ -- Only provide this orphan instance for linear-base <= 0.7.0 -- The next release will come with this instance built-in: https://github.com/tweag/linear-base/pull/505 #if !MIN_VERSION_linear_base(0,7,1) instance L.MonadIO RIO where liftIO action = RIOInternal.RIO (\_ -> action) #endif--------------------------------------------------------------------------------- Utils----------------------------------------------------------------------------- -- | Similar to 'System.IO.Resource.Linear.release', except it uses a different release action than the one registered by 'System.IO.Resource.Linear.unsafeAcquire'. release' :: RIO.Resource a %1 -> L.IO () -> RIO ()
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}
test/Test/LinearLocks/LockSetSpec.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoFieldSelectors #-} @@ -16,8 +15,7 @@ import LinearLocks.Mutex.Strict qualified as StrictMutex import LinearLocks.RWLock qualified as RWLock import Prelude.Linear (Ur (..))-import Test.Hspec.Expectations.Pretty (shouldNotBe, shouldThrow)-import "tasty-hunit-compat" Test.Tasty.HUnit+import Test.Syd -- | Doctests --@@ -33,119 +31,115 @@ -- ... • Couldn't match type ‘2’ with ‘3’ -- ... arising from a use of ‘newLockSet’ -- ...-unit_read_lock_set :: IO ()-unit_read_lock_set = do- m1 <- Mutex.new 0 "m1"- m2 <- Mutex.new 0 "m2"- m3 <- Mutex.new 0 "m3"- set <- newLockSet (m1, m2, m3)+spec :: Spec+spec = describe "LockSet" do+ it "read lock set" do+ m1 <- Mutex.new 0 "m1"+ m2 <- Mutex.new 0 "m2"+ m3 <- Mutex.new 0 "m3"+ set <- newLockSet (m1, m2, m3) - lockScope \key -> L.do- ((mg1, mg2, mg3), key) <- acquireMany key set+ lockScope \key -> L.do+ ((mg1, mg2, mg3), key) <- acquireMany key set - (Ur str1, mg1) <- Mutex.read mg1- (Ur str2, mg2) <- Mutex.read mg2- (Ur str3, mg3) <- Mutex.read mg3+ (Ur str1, mg1) <- Mutex.read mg1+ (Ur str2, mg2) <- Mutex.read mg2+ (Ur str3, mg3) <- Mutex.read mg3 - L.liftSystemIO do- str1 @?= "m1"- str2 @?= "m2"- str3 @?= "m3"+ L.liftSystemIO do+ str1 `shouldBe` "m1"+ str2 `shouldBe` "m2"+ str3 `shouldBe` "m3" - Mutex.release mg1- Mutex.release mg2- Mutex.release mg3- dropKeyAndReturn key ()+ Mutex.release mg1+ Mutex.release mg2+ Mutex.release mg3+ dropKeyAndReturn key () -unit_write_lock_set :: IO ()-unit_write_lock_set = do- m1 <- Mutex.new 0 "m1"- m2 <- Mutex.new 0 "m2"- m3 <- Mutex.new 0 "m3"- set <- newLockSet (m3, m2, m1)+ it "write lock set" do+ m1 <- Mutex.new 0 "m1"+ m2 <- Mutex.new 0 "m2"+ m3 <- Mutex.new 0 "m3"+ set <- newLockSet (m3, m2, m1) - lockScope \key -> L.do- ((mg3, mg2, mg1), key) <- acquireMany key set+ lockScope \key -> L.do+ ((mg3, mg2, mg1), key) <- acquireMany key set - mg3 <- Mutex.write mg3 "m3 updated"- mg2 <- Mutex.write mg2 "m2 updated"- mg1 <- Mutex.write mg1 "m1 updated"+ mg3 <- Mutex.write mg3 "m3 updated"+ mg2 <- Mutex.write mg2 "m2 updated"+ mg1 <- Mutex.write mg1 "m1 updated" - Mutex.release mg3- Mutex.release mg2- Mutex.release mg1- dropKeyAndReturn key ()+ Mutex.release mg3+ Mutex.release mg2+ Mutex.release mg1+ dropKeyAndReturn key () - lockScope \key -> L.do- ((mg3, mg2, mg1), key) <- acquireMany key set+ lockScope \key -> L.do+ ((mg3, mg2, mg1), key) <- acquireMany key set - (Ur str3, mg3) <- Mutex.read mg3- (Ur str2, mg2) <- Mutex.read mg2- (Ur str1, mg1) <- Mutex.read mg1+ (Ur str3, mg3) <- Mutex.read mg3+ (Ur str2, mg2) <- Mutex.read mg2+ (Ur str1, mg1) <- Mutex.read mg1 - L.liftSystemIO do- str3 @?= "m3 updated"- str2 @?= "m2 updated"- str1 @?= "m1 updated"+ L.liftSystemIO do+ str3 `shouldBe` "m3 updated"+ str2 `shouldBe` "m2 updated"+ str1 `shouldBe` "m1 updated" - Mutex.release mg3- Mutex.release mg2- Mutex.release mg1- dropKeyAndReturn key ()+ Mutex.release mg3+ Mutex.release mg2+ Mutex.release mg1+ dropKeyAndReturn key () -unit_assigns_unique_lock_ids :: IO ()-unit_assigns_unique_lock_ids = do- m1 <- Mutex.new 0 ""- m2 <- Mutex.new 0 ""- m3 <- Mutex.new 0 ""+ it "assigns unique lock ids" do+ m1 <- Mutex.new 0 ""+ m2 <- Mutex.new 0 ""+ m3 <- Mutex.new 0 "" - m1.id `shouldNotBe` m2.id- m2.id `shouldNotBe` m3.id- m1.id `shouldNotBe` m3.id+ m1.id `shouldNotBe` m2.id+ m2.id `shouldNotBe` m3.id+ m1.id `shouldNotBe` m3.id -unit_throws_when_lock_set_contains_duplicates :: IO ()-unit_throws_when_lock_set_contains_duplicates = do- m1 <- Mutex.new 0 ""- m2 <- Mutex.new 0 ""+ it "throws when lock set contains duplicates" do+ m1 <- Mutex.new 0 ""+ m2 <- Mutex.new 0 "" - newLockSet (m1, m2, m1) `shouldThrow` \(err :: IOError) -> err == userError "LockSet: duplicate locks are not allowed"+ newLockSet (m1, m2, m1) `shouldThrow` \(err :: IOError) -> err == userError "LockSet: duplicate locks are not allowed" -unit_sorts_locks_deterministically :: IO ()-unit_sorts_locks_deterministically = do- m1 <- Mutex.new 0 ""- m2 <- Mutex.new 0 ""- m3 <- Mutex.new 0 ""+ it "sorts locks deterministically" do+ let sortedIndices :: forall set. LockSet set -> VU.Vector Int+ sortedIndices (Internal.MkLockSet _ indices) = VU.map (\(Internal.LockSetIndex i) -> i) indices - newLockSet (m1, m2, m3) >>= \set -> sortedIndices set @?= VU.fromList [0, 1, 2]- newLockSet (m2, m1, m3) >>= \set -> sortedIndices set @?= VU.fromList [1, 0, 2]- newLockSet (m3, m1, m2) >>= \set -> sortedIndices set @?= VU.fromList [1, 2, 0]- newLockSet (m1, m3, m2) >>= \set -> sortedIndices set @?= VU.fromList [0, 2, 1]- newLockSet (m2, m3, m1) >>= \set -> sortedIndices set @?= VU.fromList [2, 0, 1]- newLockSet (m3, m2, m1) >>= \set -> sortedIndices set @?= VU.fromList [2, 1, 0]- where- sortedIndices :: forall set. LockSet set -> VU.Vector Int- sortedIndices (Internal.MkLockSet _ indices) = VU.map (\(Internal.LockSetIndex i) -> i) indices+ m1 <- Mutex.new 0 ""+ m2 <- Mutex.new 0 ""+ m3 <- Mutex.new 0 "" -unit_sets_can_have_mixed_lock_types :: IO ()-unit_sets_can_have_mixed_lock_types = do- m1 <- StrictMutex.new 0 "hello"- m2 <- Mutex.new @Int 0 99- m3 <- RWLock.new 0 True- set <- newLockSet (m1, m2, RWLock.AsRead (m3))+ newLockSet (m1, m2, m3) >>= \set -> sortedIndices set `shouldBe` VU.fromList [0, 1, 2]+ newLockSet (m2, m1, m3) >>= \set -> sortedIndices set `shouldBe` VU.fromList [1, 0, 2]+ newLockSet (m3, m1, m2) >>= \set -> sortedIndices set `shouldBe` VU.fromList [1, 2, 0]+ newLockSet (m1, m3, m2) >>= \set -> sortedIndices set `shouldBe` VU.fromList [0, 2, 1]+ newLockSet (m2, m3, m1) >>= \set -> sortedIndices set `shouldBe` VU.fromList [2, 0, 1]+ newLockSet (m3, m2, m1) >>= \set -> sortedIndices set `shouldBe` VU.fromList [2, 1, 0] - lockScope \key -> L.do- ((g1, g2, g3), key) <- acquireMany key set+ it "sets can have mixed lock types" do+ m1 <- StrictMutex.new 0 "hello"+ m2 <- Mutex.new @Int 0 99+ m3 <- RWLock.new 0 True+ set <- newLockSet (m1, m2, RWLock.AsRead m3) - (Ur res1, g1) <- StrictMutex.read g1- (Ur res2, g2) <- Mutex.read g2- (Ur res3, g3) <- RWLock.read g3+ lockScope \key -> L.do+ ((g1, g2, g3), key) <- acquireMany key set - L.liftSystemIO do- res1 @?= "hello"- res2 @?= 99- res3 @?= True+ (Ur res1, g1) <- StrictMutex.read g1+ (Ur res2, g2) <- Mutex.read g2+ (Ur res3, g3) <- RWLock.read g3 - StrictMutex.release g1- Mutex.release g2- RWLock.releaseRead g3- dropKeyAndReturn key ()+ L.liftSystemIO do+ res1 `shouldBe` "hello"+ res2 `shouldBe` 99+ res3 `shouldBe` True++ StrictMutex.release g1+ Mutex.release g2+ RWLock.releaseRead g3+ dropKeyAndReturn key ()
test/Test/LinearLocks/MutexSpec.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoFieldSelectors #-} @@ -22,8 +21,8 @@ import Prelude.Linear (Ur (..)) import Prelude.Linear qualified as L hiding (IO) import StmContainers.Set qualified as StmSet-import Test.Hspec.Expectations.Pretty (anyIOException, shouldThrow)-import "tasty-hunit-compat" Test.Tasty.HUnit+import Test.LinearLocks.Utils+import Test.Syd -- | Doctests --@@ -43,151 +42,143 @@ -- ... • Cannot satisfy: 5 <= 2 -- ... • In a stmt of a 'do' block: (mg1, key) <- Mutex.acquire key m1 -- ...-unit_read_mutex :: IO ()-unit_read_mutex = do- mutex <- Mutex.new 0 "hello"- str <- lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- (Ur str, mg) <- Mutex.read mg- Mutex.release mg- dropKeyAndReturn key str- str @?= "hello"+spec :: Spec+spec = describe "Mutex" do+ it "read mutex" do+ mutex <- Mutex.new 0 "hello"+ str <- lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ (Ur str, mg) <- Mutex.read mg+ Mutex.release mg+ dropKeyAndReturn key str+ str `shouldBe` "hello" -unit_write_mutex :: IO ()-unit_write_mutex = do- mutex <- Mutex.new 0 "hello"- lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- mg <- Mutex.write mg "world"- Mutex.release mg- dropKeyAndReturn key ()+ it "write mutex" do+ mutex <- Mutex.new 0 "hello"+ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ mg <- Mutex.write mg "world"+ Mutex.release mg+ dropKeyAndReturn key () - str <- lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- (Ur str, mg) <- Mutex.read mg- Mutex.release mg- dropKeyAndReturn key str+ str <- lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ (Ur str, mg) <- Mutex.read mg+ Mutex.release mg+ dropKeyAndReturn key str - str @?= "world"+ str `shouldBe` "world" - str <- MVar.readMVar mutex.var- str @?= "world"+ str <- MVar.readMVar mutex.var+ str `shouldBe` "world" -unit_realeases_mvar :: IO ()-unit_realeases_mvar = do- mutex <- Mutex.new 0 "hello"- lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex+ it "realeases mvar" do+ mutex <- Mutex.new 0 "hello"+ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex - L.liftSystemIO do- isEmpty <- MVar.isEmptyMVar mutex.var- isEmpty @?= True+ L.liftSystemIO do+ isEmpty <- MVar.isEmptyMVar mutex.var+ isEmpty `shouldBe` True - Mutex.release mg+ Mutex.release mg - L.liftSystemIO do- isEmpty <- MVar.isEmptyMVar mutex.var- isEmpty @?= False+ L.liftSystemIO do+ isEmpty <- MVar.isEmptyMVar mutex.var+ isEmpty `shouldBe` False - dropKeyAndReturn key ()+ dropKeyAndReturn key () - isEmpty <- MVar.isEmptyMVar mutex.var- isEmpty @?= False+ isEmpty <- MVar.isEmptyMVar mutex.var+ isEmpty `shouldBe` False -unit_cant_nest_lockscopes :: IO ()-unit_cant_nest_lockscopes = do- let run =- lockScope \key -> L.do- L.liftSystemIO do- lockScope \key -> dropKeyAndReturn key ()- dropKeyAndReturn key ()+ it "can't nest lock scopes" do+ let run =+ lockScope \key -> L.do+ L.liftSystemIO do+ lockScope \key -> dropKeyAndReturn key ()+ dropKeyAndReturn key () - run `shouldThrow` \(_ :: NestedLocksScopeException) -> True+ run `shouldThrow` \(_ :: NestedLocksScopeException) -> True -unit_updates_thread_ids :: IO ()-unit_updates_thread_ids = do- tid <- myThreadId+ it "updates thread ids" do+ let getThreadIds :: IO [ThreadId]+ getThreadIds =+ Internal.lockScopes & StmSet.listT & ListT.toList & atomically+ tid <- myThreadId - getThreadIds >>= \tids -> tids @?= []- lockScope \key -> L.do- L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid]- dropKeyAndReturn key ()- getThreadIds >>= \tids -> tids @?= []+ getThreadIds >>= \tids -> tids `shouldNotContain` [tid]+ lockScope \key -> L.do+ L.liftSystemIO L.$ getThreadIds >>= \tids -> tids `shouldContain` [tid]+ dropKeyAndReturn key ()+ getThreadIds >>= \tids -> tids `shouldNotContain` [tid] - -- Check that the thread ID is removed even if an exception is thrown.- let run =- lockScope \key -> L.do- L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid]- L.liftSystemIO L.$ throwIO (userError "oops")- dropKeyAndReturn key ()- run `shouldThrow` anyIOException- getThreadIds >>= \tids -> tids @?= []+ -- Check that the thread ID is removed even if an exception is thrown.+ let run =+ lockScope \key -> L.do+ L.liftSystemIO L.$ getThreadIds >>= \tids -> tids `shouldContain` [tid]+ L.liftSystemIO L.$ throwIO (userError "oops")+ dropKeyAndReturn key ()+ run `shouldThrow` anyIOException+ getThreadIds >>= \tids -> tids `shouldNotContain` [tid] - -- Check that the thread ID is removed even if when a nested lock scope is attempted- let run =- lockScope \key -> L.do- L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid]- L.liftSystemIO do- lockScope \key -> dropKeyAndReturn key ()- dropKeyAndReturn key ()- run `shouldThrow` \(_ :: NestedLocksScopeException) -> True- getThreadIds >>= \tids -> tids @?= []+ -- Check that the thread ID is removed even if when a nested lock scope is attempted+ let run =+ lockScope \key -> L.do+ L.liftSystemIO L.$ getThreadIds >>= \tids -> tids `shouldContain` [tid]+ L.liftSystemIO do+ lockScope \key -> dropKeyAndReturn key ()+ dropKeyAndReturn key ()+ run `shouldThrow` \(_ :: NestedLocksScopeException) -> True+ getThreadIds >>= \tids -> tids `shouldNotContain` [tid] - -- Check that the thread ID is NOT removed if a nested lock scope is caught- lockScope \key -> L.do- L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid]- L.liftSystemIO do- Left _ <- try @SomeException $ lockScope \key -> dropKeyAndReturn key ()- pure ()- L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid]- dropKeyAndReturn key ()- getThreadIds >>= \tids -> tids @?= []- where- getThreadIds :: IO [ThreadId]- getThreadIds =- Internal.lockScopes & StmSet.listT & ListT.toList & atomically+ -- Check that the thread ID is NOT removed if a nested lock scope is caught+ lockScope \key -> L.do+ L.liftSystemIO L.$ getThreadIds >>= \tids -> tids `shouldContain` [tid]+ L.liftSystemIO do+ Left _ <- try @SomeException $ lockScope \key -> dropKeyAndReturn key ()+ pure ()+ L.liftSystemIO L.$ getThreadIds >>= \tids -> tids `shouldContain` [tid]+ dropKeyAndReturn key ()+ getThreadIds >>= \tids -> tids `shouldNotContain` [tid] -unit_rolls_back_on_exception :: IO ()-unit_rolls_back_on_exception = do- mutex <- Mutex.new 0 "hello"- Left _ <- try @SomeException $ lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- mg <- Mutex.write mg "world"- L.liftSystemIO L.$ throwIO (userError "oops")- Mutex.release mg- dropKeyAndReturn key ()+ it "rolls back on exception" do+ mutex <- Mutex.new 0 "hello"+ Left _ <- try @SomeException $ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ mg <- Mutex.write mg "world"+ L.liftSystemIO L.$ throwIO (userError "oops")+ Mutex.release mg+ dropKeyAndReturn key () - -- The MVar should have been released, and the original value should have been put back into the MVar.- mbResult <- MVar.tryTakeMVar mutex.var- mbResult @?= Just "hello"+ -- The MVar should have been released, and the original value should have been put back into the MVar.+ mbResult <- MVar.tryTakeMVar mutex.var+ mbResult `shouldBe` Just "hello" -unit_rolls_back_on_imprecise_exception :: IO ()-unit_rolls_back_on_imprecise_exception = do- mutex <- Mutex.new 0 "hello"- Left _ <- try @SomeException $ lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- mg <- Mutex.write mg "world"- error "err"- Mutex.release mg- dropKeyAndReturn key ()+ it "rolls back on imprecise exception" do+ mutex <- Mutex.new 0 "hello"+ Left _ <- try @SomeException $ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ mg <- Mutex.write mg "world"+ error "err"+ Mutex.release mg+ dropKeyAndReturn key () - -- The MVar should have been released, and the original value should have been put back into the MVar.- mbResult <- MVar.tryTakeMVar mutex.var- mbResult @?= Just "hello"+ -- The MVar should have been released, and the original value should have been put back into the MVar.+ mbResult <- MVar.tryTakeMVar mutex.var+ mbResult `shouldBe` Just "hello" -unit_new_doesnt_evaluate_value_to_normal_form :: IO ()-unit_new_doesnt_evaluate_value_to_normal_form = do- -- This should not throw, the "error" thunk should not be evaluated- void $ Mutex.new @[Int] 0 [1, 2, error "oops", 4]+ it "new doesn't evaluate value to normal form" do+ -- This should not throw, the "error" thunk should not be evaluated+ void $ Mutex.new @[Int] 0 [1, 2, error "oops", 4] -unit_release_doesnt_evaluate_value_to_normal_form :: IO ()-unit_release_doesnt_evaluate_value_to_normal_form = do- mutex <- Mutex.new @[Int] 0 [1]+ it "release doesn't evaluate value to normal form" do+ mutex <- Mutex.new @[Int] 0 [1] - lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- -- This should not throw, the "error" thunk should not be evaluated- mg <- Mutex.write mg [1, 2, error "oops", 4]- -- This should not throw- Mutex.release mg- dropKeyAndReturn key ()+ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ -- This should not throw, the "error" thunk should not be evaluated+ mg <- Mutex.write mg [1, 2, error "oops", 4]+ -- This should not throw+ Mutex.release mg+ dropKeyAndReturn key ()
test/Test/LinearLocks/RWLockSpec.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoFieldSelectors #-} @@ -17,7 +16,7 @@ import LinearLocks.RWLock qualified as RWLock import Prelude.Linear (Ur (..)) import Prelude.Linear qualified as L hiding (IO)-import "tasty-hunit-compat" Test.Tasty.HUnit+import Test.Syd -- | Doctests --@@ -37,159 +36,153 @@ -- ... • Cannot satisfy: 5 <= 2 -- ... • In a stmt of a 'do' block: (g1, key) <- RWLock.acquireRead key m1 -- ...-unit_read_mutex :: IO ()-unit_read_mutex = do- rwl <- RWLock.new 0 "hello"- -- Read in "read mode"- str <- lockScope \key -> L.do- (guard, key) <- RWLock.acquireRead key rwl- (Ur str, guard) <- RWLock.read guard- RWLock.releaseRead guard- dropKeyAndReturn key str- str @?= "hello"+spec :: Spec+spec = describe "RWLock" do+ it "read mutex" do+ rwl <- RWLock.new 0 "hello"+ -- Read in "read mode"+ str <- lockScope \key -> L.do+ (guard, key) <- RWLock.acquireRead key rwl+ (Ur str, guard) <- RWLock.read guard+ RWLock.releaseRead guard+ dropKeyAndReturn key str+ str `shouldBe` "hello" - -- Read in "write mode"- str <- lockScope \key -> L.do- (guard, key) <- RWLock.acquireWrite key rwl- (Ur str, guard) <- RWLock.read guard- RWLock.releaseWrite guard- dropKeyAndReturn key str- str @?= "hello"+ -- Read in "write mode"+ str <- lockScope \key -> L.do+ (guard, key) <- RWLock.acquireWrite key rwl+ (Ur str, guard) <- RWLock.read guard+ RWLock.releaseWrite guard+ dropKeyAndReturn key str+ str `shouldBe` "hello" -unit_write_mutex :: IO ()-unit_write_mutex = do- rwl <- RWLock.new 0 "hello"+ it "write mutex" do+ rwl <- RWLock.new 0 "hello" - -- Write in "write mode"- lockScope \key -> L.do- (guard, key) <- RWLock.acquireWrite key rwl- guard <- RWLock.write guard "world"- RWLock.releaseWrite guard- dropKeyAndReturn key ()+ -- Write in "write mode"+ lockScope \key -> L.do+ (guard, key) <- RWLock.acquireWrite key rwl+ guard <- RWLock.write guard "world"+ RWLock.releaseWrite guard+ dropKeyAndReturn key () - -- Read in "read mode"- str <- lockScope \key -> L.do- (guard, key) <- RWLock.acquireRead key rwl- (Ur str, guard) <- RWLock.read guard- RWLock.releaseRead guard- dropKeyAndReturn key str- str @?= "world"+ -- Read in "read mode"+ str <- lockScope \key -> L.do+ (guard, key) <- RWLock.acquireRead key rwl+ (Ur str, guard) <- RWLock.read guard+ RWLock.releaseRead guard+ dropKeyAndReturn key str+ str `shouldBe` "world" - -- Read in "write mode"- str <- lockScope \key -> L.do- (guard, key) <- RWLock.acquireWrite key rwl- (Ur str, guard) <- RWLock.read guard- RWLock.releaseWrite guard- dropKeyAndReturn key str- str @?= "world"+ -- Read in "write mode"+ str <- lockScope \key -> L.do+ (guard, key) <- RWLock.acquireWrite key rwl+ (Ur str, guard) <- RWLock.read guard+ RWLock.releaseWrite guard+ dropKeyAndReturn key str+ str `shouldBe` "world" - str <- IORef.readIORef rwl.var- str @?= "world"+ str <- IORef.readIORef rwl.var+ str `shouldBe` "world" -unit_realeases_ioref_in_read_mode :: IO ()-unit_realeases_ioref_in_read_mode = do- rwl <- RWLock.new 0 "hello"- lockScope \key -> L.do- (mg, key) <- RWLock.acquireRead key rwl+ it "realeases ioref in read mode" do+ rwl <- RWLock.new 0 "hello"+ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireRead key rwl - -- If the lock was acquired in "read mode",- -- we shouldn't be able to acquire it again in "write mode",- -- but we should be able to acquire it in "read mode".- L.liftSystemIO do- assertCanRead rwl True- assertCanWrite rwl False+ -- If the lock was acquired in "read mode",+ -- we shouldn't be able to acquire it again in "write mode",+ -- but we should be able to acquire it in "read mode".+ L.liftSystemIO do+ assertCanRead rwl True+ assertCanWrite rwl False - RWLock.releaseRead mg+ RWLock.releaseRead mg - -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".- L.liftSystemIO do- assertCanRead rwl True- assertCanWrite rwl True+ -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".+ L.liftSystemIO do+ assertCanRead rwl True+ assertCanWrite rwl True - dropKeyAndReturn key ()+ dropKeyAndReturn key () - -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".- assertCanRead rwl True- assertCanWrite rwl True+ -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".+ assertCanRead rwl True+ assertCanWrite rwl True -unit_realeases_ioref_in_write_mode :: IO ()-unit_realeases_ioref_in_write_mode = do- rwl <- RWLock.new 0 "hello"- lockScope \key -> L.do- (mg, key) <- RWLock.acquireWrite key rwl+ it "realeases ioref in write mode" do+ rwl <- RWLock.new 0 "hello"+ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireWrite key rwl - -- If the lock was acquired in "write mode",- -- we shouldn't be able to acquire it again in "write mode" or "read mode".- L.liftSystemIO do- assertCanRead rwl False- assertCanWrite rwl False+ -- If the lock was acquired in "write mode",+ -- we shouldn't be able to acquire it again in "write mode" or "read mode".+ L.liftSystemIO do+ assertCanRead rwl False+ assertCanWrite rwl False - RWLock.releaseWrite mg+ RWLock.releaseWrite mg - -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".- L.liftSystemIO do- assertCanRead rwl True- assertCanWrite rwl True+ -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".+ L.liftSystemIO do+ assertCanRead rwl True+ assertCanWrite rwl True - dropKeyAndReturn key ()+ dropKeyAndReturn key () - -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".- assertCanRead rwl True- assertCanWrite rwl True+ -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".+ assertCanRead rwl True+ assertCanWrite rwl True -unit_rolls_back_on_exception :: IO ()-unit_rolls_back_on_exception = do- rwl <- RWLock.new 0 "hello"- Left _ <- try @SomeException $ lockScope \key -> L.do- (mg, key) <- RWLock.acquireWrite key rwl- mg <- RWLock.write mg "world"- L.liftSystemIO L.$ throwIO (userError "oops")- RWLock.releaseWrite mg- dropKeyAndReturn key ()+ it "rolls back on exception" do+ rwl <- RWLock.new 0 "hello"+ Left _ <- try @SomeException $ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireWrite key rwl+ mg <- RWLock.write mg "world"+ L.liftSystemIO L.$ throwIO (userError "oops")+ RWLock.releaseWrite mg+ dropKeyAndReturn key () - -- The IORef should have been released, and the original value should have been put back into the IORef.- assertCanRead rwl True- assertCanWrite rwl True- mbResult <- IORef.readIORef rwl.var- mbResult @?= "hello"+ -- The IORef should have been released, and the original value should have been put back into the IORef.+ assertCanRead rwl True+ assertCanWrite rwl True+ mbResult <- IORef.readIORef rwl.var+ mbResult `shouldBe` "hello" -unit_rolls_back_on_imprecise_exception :: IO ()-unit_rolls_back_on_imprecise_exception = do- rwl <- RWLock.new 0 "hello"- Left _ <- try @SomeException $ lockScope \key -> L.do- (mg, key) <- RWLock.acquireWrite key rwl- mg <- RWLock.write mg "world"- error "err"- RWLock.releaseWrite mg- dropKeyAndReturn key ()+ it "rolls back on imprecise exception" do+ rwl <- RWLock.new 0 "hello"+ Left _ <- try @SomeException $ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireWrite key rwl+ mg <- RWLock.write mg "world"+ error "err"+ RWLock.releaseWrite mg+ dropKeyAndReturn key () - -- The IORef should have been released, and the original value should have been put back into the IORef.- assertCanRead rwl True- assertCanWrite rwl True- mbResult <- IORef.readIORef rwl.var- mbResult @?= "hello"+ -- The IORef should have been released, and the original value should have been put back into the IORef.+ assertCanRead rwl True+ assertCanWrite rwl True+ mbResult <- IORef.readIORef rwl.var+ mbResult `shouldBe` "hello" -unit_new_doesnt_evaluate_value_to_normal_form :: IO ()-unit_new_doesnt_evaluate_value_to_normal_form = do- -- This should not throw, the "error" thunk should not be evaluated- void $ RWLock.new @[Int] 0 [1, 2, error "oops", 4]+ it "new doesn't evaluate value to normal form" do+ -- This should not throw, the "error" thunk should not be evaluated+ void $ RWLock.new @[Int] 0 [1, 2, error "oops", 4] -unit_release_doesnt_evaluate_value_to_normal_form :: IO ()-unit_release_doesnt_evaluate_value_to_normal_form = do- mutex <- RWLock.new @[Int] 0 [1]+ it "release doesn't evaluate value to normal form" do+ mutex <- RWLock.new @[Int] 0 [1] - lockScope \key -> L.do- (mg, key) <- RWLock.acquireWrite key mutex- -- This should not throw, the "error" thunk should not be evaluated- mg <- RWLock.write mg [1, 2, error "oops", 4]- -- This should not throw- RWLock.releaseWrite mg- dropKeyAndReturn key ()+ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireWrite key mutex+ -- This should not throw, the "error" thunk should not be evaluated+ mg <- RWLock.write mg [1, 2, error "oops", 4]+ -- This should not throw+ RWLock.releaseWrite mg+ dropKeyAndReturn key () assertCanRead :: RWLock.RWLock lvl a -> Bool -> IO () assertCanRead rwl expected = do canRead <- Conc.tryAcquireRead rwl.lock- canRead @?= expected+ canRead `shouldBe` expected -- Release the lock if it was acquired. when canRead do Conc.releaseRead rwl.lock@@ -197,7 +190,7 @@ assertCanWrite :: RWLock.RWLock lvl a -> Bool -> IO () assertCanWrite rwl expected = do canWrite <- Conc.tryAcquireWrite rwl.lock- canWrite @?= expected+ canWrite `shouldBe` expected -- Release the lock if it was acquired. when canWrite do Conc.releaseWrite rwl.lock
test/Test/LinearLocks/StrictMutexSpec.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoFieldSelectors #-} @@ -17,8 +16,7 @@ import Prelude.Linear (Ur (..)) import Prelude.Linear qualified as L hiding (IO) import System.IO.Resource.Linear (RIO)-import Test.Hspec.Expectations.Pretty (errorCall, shouldThrow)-import "tasty-hunit-compat" Test.Tasty.HUnit+import Test.Syd -- | Doctests --@@ -38,112 +36,107 @@ -- ... • Cannot satisfy: 5 <= 2 -- ... • In a stmt of a 'do' block: (mg1, key) <- Mutex.acquire key m1 -- ...-unit_read_mutex :: IO ()-unit_read_mutex = do- mutex <- Mutex.new 0 "hello"- str <- lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- (Ur str, mg) <- Mutex.read mg- Mutex.release mg- dropKeyAndReturn key str- str @?= "hello"+spec :: Spec+spec = describe "Strict Mutex" do+ it "read mutex" do+ mutex <- Mutex.new 0 "hello"+ str <- lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ (Ur str, mg) <- Mutex.read mg+ Mutex.release mg+ dropKeyAndReturn key str+ str `shouldBe` "hello" -unit_write_mutex :: IO ()-unit_write_mutex = do- mutex <- Mutex.new 0 "hello"- lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- mg <- Mutex.write mg "world"- Mutex.release mg- dropKeyAndReturn key ()+ it "write mutex" do+ mutex <- Mutex.new 0 "hello"+ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ mg <- Mutex.write mg "world"+ Mutex.release mg+ dropKeyAndReturn key () - str <- lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- (Ur str, mg) <- Mutex.read mg- Mutex.release mg- dropKeyAndReturn key str+ str <- lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ (Ur str, mg) <- Mutex.read mg+ Mutex.release mg+ dropKeyAndReturn key str - str @?= "world"+ str `shouldBe` "world" - str <- MVar.readMVar mutex.var- str.unNF @?= "world"+ str <- MVar.readMVar mutex.var+ str.unNF `shouldBe` "world" -unit_realeases_mvar :: IO ()-unit_realeases_mvar = do- mutex <- Mutex.new 0 "hello"- lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex+ it "realeases mvar" do+ mutex <- Mutex.new 0 "hello"+ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex - L.liftSystemIO do- isEmpty <- MVar.isEmptyMVar mutex.var- isEmpty @?= True+ L.liftSystemIO do+ isEmpty <- MVar.isEmptyMVar mutex.var+ isEmpty `shouldBe` True - Mutex.release mg+ Mutex.release mg - L.liftSystemIO do- isEmpty <- MVar.isEmptyMVar mutex.var- isEmpty @?= False+ L.liftSystemIO do+ isEmpty <- MVar.isEmptyMVar mutex.var+ isEmpty `shouldBe` False - dropKeyAndReturn key ()+ dropKeyAndReturn key () - isEmpty <- MVar.isEmptyMVar mutex.var- isEmpty @?= False+ isEmpty <- MVar.isEmptyMVar mutex.var+ isEmpty `shouldBe` False -unit_rolls_back_on_exception :: IO ()-unit_rolls_back_on_exception = do- mutex <- Mutex.new 0 "hello"- Left _ <- try @SomeException $ lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- mg <- Mutex.write mg "world"- L.liftSystemIO L.$ throwIO (userError "oops")- Mutex.release mg- dropKeyAndReturn key ()+ it "rolls back on exception" do+ mutex <- Mutex.new 0 "hello"+ Left _ <- try @SomeException $ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ mg <- Mutex.write mg "world"+ L.liftSystemIO L.$ throwIO (userError "oops")+ Mutex.release mg+ dropKeyAndReturn key () - -- The MVar should have been released, and the original value should have been put back into the MVar.- mbResult <- MVar.tryTakeMVar mutex.var- mbResult @?= Just (Internal.mkNF "hello")+ -- The MVar should have been released, and the original value should have been put back into the MVar.+ mbResult <- MVar.tryTakeMVar mutex.var+ mbResult `shouldBe` Just (Internal.mkNF "hello") -unit_rolls_back_on_imprecise_exception :: IO ()-unit_rolls_back_on_imprecise_exception = do- mutex <- Mutex.new 0 "hello"- Left _ <- try @SomeException $ lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- mg <- Mutex.write mg "world"- error "err"- Mutex.release mg- dropKeyAndReturn key ()+ it "rolls back on imprecise exception" do+ mutex <- Mutex.new 0 "hello"+ Left _ <- try @SomeException $ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ mg <- Mutex.write mg "world"+ error "err"+ Mutex.release mg+ dropKeyAndReturn key () - -- The MVar should have been released, and the original value should have been put back into the MVar.- mbResult <- MVar.tryTakeMVar mutex.var- mbResult @?= Just (Internal.mkNF "hello")+ -- The MVar should have been released, and the original value should have been put back into the MVar.+ mbResult <- MVar.tryTakeMVar mutex.var+ mbResult `shouldBe` Just (Internal.mkNF "hello") -unit_new_evaluates_value_to_normal_form :: IO ()-unit_new_evaluates_value_to_normal_form = do- Mutex.new @[Int] 0 [1, 2, error "oops", 4]- `shouldThrow` errorCall "oops"+ it "new evaluates value to normal form" do+ Mutex.new @[Int] 0 [1, 2, error "oops", 4]+ `shouldThrow` errorCall "oops" -unit_release_evaluates_value_to_normal_form :: IO ()-unit_release_evaluates_value_to_normal_form = do- mutex <- Mutex.new @[Int] 0 [1]+ it "release evaluates value to normal form" do+ mutex <- Mutex.new @[Int] 0 [1] - logs <- MVar.newMVar @[String] []- let logMsg :: String -> RIO ()- logMsg msg = L.liftSystemIO do- MVar.modifyMVar_ logs \logs -> pure (logs <> [msg])+ logs <- MVar.newMVar @[String] []+ let logMsg :: String -> RIO ()+ logMsg msg = L.liftSystemIO do+ MVar.modifyMVar_ logs \logs -> pure (logs <> [msg]) - let run =- lockScope \key -> L.do- (mg, key) <- Mutex.acquire key mutex- logMsg "ran 'acquire'"- mg <- Mutex.write mg [1, 2, error "oops", 4]- logMsg "ran 'write'"- Mutex.release mg- logMsg "ran 'release'"- dropKeyAndReturn key ()+ let run =+ lockScope \key -> L.do+ (mg, key) <- Mutex.acquire key mutex+ logMsg "ran 'acquire'"+ mg <- Mutex.write mg [1, 2, error "oops", 4]+ logMsg "ran 'write'"+ Mutex.release mg+ logMsg "ran 'release'"+ dropKeyAndReturn key () - run `shouldThrow` errorCall "oops"+ run `shouldThrow` errorCall "oops" - -- The exception should be thrown WHILE running `release`.- -- `write` should NOT throw.- msgs <- MVar.takeMVar logs- msgs @?= ["ran 'acquire'", "ran 'write'"]+ -- The exception should be thrown WHILE running `release`.+ -- `write` should NOT throw.+ msgs <- MVar.takeMVar logs+ msgs `shouldBe` ["ran 'acquire'", "ran 'write'"]
test/Test/LinearLocks/StrictRWLockSpec.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoFieldSelectors #-} @@ -20,8 +19,7 @@ import Prelude.Linear (Ur (..)) import Prelude.Linear qualified as L hiding (IO) import System.IO.Resource.Linear (RIO)-import Test.Hspec.Expectations.Pretty (errorCall, shouldThrow)-import "tasty-hunit-compat" Test.Tasty.HUnit+import Test.Syd -- | Doctests --@@ -41,173 +39,167 @@ -- ... • Cannot satisfy: 5 <= 2 -- ... • In a stmt of a 'do' block: (g1, key) <- RWLock.acquireRead key m1 -- ...-unit_read_mutex :: IO ()-unit_read_mutex = do- rwl <- RWLock.new 0 "hello"- -- Read in "read mode"- str <- lockScope \key -> L.do- (guard, key) <- RWLock.acquireRead key rwl- (Ur str, guard) <- RWLock.read guard- RWLock.releaseRead guard- dropKeyAndReturn key str- str @?= "hello"+spec :: Spec+spec = describe "Strict RWLock" do+ it "read mutex" do+ rwl <- RWLock.new 0 "hello"+ -- Read in "read mode"+ str <- lockScope \key -> L.do+ (guard, key) <- RWLock.acquireRead key rwl+ (Ur str, guard) <- RWLock.read guard+ RWLock.releaseRead guard+ dropKeyAndReturn key str+ str `shouldBe` "hello" - -- Read in "write mode"- str <- lockScope \key -> L.do- (guard, key) <- RWLock.acquireWrite key rwl- (Ur str, guard) <- RWLock.read guard- RWLock.releaseWrite guard- dropKeyAndReturn key str- str @?= "hello"+ -- Read in "write mode"+ str <- lockScope \key -> L.do+ (guard, key) <- RWLock.acquireWrite key rwl+ (Ur str, guard) <- RWLock.read guard+ RWLock.releaseWrite guard+ dropKeyAndReturn key str+ str `shouldBe` "hello" -unit_write_mutex :: IO ()-unit_write_mutex = do- rwl <- RWLock.new 0 "hello"+ it "write mutex" do+ rwl <- RWLock.new 0 "hello" - -- Write in "write mode"- lockScope \key -> L.do- (guard, key) <- RWLock.acquireWrite key rwl- guard <- RWLock.write guard "world"- RWLock.releaseWrite guard- dropKeyAndReturn key ()+ -- Write in "write mode"+ lockScope \key -> L.do+ (guard, key) <- RWLock.acquireWrite key rwl+ guard <- RWLock.write guard "world"+ RWLock.releaseWrite guard+ dropKeyAndReturn key () - -- Read in "read mode"- str <- lockScope \key -> L.do- (guard, key) <- RWLock.acquireRead key rwl- (Ur str, guard) <- RWLock.read guard- RWLock.releaseRead guard- dropKeyAndReturn key str- str @?= "world"+ -- Read in "read mode"+ str <- lockScope \key -> L.do+ (guard, key) <- RWLock.acquireRead key rwl+ (Ur str, guard) <- RWLock.read guard+ RWLock.releaseRead guard+ dropKeyAndReturn key str+ str `shouldBe` "world" - -- Read in "write mode"- str <- lockScope \key -> L.do- (guard, key) <- RWLock.acquireWrite key rwl- (Ur str, guard) <- RWLock.read guard- RWLock.releaseWrite guard- dropKeyAndReturn key str- str @?= "world"+ -- Read in "write mode"+ str <- lockScope \key -> L.do+ (guard, key) <- RWLock.acquireWrite key rwl+ (Ur str, guard) <- RWLock.read guard+ RWLock.releaseWrite guard+ dropKeyAndReturn key str+ str `shouldBe` "world" - str <- IORef.readIORef rwl.var- str.unNF @?= "world"+ str <- IORef.readIORef rwl.var+ str.unNF `shouldBe` "world" -unit_realeases_ioref_in_read_mode :: IO ()-unit_realeases_ioref_in_read_mode = do- rwl <- RWLock.new 0 "hello"- lockScope \key -> L.do- (mg, key) <- RWLock.acquireRead key rwl+ it "realeases ioref in read mode" do+ rwl <- RWLock.new 0 "hello"+ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireRead key rwl - -- If the lock was acquired in "read mode",- -- we shouldn't be able to acquire it again in "write mode",- -- but we should be able to acquire it in "read mode".- L.liftSystemIO do- assertCanRead rwl True- assertCanWrite rwl False+ -- If the lock was acquired in "read mode",+ -- we shouldn't be able to acquire it again in "write mode",+ -- but we should be able to acquire it in "read mode".+ L.liftSystemIO do+ assertCanRead rwl True+ assertCanWrite rwl False - RWLock.releaseRead mg+ RWLock.releaseRead mg - -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".- L.liftSystemIO do- assertCanRead rwl True- assertCanWrite rwl True+ -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".+ L.liftSystemIO do+ assertCanRead rwl True+ assertCanWrite rwl True - dropKeyAndReturn key ()+ dropKeyAndReturn key () - -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".- assertCanRead rwl True- assertCanWrite rwl True+ -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".+ assertCanRead rwl True+ assertCanWrite rwl True -unit_realeases_ioref_in_write_mode :: IO ()-unit_realeases_ioref_in_write_mode = do- rwl <- RWLock.new 0 "hello"- lockScope \key -> L.do- (mg, key) <- RWLock.acquireWrite key rwl+ it "realeases ioref in write mode" do+ rwl <- RWLock.new 0 "hello"+ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireWrite key rwl - -- If the lock was acquired in "write mode",- -- we shouldn't be able to acquire it again in "write mode" or "read mode".- L.liftSystemIO do- assertCanRead rwl False- assertCanWrite rwl False+ -- If the lock was acquired in "write mode",+ -- we shouldn't be able to acquire it again in "write mode" or "read mode".+ L.liftSystemIO do+ assertCanRead rwl False+ assertCanWrite rwl False - RWLock.releaseWrite mg+ RWLock.releaseWrite mg - -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".- L.liftSystemIO do- assertCanRead rwl True- assertCanWrite rwl True+ -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".+ L.liftSystemIO do+ assertCanRead rwl True+ assertCanWrite rwl True - dropKeyAndReturn key ()+ dropKeyAndReturn key () - -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".- assertCanRead rwl True- assertCanWrite rwl True+ -- The lock was released, we should be able to acquire it in both "read mode" and "write mode".+ assertCanRead rwl True+ assertCanWrite rwl True -unit_rolls_back_on_exception :: IO ()-unit_rolls_back_on_exception = do- rwl <- RWLock.new 0 "hello"- Left _ <- try @SomeException $ lockScope \key -> L.do- (mg, key) <- RWLock.acquireWrite key rwl- mg <- RWLock.write mg "world"- L.liftSystemIO L.$ throwIO (userError "oops")- RWLock.releaseWrite mg- dropKeyAndReturn key ()+ it "rolls back on exception" do+ rwl <- RWLock.new 0 "hello"+ Left _ <- try @SomeException $ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireWrite key rwl+ mg <- RWLock.write mg "world"+ L.liftSystemIO L.$ throwIO (userError "oops")+ RWLock.releaseWrite mg+ dropKeyAndReturn key () - -- The IORef should have been released, and the original value should have been put back into the IORef.- assertCanRead rwl True- assertCanWrite rwl True- mbResult <- IORef.readIORef rwl.var- mbResult.unNF @?= "hello"+ -- The IORef should have been released, and the original value should have been put back into the IORef.+ assertCanRead rwl True+ assertCanWrite rwl True+ mbResult <- IORef.readIORef rwl.var+ mbResult.unNF `shouldBe` "hello" -unit_rolls_back_on_imprecise_exception :: IO ()-unit_rolls_back_on_imprecise_exception = do- rwl <- RWLock.new 0 "hello"- Left _ <- try @SomeException $ lockScope \key -> L.do- (mg, key) <- RWLock.acquireWrite key rwl- mg <- RWLock.write mg "world"- error "err"- RWLock.releaseWrite mg- dropKeyAndReturn key ()+ it "rolls back on imprecise exception" do+ rwl <- RWLock.new 0 "hello"+ Left _ <- try @SomeException $ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireWrite key rwl+ mg <- RWLock.write mg "world"+ error "err"+ RWLock.releaseWrite mg+ dropKeyAndReturn key () - -- The IORef should have been released, and the original value should have been put back into the IORef.- assertCanRead rwl True- assertCanWrite rwl True- mbResult <- IORef.readIORef rwl.var- mbResult.unNF @?= "hello"+ -- The IORef should have been released, and the original value should have been put back into the IORef.+ assertCanRead rwl True+ assertCanWrite rwl True+ mbResult <- IORef.readIORef rwl.var+ mbResult.unNF `shouldBe` "hello" -unit_new_evaluates_value_to_normal_form :: IO ()-unit_new_evaluates_value_to_normal_form = do- RWLock.new @[Int] 0 [1, 2, error "oops", 4]- `shouldThrow` errorCall "oops"+ it "new evaluates value to normal form" do+ RWLock.new @[Int] 0 [1, 2, error "oops", 4]+ `shouldThrow` errorCall "oops" -unit_release_evaluates_value_to_normal_form :: IO ()-unit_release_evaluates_value_to_normal_form = do- mutex <- RWLock.new @[Int] 0 [1]+ it "release evaluates value to normal form" do+ mutex <- RWLock.new @[Int] 0 [1] - logs <- MVar.newMVar @[String] []- let logMsg :: String -> RIO ()- logMsg msg = L.liftSystemIO do- MVar.modifyMVar_ logs \logs -> pure (logs <> [msg])+ logs <- MVar.newMVar @[String] []+ let logMsg :: String -> RIO ()+ logMsg msg = L.liftSystemIO do+ MVar.modifyMVar_ logs \logs -> pure (logs <> [msg]) - let run =- lockScope \key -> L.do- (mg, key) <- RWLock.acquireWrite key mutex- logMsg "ran 'acquire'"- mg <- RWLock.write mg [1, 2, error "oops", 4]- logMsg "ran 'write'"- RWLock.releaseWrite mg- logMsg "ran 'release'"- dropKeyAndReturn key ()+ let run =+ lockScope \key -> L.do+ (mg, key) <- RWLock.acquireWrite key mutex+ logMsg "ran 'acquire'"+ mg <- RWLock.write mg [1, 2, error "oops", 4]+ logMsg "ran 'write'"+ RWLock.releaseWrite mg+ logMsg "ran 'release'"+ dropKeyAndReturn key () - run `shouldThrow` errorCall "oops"+ run `shouldThrow` errorCall "oops" - -- The exception should be thrown WHILE running `release`.- -- `write` should NOT throw.- msgs <- MVar.takeMVar logs- msgs @?= ["ran 'acquire'", "ran 'write'"]+ -- The exception should be thrown WHILE running `release`.+ -- `write` should NOT throw.+ msgs <- MVar.takeMVar logs+ msgs `shouldBe` ["ran 'acquire'", "ran 'write'"] assertCanRead :: RWLock.RWLock lvl a -> Bool -> IO () assertCanRead rwl expected = do canRead <- Conc.tryAcquireRead rwl.lock- canRead @?= expected+ canRead `shouldBe` expected -- Release the lock if it was acquired. when canRead do Conc.releaseRead rwl.lock@@ -215,7 +207,7 @@ assertCanWrite :: RWLock.RWLock lvl a -> Bool -> IO () assertCanWrite rwl expected = do canWrite <- Conc.tryAcquireWrite rwl.lock- canWrite @?= expected+ canWrite `shouldBe` expected -- Release the lock if it was acquired. when canWrite do Conc.releaseWrite rwl.lock
+ test/Test/LinearLocks/Utils.hs view
@@ -0,0 +1,11 @@+module Test.LinearLocks.Utils where++import Data.List qualified as List+import GHC.Stack (HasCallStack)+import Test.Syd++-- | Assert that the given list does NOT have the given infix.+shouldNotContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation+shouldNotContain a i = shouldSatisfyNamed a ("doesn't have infix\n" <> ppShow i) (not . List.isInfixOf i)++infix 1 `shouldNotContain`