packages feed

linear-locks (empty) → 0.1.0.0

raw patch · 22 files changed

+2752/−0 lines, 22 filesdep +atomic-primopsdep +basedep +concurrent-extrasetup-changed

Dependencies added: atomic-primops, base, concurrent-extra, containers, deepseq, focus, hspec-expectations-pretty-diff, linear-base, linear-locks, list-t, stm-containers, tasty, tasty-hunit-compat, vector, vector-algorithms

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `linear-locks`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2026 Author name here++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.++3.  Neither the name of the copyright holder nor the names of its contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,236 @@+<!--+    DO NOT EDIT THIS FILE.++    This file was generated from `docs/src/Readme.lhs`.+    Edit that file, and then run `just pandoc`.+-->++# linear-locks++`linear-locks` is a port of the+[Surelock](https://notes.brooklynzelenka.com/Blog/Surelock) Rust crate+to Linear Haskell.++The package provides locking primitives that are statically guaranteed+not to lead to deadlocks.++It achieves this by breaking one of the [Coffman conditions for+deadlocks](https://en.wikipedia.org/wiki/Deadlock_(computer_science)#Prevention):+the "circular wait" condition. `linear-locks` ensures locks are always+acquired in a consistent order.++Currently supported lock types:++- "LinearLocks.Mutex"+- "LinearLocks.Mutex.Strict"+- "LinearLocks.RWLock"+- "LinearLocks.RWLock.Strict"++See [Getting Started](#getting-started) for a quick introduction to the+API. Some examples can also be found in the+[examples](https://github.com/dcastro/linear-locks/tree/main/examples/src)+folder.++## Motivation++In Haskell, [`STM` is the holy+grail](https://chrispenner.ca/posts/mutexes) for synchronizing access to+multiple shared resources without risking deadlocks, and it should+absolutely be the first thing on your mind when writing concurrent code.++Still, `STM` does have its limitations:++- You cannot run arbitrary `IO` actions within `STM` transactions, which+  can be a roadblock if you need to interact with the outside world+  while holding locks.+- Due to its optimistic nature, scenarios with high contention can lead+  to excessive transaction retries and livelocks.++Locking primitives like `MVar`s solve both of these issues, but juggling+multiple `MVar`s is a sure way to hit a deadlock sooner or later.++Enter `linear-locks`: it provides locking primitives that are statically+guaranteed to be free of deadlocks.++## Getting started++`linear-locks` is meant to be used alongside the+[`linear-base`](https://hackage.haskell.org/package/linear-base)+package.++We'll need `QualifiedDo`:++``` haskell+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+```++And the following imports:++``` haskell+import LinearLocks+import LinearLocks.Mutex qualified as Mutex++-- From `linear-base`:+import Prelude.Linear (Ur (..))+import Control.Functor.Linear qualified as Linear+import Control.Monad.IO.Class.Linear qualified as Linear+```++Each lock is assigned a "level" at compile-time.++``` haskell+  -- `Mutex 0 Config`+  configMutex <- Mutex.new 0 Config { verbose = True }++  -- `Mutex 1 DbConn`+  dbMutex <- Mutex.new 1 DbConn {}+```++We can then enter a "lock scope".++We're given a `LockKey lvl` that we can use to acquire locks. The key+starts off with level 0 (`LockKey 0`) and it can be used to acquire any+lock with level 0 or above.++Every time we acquire a lock, the key's level increases. Acquiring+`Mutex 0 Config` consumes our `LockKey 0` and gives us a `LockKey 1`+back. Acquiring `Mutex 1 DbConn` then gives us a `LockKey 2`.++``` haskell+  lockScope \key -> Linear.do+    --                                   ↓ Consumes `LockKey 0` to acquire a `Mutex 0`+    (configGuard, key) <- Mutex.acquire key configMutex+    --             ↑ Returns `LockKey 1`+++    --                               ↓ Consumes `LockKey 1` to acquire a `Mutex 1`+    (dbGuard, key) <- Mutex.acquire key dbMutex+    --         ↑ Returns `LockKey 2`++    Mutex.release configGuard+    Mutex.release dbGuard+    dropKey key+    Linear.pure (Ur ())+```++Acquiring locks in the wrong order (e.g. trying to acquire a lock of+level 0 with a key of level 2) would be a type error. This ensures locks+are always acquired in order of increasing level, preventing circular+waits and thus deadlocks.++The key is linearly typed; it must be consumed *exactly once*. Using the+same key to acquire 2 locks would be a type error.++Notice how we had to use `Linear.do` (enabled by the `QualifiedDo`+extension) and `Linear.pure` instead of `Prelude.pure` to chain our+actions together. This is because the lock scope action runs in+[`RIO`](https://hackage-content.haskell.org/package/linear-base/docs/System-IO-Resource-Linear.html),+and `RIO` does not implement `Prelude.Monad`; instead, it implements+[`Linear.Monad`](https://hackage-content.haskell.org/package/linear-base/docs/Control-Functor-Linear.html#t:Monad)+from `linear-base`. This ensures values bound by `>>=` must be consumed+exactly once.++Since dropping the key before returning is a common pattern, we provide+the `dropKeyAndReturn` function to conveniently do both at once.++<h3>++Guards+</h3>++When we acquire a mutex, we get back a `MutexGuard a` that represents+our ownership of the lock. We can freely read from / write to it while+the lock is held.++The guard is also linearly typed, thus ensuring:++- We can never forget to release it with `release`.+- It cannot be used after being released.++``` haskell+  lockScope \key -> Linear.do+    (configGuard, key) <- Mutex.acquire key configMutex++    (Ur config, configGuard) <- Mutex.read configGuard++    configGuard <- Mutex.write configGuard config { verbose = False }++    Mutex.release configGuard+    dropKeyAndReturn key ()+```++Since the guard is linear, `read` and `write` must consume the guard and+return a new one.++`read configGuard` returns a `Ur Config`. `Ur` is short for+"unrestricted", meaning the value is *not* linear and can be freely used+as many times as needed.++<h3>++LockSet+</h3>++Locks with the same level must be acquired simultaneously by adding them+to a `LockSet` and using `acquireMany`.++``` haskell+  alice <- Mutex.new 3 User { balance = 100 }+  bob <- Mutex.new 3 User { balance = 100 }++  users <- newLockSet (alice, bob)++  lockScope \key -> Linear.do+    ((aliceGuard, bobGuard), key) <- acquireMany key users+    (Ur alice, aliceGuard) <- Mutex.read aliceGuard+    (Ur bob, bobGuard) <- Mutex.read bobGuard++    bobGuard <- Mutex.write bobGuard bob { balance = balance bob + 10 }+    aliceGuard <- Mutex.write aliceGuard alice { balance = balance alice - 10 }++    Mutex.release bobGuard+    Mutex.release aliceGuard+    dropKeyAndReturn key ()+```++To prevent deadlocks, locks in a set are always acquired in a+deterministic order. Creating a set with `(alice, bob)` or+`(bob, alice)` will always result in them being acquired in the same+order.++<h3>++IO+</h3>++You can use the linear [`MonadIO` from+`linear-base`](https://hackage-content.haskell.org/package/linear-base/docs/Control-Monad-IO-Class-Linear.html)+to lift `IO` actions into the lock scope.++``` haskell+  lockScope \key -> Linear.do+    (configGuard, key) <- Mutex.acquire key configMutex+    (Ur config, configGuard) <- Mutex.read configGuard++    Ur newVerbose <- Linear.liftSystemIOU do+      putStrLn $ "Verbose mode is: " <> show (verbose config)+      putStrLn $ "Enter new verbose mode: "+      readLn @Bool++    configGuard <- Mutex.write configGuard config { verbose = newVerbose }+    Mutex.release configGuard+    dropKeyAndReturn key ()+```++Note: for the time being, the `linear-locks` package conditionally+provides an orphan instance of `MonadIO` for the `RIO` monad when+compiled against `linear-base <= 0.7.0`. The next version of+`linear-base` [will+include](https://github.com/tweag/linear-base/pull/505) a `MonadIO`+instance itself.++## Roadmap++- [ ] Allow backtracking of `LockKey`'s level when a lock is released
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ linear-locks.cabal view
@@ -0,0 +1,101 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack++name:           linear-locks+version:        0.1.0.0+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>+category:       Concurrency, Parallelism, Mutable State+homepage:       https://github.com/dcastro/linear-locks#readme+bug-reports:    https://github.com/dcastro/linear-locks/issues+author:         Diogo Castro+maintainer:     dc@diogocastro.com+copyright:      2026 Diogo Castro+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 9.10.3 , GHC == 9.12.4 , GHC == 9.14.1+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/dcastro/linear-locks++library+  exposed-modules:+      LinearLocks+      LinearLocks.Internal+      LinearLocks.Internal.LockSet+      LinearLocks.Internal.Mutex+      LinearLocks.Internal.RWLock+      LinearLocks.Internal.StrictMutex+      LinearLocks.Internal.StrictRWLock+      LinearLocks.Mutex+      LinearLocks.Mutex.Strict+      LinearLocks.RWLock+      LinearLocks.RWLock.Strict+  other-modules:+      Paths_linear_locks+  autogen-modules:+      Paths_linear_locks+  hs-source-dirs:+      src+  default-extensions:+      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+  build-depends:+      atomic-primops >=0.8.4+    , base >=4.20 && <5+    , concurrent-extra >=0.7.0.12+    , containers >=0.6.8+    , deepseq >=1.5.0.0+    , focus >=1.0.3.2+    , linear-base >=0.4.0+    , stm-containers >=1.2.1+    , vector >=0.13.1.0+    , vector-algorithms >=0.9.0.1+  default-language: GHC2024++test-suite linear-locks-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Test.LinearLocks.LockSetSpec+      Test.LinearLocks.MutexSpec+      Test.LinearLocks.RWLockSpec+      Test.LinearLocks.StrictMutexSpec+      Test.LinearLocks.StrictRWLockSpec+      Paths_linear_locks+  autogen-modules:+      Paths_linear_locks+  hs-source-dirs:+      test+  default-extensions:+      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+  build-tool-depends:+      tasty-discover:tasty-discover+  build-depends:+      base+    , concurrent-extra+    , hspec-expectations-pretty-diff+    , linear-base+    , linear-locks+    , list-t+    , stm-containers+    , tasty+    , tasty-hunit-compat+    , vector+  default-language: GHC2024
+ src/LinearLocks.hs view
@@ -0,0 +1,68 @@+{- ORMOLU_DISABLE -}+{- |++@linear-locks@ provides locking primitives that are statically guaranteed to not lead to deadlocks.++An in-depth description and tutorial can be found in the [README](https://github.com/dcastro/linear-locks#readme).++It is meant to be used with @QualifiedDo@ and these imports:++>>> :set -XQualifiedDo -XGHC2024 -XBlockArguments+>>> import LinearLocks+>>> import LinearLocks.Mutex qualified as Mutex+>>> import Prelude.Linear (Ur (..))+>>> import Control.Functor.Linear qualified as Linear+>>> import Control.Monad.IO.Class.Linear qualified as Linear+++>>> :{+example :: IO ()+example = do+  -- Create mutexes with a chosen level+  configMutex <- Mutex.new 0 Config { verbose = True }+  dbMutex <- Mutex.new 1 DbConn {}+  --+  -- Enter a lockscope+  lockScope \key -> Linear.do+    -- Acquire locks+    (configGuard, key) <- acquire key configMutex+    (dbGuard, key) <- acquire key dbMutex+    --+    -- Read/write+    (Ur config, configGuard) <- Mutex.read configGuard+    configGuard <- Mutex.write configGuard config { verbose = False }+    --+    -- IO actions+    Linear.liftSystemIO do+      putStrLn $ "Verbose mode was: " <> show (verbose config)+    --+    -- Release locks+    Mutex.release configGuard+    Mutex.release dbGuard+    dropKeyAndReturn key ()+:}++-}+{- ORMOLU_ENABLE -}+module LinearLocks+  ( -- * Lock scope+    LockKey,+    lockScope,+    dropKey,+    dropKeyAndReturn,+    NestedLocksScopeException (..),++    -- * Lock sets+    LockSet,+    IsLockSet (), -- Note: do not export the typeclass members+    newLockSet,+    acquireMany,+  )+where++import LinearLocks.Internal+import LinearLocks.Internal.LockSet++-- $setup+-- >>> data Config = Config { verbose :: Bool }+-- >>> data DbConn = DbConn
+ src/LinearLocks/Internal.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_HADDOCK not-home #-}++#if !MIN_VERSION_linear_base(0,7,1)+{-# OPTIONS_GHC -Wno-orphans #-}+#endif++module LinearLocks.Internal where++import Control.Concurrent (ThreadId, myThreadId)+import Control.DeepSeq (NFData, force)+import Control.Exception (Exception (..), bracket_, throw)+import Control.Functor.Linear qualified as L+import Control.Monad.IO.Class.Linear qualified as L+import Data.Atomics.Counter (AtomicCounter)+import Data.Atomics.Counter qualified as Atomic+import Data.IntMap.Strict qualified as IntMap+import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as VGM+import Data.Vector.Primitive qualified as VP+import Data.Vector.Unboxed qualified as VU+import Focus qualified+import GHC.Base (Type)+import GHC.Conc (atomically)+import GHC.IO (unsafePerformIO)+import GHC.TypeLits (Nat, type (+), type (<=))+import Prelude.Linear (Ur (..))+import StmContainers.Set qualified as StmSet+import System.IO.Linear qualified as L+import System.IO.Resource.Linear (RIO)+import System.IO.Resource.Linear qualified as RIO+import System.IO.Resource.Linear.Internal qualified as RIOInternal++-- | A key used to acquire locks.+-- A key of level @n@ can only acquire locks of level @n@ or higher.+--+-- Acquiring a lock with `acquire` or `LinearLocks.acquireMany` will consume the key and return a new key with an increased level,+-- ensuring locks are always acquired in a consistent order.+data LockKey (lvl :: Nat)+  = -- Notes:+    --  * Do not export the constructor+    --  * Do not implement `Consumable` / `Dupable` / `Movable`+    UnsafeLockKey++-- | A unique identifier for a lock.+newtype LockId = LockId Int+  deriving newtype (Eq, Ord, Show)++newtype instance VU.MVector s LockId = MV_LockId (VP.MVector s Int)++newtype instance VU.Vector LockId = V_LockId (VP.Vector Int)++deriving via (VU.UnboxViaPrim Int) instance VGM.MVector VU.MVector LockId++deriving via (VU.UnboxViaPrim Int) instance VG.Vector VU.Vector LockId++instance VU.Unbox LockId++-- | Creates a new lock scope with a key of level 0, and runs the given function with it.+--  The key can be used to acquire locks with `acquire` and `LinearLocks.acquireMany`.+--+-- After acquiring all the necessary locks, the key must be dropped with+-- `dropKey` or `dropKeyAndReturn`.+--+-- Will throw a t`NestedLocksScopeException` if a nested `lockScope` is created at runtime.+lockScope ::+  forall a.+  -- NOTE: The use of `Ur` prevents the key (and any other linear values) from escaping the scope+  -- of the `lockScope` function via the variable `a`.+  -- See: https://www.tweag.io/blog/2023-03-23-linear-constraints-linearly/#sticky-ends-of-scopes+  (LockKey 0 %1 -> RIO (Ur a)) ->+  IO a+lockScope run = do+  ensureNotNested do+    RIO.run L.do+      let key = UnsafeLockKey @0+      run key+  where+    -- Ensures nested lock scopes are not created.+    -- We can't really detect this at compile-time, so we'll make do with a runtime check.+    ensureNotNested :: IO a -> IO a+    ensureNotNested action = do+      tid <- myThreadId+      bracket_+        -- Acquire: register the thread ID in the set of active lock scopes.+        ( do+            success <- atomically do+              StmSet.focus+                ( do+                    -- Check if the thread ID is already in the set.+                    Focus.lookup >>= \case+                      Just () ->+                        -- The thread ID was found in the set, which means we're trying to create a nested lock scope.+                        -- We return `False` to signal an error.+                        pure False+                      Nothing -> do+                        Focus.insert ()+                        pure True+                )+                tid+                lockScopes+            if success+              then pure ()+              else throw NestedLocksScopeException+        )+        -- Release: remove the thread ID from the set of active lock scopes.+        ( atomically do+            StmSet.delete tid lockScopes+        )+        action++-- | Discard a key. Should be used after acquiring all the necessary locks in a lock scope.+dropKey :: LockKey lvl %1 -> RIO ()+dropKey UnsafeLockKey = L.pure ()++-- | Convenience function to drop the key and return a pure value at the end of a lock scope.+dropKeyAndReturn :: LockKey lvl %1 -> a -> RIO (Ur a)+dropKeyAndReturn key a = L.do+  dropKey key+  L.pure (Ur a)++data NestedLocksScopeException = NestedLocksScopeException+  deriving stock (Show)++instance Exception NestedLocksScopeException where+  displayException NestedLocksScopeException = "Nested lock scopes are not allowed"++-- | Acquires a lock.+-- Consumes the key and return a new key (with an increased level).+acquire ::+  forall keyLvl acquirable.+  (Acquirable acquirable) =>+  (keyLvl <= Level acquirable) =>+  LockKey keyLvl %1 ->+  acquirable ->+  RIO (Guard acquirable, LockKey (Level acquirable + 1))+acquire UnsafeLockKey m = L.do+  guard <- unsafeAcquire m+  L.pure (guard, UnsafeLockKey)++class (Releasable (Guard acquirable)) => Acquirable acquirable where+  type Guard acquirable :: Type+  type Level acquirable :: Nat++  getId :: acquirable -> LockId++  -- | This is marked as unsafe because it does not consume a `LockKey`.+  unsafeAcquire :: acquirable -> RIO (Guard acquirable)++class Releasable guard where+  -- Design decision: `doRelease` generalizes over releasing any kind of guard, but we don't export it.+  -- We only export the monomorphic `release` functions for each guard type, because they might have+  -- important notes in their haddock docs (e.g. `StrictMutex.release` does deep evaluation and might throw an exception as a result),+  -- so it's important those docs are easily discoverable and not hidden behind a more general `doRelease` function.+  doRelease :: guard %1 -> RIO ()++----------------------------------------------------------------------------+-- Global variables+----------------------------------------------------------------------------++-- | A set of the ThreadIds currently holding a lock scope.+-- We use this to prevent nested lock scopes at runtime.+{-# NOINLINE lockScopes #-}+lockScopes :: StmSet.Set ThreadId+lockScopes =+  -- See: https://wiki.haskell.org/index.php?oldid=64612+  unsafePerformIO StmSet.newIO++-- | An atomic counter used to generate unique IDs for locks.+{-# NOINLINE lockIdCounter #-}+lockIdCounter :: AtomicCounter+lockIdCounter =+  unsafePerformIO $ Atomic.newCounter 0++-- | Generates the next unique lock ID.+nextLockId :: IO LockId+nextLockId = do+  newId <- Atomic.incrCounter 1 lockIdCounter+  pure (LockId newId)++-- 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 ()+release' (RIOInternal.UnsafeResource key _) release = RIOInternal.RIO (\st -> L.mask_ (releaseWith key st))+  where+    releaseWith key rrm = L.do+      Ur (RIOInternal.ReleaseMap releaseMap) <- L.readIORef rrm+      () <- release+      L.writeIORef rrm (RIOInternal.ReleaseMap (IntMap.delete key releaseMap))++-- | A wrapper type to force the contents to be fully evaluated before being put back into an MVar / IORef.+--+-- NOTE: `NF` will only turn "shallow evaluation" into "deep evaluation".+-- You must still use a bang pattern on `NF` to force it.+newtype NF a = UnsafeNF {unNF :: a}+  deriving newtype (Show, Eq)++mkNF :: (NFData a) => a -> NF a+mkNF = UnsafeNF . force
+ src/LinearLocks/Internal/LockSet.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_HADDOCK not-home #-}++module LinearLocks.Internal.LockSet where++import Control.Functor.Linear qualified as L+import Control.Monad.IO.Class.Linear qualified as L+import Control.Monad.ST (ST, runST)+import Data.Function (on)+import Data.Kind (Type)+import Data.Vector.Algorithms.Insertion qualified as Sort+import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as VGM+import Data.Vector.Primitive qualified as VP+import Data.Vector.Unboxed qualified as VU+import Data.Vector.Unboxed.Mutable qualified as VUM+import GHC.TypeLits (Nat, type (+), type (<=))+import LinearLocks.Internal+import System.IO.Resource.Linear (RIO)++-- | The index of a lock in a lock set.+newtype LockSetIndex = LockSetIndex Int+  deriving newtype (Enum)++newtype instance VU.MVector s LockSetIndex = MV_LockSetIndex (VP.MVector s Int)++newtype instance VU.Vector LockSetIndex = V_LockSetIndex (VP.Vector Int)++deriving via (VU.UnboxViaPrim Int) instance VGM.MVector VU.MVector LockSetIndex++deriving via (VU.UnboxViaPrim Int) instance VG.Vector VU.Vector LockSetIndex++instance VU.Unbox LockSetIndex++-- | A set of locks with the same level that can be acquired together with 'acquireMany'.+data LockSet set where+  MkLockSet :: set -> VU.Vector LockSetIndex -> LockSet set++-- | Creates a 'LockSet' from a set of locks.+-- All locks must have the same level.+--+-- Locks in a 'LockSet' can be acquired simultaneously using 'acquireMany'.+--+-- Fails if the set contains duplicate locks.+--+-- >>> import LinearLocks.Mutex qualified as Mutex+-- >>> m1 <- Mutex.new 1 "a"+-- >>> m2 <- Mutex.new 1 "b"+-- >>> m3 <- Mutex.new 1 "c"+-- >>> set <- newLockSet (m1, m2, m3)+newLockSet :: forall m set. (IsLockSet set, MonadFail m) => set -> m (LockSet set)+newLockSet set =+  if hasDups+    then fail "LockSet: duplicate locks are not allowed"+    else pure $ MkLockSet set sortedIndices+  where+    (hasDups, sortedIndices) = runST do+      idsAndIndices <- VU.thaw $ VU.fromList $ collectIds set `zip` [LockSetIndex 0 ..]++      -- Sort by lock IDs+      Sort.sortBy (compare `on` fst) idsAndIndices++      -- Check whether this set contains duplicate locks.+      -- NOTE: the vector must already be sorted.+      hasDups <- hasDuplicateIds idsAndIndices++      sortedIndices <- VU.map snd <$> VU.unsafeFreeze idsAndIndices++      pure (hasDups, sortedIndices)++    hasDuplicateIds :: VUM.MVector (VUM.PrimState (ST s)) (LockId, LockSetIndex) -> ST s Bool+    hasDuplicateIds idsAndIndices = do+      let go i =+            if i >= VUM.length idsAndIndices - 1+              then pure False+              else do+                (id1, _) <- VUM.read idsAndIndices i+                (id2, _) <- VUM.read idsAndIndices (i + 1)+                if id1 == id2+                  then pure True+                  else go (i + 1)+      go 0++acquireMany ::+  forall keyLvl lockLvl set.+  (IsLockSet set, lockLvl ~ LockSetLevel set, keyLvl <= lockLvl) =>+  LockKey keyLvl %1 ->+  LockSet set ->+  RIO (LockSetGuard set, LockKey (lockLvl + 1))+acquireMany UnsafeLockKey (MkLockSet set indices) = L.do+  guards <- acquireInOrder indices set+  L.pure (guards, UnsafeLockKey)++class IsLockSet set where+  type LockSetGuard set :: Type+  type LockSetLevel set :: Nat++  collectIds :: set -> [LockId]++  -- | Acquires the locks in the set in the given order.+  -- E.g. `acquireInOrder [1, 3, 2]` will acquire the first lock in the set, then the third, then the second.+  --+  -- Invariants:+  --   * The indices must refer to every lock in the set, without duplicates.+  acquireInOrder :: VU.Vector LockSetIndex -> set -> RIO (LockSetGuard set)++instance+  ( Acquirable l1,+    Acquirable l2,+    Level l1 ~ Level l2+  ) =>+  IsLockSet (l1, l2)+  where+  type LockSetGuard (l1, l2) = (Guard l1, Guard l2)+  type LockSetLevel (l1, l2) = Level l1++  collectIds (l1, l2) = [getId l1, getId l2]++  acquireInOrder indices (l1, l2) = L.do+    guards <- L.execStateT (forM_' indices acquireAt) (Nothing, Nothing)+    case guards of+      (Just g1, Just g2) -> L.pure (g1, g2)+      guards -> releaseAndFail guards missingIndices+    where+      acquireAt :: LockSetIndex -> L.StateT (Maybe (Guard l1), Maybe (Guard l2)) RIO ()+      acquireAt (LockSetIndex index) =+        case index of+          0 -> modifyM \case+            (Nothing, g2) -> L.do+              g1 <- unsafeAcquire l1+              L.pure (Just g1, g2)+            guards -> releaseAndFail guards (dupIndex index)+          1 -> modifyM \case+            (g1, Nothing) -> L.do+              g2 <- unsafeAcquire l2+              L.pure (g1, Just g2)+            guards -> releaseAndFail guards (dupIndex index)+          _ -> L.lift (failRIO (invalidIndex index))++      releaseAndFail :: (Maybe (Guard l1), Maybe (Guard l2)) %1 -> String -> RIO x+      releaseAndFail (g1, g2) errMsg = L.do+        releaseMb g1+        releaseMb g2+        failRIO errMsg++instance+  ( Acquirable l1,+    Acquirable l2,+    Acquirable l3,+    Level l1 ~ Level l2,+    Level l1 ~ Level l3+  ) =>+  IsLockSet (l1, l2, l3)+  where+  type LockSetGuard (l1, l2, l3) = (Guard l1, Guard l2, Guard l3)+  type LockSetLevel (l1, l2, l3) = Level l1++  collectIds (l1, l2, l3) = [getId l1, getId l2, getId l3]++  acquireInOrder indices (l1, l2, l3) = L.do+    guards <- L.execStateT (forM_' indices acquireAt) (Nothing, Nothing, Nothing)+    case guards of+      (Just g1, Just g2, Just g3) -> L.pure (g1, g2, g3)+      guards -> releaseAndFail guards missingIndices+    where+      acquireAt :: LockSetIndex -> L.StateT (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3)) RIO ()+      acquireAt (LockSetIndex index) =+        case index of+          0 -> modifyM \case+            (Nothing, g2, g3) -> L.do+              g1 <- unsafeAcquire l1+              L.pure (Just g1, g2, g3)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          1 -> modifyM \case+            (g1, Nothing, g3) -> L.do+              g2 <- unsafeAcquire l2+              L.pure (g1, Just g2, g3)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          2 -> modifyM \case+            (g1, g2, Nothing) -> L.do+              g3 <- unsafeAcquire l3+              L.pure (g1, g2, Just g3)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          _ -> L.lift (failRIO (invalidIndex index))++      releaseAndFail :: (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3)) %1 -> String -> RIO x+      releaseAndFail (g1, g2, g3) errMsg = L.do+        releaseMb g1+        releaseMb g2+        releaseMb g3+        failRIO errMsg++instance+  ( Acquirable l1,+    Acquirable l2,+    Acquirable l3,+    Acquirable l4,+    Level l1 ~ Level l2,+    Level l1 ~ Level l3,+    Level l1 ~ Level l4+  ) =>+  IsLockSet (l1, l2, l3, l4)+  where+  type LockSetGuard (l1, l2, l3, l4) = (Guard l1, Guard l2, Guard l3, Guard l4)+  type LockSetLevel (l1, l2, l3, l4) = Level l1++  collectIds (l1, l2, l3, l4) = [getId l1, getId l2, getId l3, getId l4]++  acquireInOrder indices (l1, l2, l3, l4) = L.do+    guards <- L.execStateT (forM_' indices acquireAt) (Nothing, Nothing, Nothing, Nothing)+    case guards of+      (Just g1, Just g2, Just g3, Just g4) -> L.pure (g1, g2, g3, g4)+      guards -> releaseAndFail guards missingIndices+    where+      acquireAt :: LockSetIndex -> L.StateT (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3), Maybe (Guard l4)) RIO ()+      acquireAt (LockSetIndex index) =+        case index of+          0 -> modifyM \case+            (Nothing, g2, g3, g4) -> L.do+              g1 <- unsafeAcquire l1+              L.pure (Just g1, g2, g3, g4)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          1 -> modifyM \case+            (g1, Nothing, g3, g4) -> L.do+              g2 <- unsafeAcquire l2+              L.pure (g1, Just g2, g3, g4)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          2 -> modifyM \case+            (g1, g2, Nothing, g4) -> L.do+              g3 <- unsafeAcquire l3+              L.pure (g1, g2, Just g3, g4)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          3 -> modifyM \case+            (g1, g2, g3, Nothing) -> L.do+              g4 <- unsafeAcquire l4+              L.pure (g1, g2, g3, Just g4)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          _ -> L.lift (failRIO (invalidIndex index))++      releaseAndFail :: (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3), Maybe (Guard l4)) %1 -> String -> RIO x+      releaseAndFail (g1, g2, g3, g4) errMsg = L.do+        releaseMb g1+        releaseMb g2+        releaseMb g3+        releaseMb g4+        failRIO errMsg++instance+  ( Acquirable l1,+    Acquirable l2,+    Acquirable l3,+    Acquirable l4,+    Acquirable l5,+    Level l1 ~ Level l2,+    Level l1 ~ Level l3,+    Level l1 ~ Level l4,+    Level l1 ~ Level l5+  ) =>+  IsLockSet (l1, l2, l3, l4, l5)+  where+  type LockSetGuard (l1, l2, l3, l4, l5) = (Guard l1, Guard l2, Guard l3, Guard l4, Guard l5)+  type LockSetLevel (l1, l2, l3, l4, l5) = Level l1++  collectIds (l1, l2, l3, l4, l5) = [getId l1, getId l2, getId l3, getId l4, getId l5]++  acquireInOrder indices (l1, l2, l3, l4, l5) = L.do+    guards <- L.execStateT (forM_' indices acquireAt) (Nothing, Nothing, Nothing, Nothing, Nothing)+    case guards of+      (Just g1, Just g2, Just g3, Just g4, Just g5) -> L.pure (g1, g2, g3, g4, g5)+      guards -> releaseAndFail guards missingIndices+    where+      acquireAt :: LockSetIndex -> L.StateT (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3), Maybe (Guard l4), Maybe (Guard l5)) RIO ()+      acquireAt (LockSetIndex index) =+        case index of+          0 -> modifyM \case+            (Nothing, g2, g3, g4, g5) -> L.do+              g1 <- unsafeAcquire l1+              L.pure (Just g1, g2, g3, g4, g5)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          1 -> modifyM \case+            (g1, Nothing, g3, g4, g5) -> L.do+              g2 <- unsafeAcquire l2+              L.pure (g1, Just g2, g3, g4, g5)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          2 -> modifyM \case+            (g1, g2, Nothing, g4, g5) -> L.do+              g3 <- unsafeAcquire l3+              L.pure (g1, g2, Just g3, g4, g5)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          3 -> modifyM \case+            (g1, g2, g3, Nothing, g5) -> L.do+              g4 <- unsafeAcquire l4+              L.pure (g1, g2, g3, Just g4, g5)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          4 -> modifyM \case+            (g1, g2, g3, g4, Nothing) -> L.do+              g5 <- unsafeAcquire l5+              L.pure (g1, g2, g3, g4, Just g5)+            guards -> L.do+              releaseAndFail guards (dupIndex index)+          _ -> L.lift (failRIO (invalidIndex index))++      releaseAndFail :: (Maybe (Guard l1), Maybe (Guard l2), Maybe (Guard l3), Maybe (Guard l4), Maybe (Guard l5)) %1 -> String -> RIO x+      releaseAndFail (g1, g2, g3, g4, g5) errMsg = L.do+        releaseMb g1+        releaseMb g2+        releaseMb g3+        releaseMb g4+        releaseMb g5+        failRIO errMsg++----------------------------------------------------------------------------+-- Utils+----------------------------------------------------------------------------++missingIndices :: String+missingIndices = "LockSet: missing indices"++dupIndex :: Int -> String+dupIndex index = "LockSet: duplicate index: " <> show index++invalidIndex :: Int -> String+invalidIndex index = "LockSet: invalid index: " <> show index++releaseMb :: (Releasable g) => Maybe g %1 -> RIO ()+releaseMb = \case+  Nothing -> L.pure ()+  Just guard -> doRelease guard++failRIO :: String -> RIO a+failRIO msg = L.do+  L.liftSystemIO (fail msg)++modifyM :: forall m s. (L.Functor m) => (s %1 -> m s) %1 -> L.StateT s m ()+modifyM f =+  L.StateT \s -> L.do+    f s L.<&> \s' -> ((), s')++-- | A version of 'Data.Vector.Unboxed.forM_' that runs in a linear monad.+forM_' :: (VU.Unbox a, L.Monad m) => VU.Vector a -> (a -> m ()) -> m ()+forM_' vec action = go 0+  where+    go i+      | i >= VU.length vec = L.pure ()+      | otherwise = L.do+          action (vec VU.! i)+          go (i + 1)
+ src/LinearLocks/Internal/Mutex.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_HADDOCK not-home #-}++module LinearLocks.Internal.Mutex where++import Control.Concurrent (MVar)+import Control.Concurrent qualified as MVar+import Control.Functor.Linear qualified as L+import GHC.TypeLits (Nat)+import LinearLocks.Internal+import Prelude.Linear (Ur (..))+import Prelude.Linear qualified as L hiding (IO)+import System.IO.Linear qualified as L+import System.IO.Resource.Linear (RIO)+import System.IO.Resource.Linear qualified as RIO+import System.IO.Resource.Linear.Internal qualified as Internal++-- | A deadlock-free mutex.+--+-- This implementation is lazy.+-- This means that if you place an expensive unevaluated thunk inside a t`Mutex`,+-- it will be evaluated by the thread that consumes it, not the thread that produced it.+-- To avoid this, use "LinearLocks.Mutex.Strict" instead.+data Mutex (lvl :: Nat) a = Mutex+  { var :: MVar a,+    -- | The unique ID for this mutex. It's used to ensure t'LinearLocks.LockSet's don't contain duplicate mutexes, see 'LinearLocks.newLockSet'.+    id :: LockId+  }++-- | A t`MutexGuard` represents the ownership of a mutex.+--+-- It can be used to read/write the mutex while the lock is held.+--+-- It must be released with `release`, after which the guard will be consumed and can no longer be used.+data MutexGuard a = MutexGuard+  { resource :: RIO.Resource (MutexResource a),+    -- | The latest value set by the user.+    -- This will be comitted to the MVar when the guard is released.+    newValue :: Ur a+  }++data MutexResource a = MutexResource+  { -- | The value that was read from the `MVar` when it was acquired.+    --+    -- If an exception occurs before the mutex guard is manually released, this value will be put back into the `MVar`.+    initialValue :: a,+    var :: MVar a+  }++instance Acquirable (Mutex lvl a) where+  type Guard (Mutex lvl a) = MutexGuard a+  type Level (Mutex lvl a) = lvl++  getId m = m.id++  unsafeAcquire :: forall lvl a. Mutex lvl a -> RIO (MutexGuard a)+  unsafeAcquire m = L.do+    -- Note: we have to match on `UnsafeResource` so we can extract the `guard.initialValue`+    Internal.UnsafeResource key guard <- RIO.unsafeAcquire acq rel+    L.pure+      MutexGuard+        { resource = Internal.UnsafeResource key guard,+          newValue = Ur guard.initialValue+        }+    where+      acq :: L.IO (Ur (MutexResource a))+      acq = L.do+        Ur a <- L.fromSystemIOU L.$ MVar.takeMVar m.var+        L.pure (Ur (MutexResource {initialValue = a, var = m.var}))++      -- The action to run if an exception is thrown before the guard is manually released with `release`.+      rel :: MutexResource a -> L.IO ()+      rel (MutexResource initialValue var) =+        L.void L.$ L.fromSystemIO L.$ MVar.putMVar var initialValue++instance Releasable (MutexGuard a) where+  doRelease = release++read :: MutexGuard a %1 -> RIO (Ur a, MutexGuard a)+read (MutexGuard resource (Ur newValue)) =+  L.pure (Ur newValue, MutexGuard {resource, newValue = Ur newValue})++-- | Writes a new value to the mutex, which will be committed when the guard is released.+--+-- If an exception is thrown after `write` but before `release`,+-- the mutex will be rolled back to its original state.+write :: MutexGuard a %1 -> a -> RIO (MutexGuard a)+write (MutexGuard resource (Ur _)) newValue =+  L.pure (MutexGuard {resource, newValue = Ur newValue})++-- | Releases the mutex and commits the latest value set by `write`.+release :: MutexGuard a %1 -> RIO ()+release (MutexGuard ((Internal.UnsafeResource key mr)) (Ur newValue)) = L.do+  -- Note: the resource was initially registered with a release action that puts the original value back into the MVar.+  -- That release action should be run if an exception is thrown before `release` is called,+  -- which ensures the MVar will "rollback" to its original state.+  --+  -- However, if `release` is called explicitly by the user,+  -- we want to update the release action to put `newValue` back into the MVar instead.+  -- Therefore, we must call `release'` with a _new release action_ that puts `newValue` into the MVar.+  release' (Internal.UnsafeResource key mr) L.do+    L.void L.$ L.fromSystemIO L.$ MVar.putMVar mr.var newValue++-- | Creates a new mutex with the given initial value.+--+-- The @lvl@ parameter determines the order in which this mutex can be acquired relative to other mutexes.+--+-- It does not have to be unique, multiple mutexes can have the same level.+-- Mutexes with the same level can be added to a t`LinearLocks.LockSet` and acquired with 'LinearLocks.acquireMany'.+new :: forall a. forall (lvl :: Nat) -> a -> IO (Mutex lvl a)+new _lvl a = do+  var <- MVar.newMVar a+  id <- nextLockId+  pure Mutex {var, id}
+ src/LinearLocks/Internal/RWLock.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_HADDOCK not-home #-}++module LinearLocks.Internal.RWLock where++import Control.Concurrent.ReadWriteLock qualified as Conc+import Control.Functor.Linear qualified as L+import Control.Monad.IO.Class.Linear qualified as L+import Data.IORef (IORef)+import Data.IORef qualified as IORef+import Data.Kind (Type)+import GHC.TypeLits (Nat, type (+), type (<=))+import LinearLocks.Internal+import Prelude.Linear (Ur (..))+import Prelude.Linear qualified as L hiding (IO)+import System.IO.Linear qualified as L+import System.IO.Resource.Linear (RIO)+import System.IO.Resource.Linear qualified as RIO++-- $setup+-- >>> data Config = Config { verbose :: Bool }++{- ORMOLU_DISABLE -}+{- | A deadlock-free lock that allows multiple concurrent readers or a single writer.++>>> import LinearLocks+>>> import LinearLocks.RWLock qualified as RWLock+>>> import Prelude.Linear (Ur (..))+>>> import Control.Functor.Linear qualified as Linear++>>> :{+example :: IO ()+example = do+  configLock <- RWLock.new 0 Config { verbose = True }+  --+  -- Enter a lockscope+  lockScope \key -> Linear.do+    -- Acquire the lock in "write mode"+    (guard, key) <- RWLock.acquireWrite key configLock+    --+    -- Read/write+    (Ur config, guard) <- RWLock.read guard+    guard <- RWLock.write guard config { verbose = False }+    --+    -- Release lock+    RWLock.releaseWrite guard+    dropKeyAndReturn key ()+:}+-}+{- ORMOLU_ENABLE -}+data RWLock (lvl :: Nat) a = RWLock+  { var :: IORef a,+    -- | A read-write lock gating access to the `IORef`.+    lock :: Conc.RWLock,+    -- | The unique ID for this lock. It's used to ensure t'LinearLocks.LockSet's don't contain duplicate locks, see 'LinearLocks.newLockSet'.+    id :: LockId+  }++-- | Creates a new read-write lock with the given initial value.+--+-- The @lvl@ parameter determines the order in which this lock can be acquired relative to other locks.+--+-- It does not have to be unique, multiple locks can have the same level.+-- Locks with the same level can be added to a t`LinearLocks.LockSet` and acquired with 'LinearLocks.acquireMany'.+new :: forall a. forall (lvl :: Nat) -> a -> IO (RWLock lvl a)+new _lvl a = do+  lock <- Conc.new+  var <- IORef.newIORef a+  id <- nextLockId+  pure RWLock {var, lock, id}++class Readable guard where+  type Elem guard :: Type+  read :: guard %1 -> RIO (Ur (Elem guard), guard)++----------------------------------------------------------------------------+-- Read mode+----------------------------------------------------------------------------++-- | Acquires the t'RWLock' in "read mode". Consumes the key and return a new key (with an increased level).+acquireRead ::+  forall a keyLvl lockLvl.+  (keyLvl <= lockLvl) =>+  LockKey keyLvl %1 ->+  RWLock lockLvl a ->+  RIO (ReadGuard a, LockKey (lockLvl + 1))+acquireRead key m = acquire key (AsRead m)++-- | A t`ReadGuard` represents the ownership of a RWLock in read mode.+--+-- It must be released with `releaseRead`, after which the guard will be consumed and can no longer be used.+data ReadGuard a = ReadGuard+  { resource :: RIO.Resource Resource,+    -- | The value that was read when the lock was acquired.+    readValue :: Ur a+  }++newtype Resource = Resource+  { lock :: Conc.RWLock+  }++-- | Newtype used to add t'RWLock's to t'LinearLocks.LockSet's.+newtype AsRead lvl a = AsRead (RWLock lvl a)++instance Acquirable (AsRead lvl a) where+  type Guard (AsRead lvl a) = ReadGuard a+  type Level (AsRead lvl a) = lvl++  getId (AsRead m) = m.id++  unsafeAcquire :: forall lvl a. AsRead lvl a -> RIO (ReadGuard a)+  unsafeAcquire (AsRead m) = L.do+    -- Acquire the rwlock in "read mode" and *then* read the `IORef`.+    resource <- RIO.unsafeAcquire acq rel+    Ur readValue <- L.liftSystemIOU (IORef.readIORef m.var)+    L.pure+      ReadGuard+        { resource = resource,+          readValue = Ur readValue+        }+    where+      acq :: L.IO (Ur Resource)+      acq = L.do+        L.fromSystemIO L.$ Conc.acquireRead m.lock+        L.pure (Ur (Resource {lock = m.lock}))++      rel :: Resource -> L.IO ()+      rel (Resource lock) =+        L.fromSystemIO L.$ Conc.releaseRead lock++-- | Releases the lock.+releaseRead :: ReadGuard a %1 -> RIO ()+releaseRead (ReadGuard resource (Ur _readValue)) =+  RIO.release resource++instance Releasable (ReadGuard a) where+  doRelease = releaseRead++instance Readable (ReadGuard a) where+  type Elem (ReadGuard a) = a++  read :: ReadGuard a %1 -> RIO (Ur a, ReadGuard a)+  read (ReadGuard resource (Ur readValue)) =+    L.pure (Ur readValue, ReadGuard {resource, readValue = Ur readValue})++----------------------------------------------------------------------------+-- Write mode+----------------------------------------------------------------------------++-- | Acquires the t'RWLock' in "write mode". Consumes the key and return a new key (with an increased level).+acquireWrite ::+  forall a keyLvl lockLvl.+  (keyLvl <= lockLvl) =>+  LockKey keyLvl %1 ->+  RWLock lockLvl a ->+  RIO (WriteGuard a, LockKey (lockLvl + 1))+acquireWrite key m = acquire key (AsWrite m)++-- | A t`WriteGuard` represents the ownership of a RWLock in write mode.+--+-- It must be released with `releaseWrite`, after which the guard will be consumed and can no longer be used.+data WriteGuard a = WriteGuard+  { resource :: RIO.Resource Resource,+    -- | The latest value set by the user.+    -- This will be comitted when the guard is released.+    newValue :: Ur a,+    var :: Ur (IORef a)+  }++-- | Newtype used to add t'RWLock's to t'LinearLocks.LockSet's.+newtype AsWrite lvl a = AsWrite (RWLock lvl a)++instance Acquirable (AsWrite lvl a) where+  type Guard (AsWrite lvl a) = WriteGuard a+  type Level (AsWrite lvl a) = lvl++  getId (AsWrite m) = m.id++  unsafeAcquire :: forall lvl a. AsWrite lvl a -> RIO (WriteGuard a)+  unsafeAcquire (AsWrite m) = L.do+    -- Acquire the rwlock in "write mode" and *then* read the `IORef`.+    resource <- RIO.unsafeAcquire acq rel+    Ur initialValue <- L.liftSystemIOU (IORef.readIORef m.var)+    L.pure+      WriteGuard+        { resource = resource,+          newValue = Ur initialValue,+          var = Ur m.var+        }+    where+      acq :: L.IO (Ur Resource)+      acq = L.do+        L.fromSystemIO L.$ Conc.acquireWrite m.lock+        L.pure (Ur (Resource {lock = m.lock}))++      rel :: Resource -> L.IO ()+      rel (Resource lock) =+        L.fromSystemIO L.$ Conc.releaseWrite lock++-- | Releases the lock and commits the latest value set by `write`.+releaseWrite :: WriteGuard a %1 -> RIO ()+releaseWrite (WriteGuard resource (Ur newValue) (Ur var)) = L.do+  L.liftSystemIO $ IORef.writeIORef var newValue+  RIO.release resource++instance Releasable (WriteGuard a) where+  doRelease = releaseWrite++instance Readable (WriteGuard a) where+  type Elem (WriteGuard a) = a++  read :: WriteGuard a %1 -> RIO (Ur a, WriteGuard a)+  read (WriteGuard resource (Ur newValue) var) =+    L.pure (Ur newValue, WriteGuard {resource, newValue = Ur newValue, var})++-- | Writes a new value to the t'RWLock', which will be committed when the guard is released.+--+-- If an exception is thrown after `write` but before `releaseWrite`,+-- the t'RWLock' will be rolled back to its original state.+write :: WriteGuard a %1 -> a -> RIO (WriteGuard a)+write (WriteGuard resource (Ur _) var) newValue =+  L.pure (WriteGuard {resource, newValue = Ur newValue, var})
+ src/LinearLocks/Internal/StrictMutex.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_HADDOCK not-home #-}++module LinearLocks.Internal.StrictMutex where++import Control.Concurrent (MVar)+import Control.Concurrent qualified as MVar+import Control.DeepSeq (NFData)+import Control.Functor.Linear qualified as L+import GHC.TypeLits (Nat)+import LinearLocks.Internal+import Prelude.Linear (Ur (..))+import Prelude.Linear qualified as L hiding (IO)+import System.IO.Linear qualified as L+import System.IO.Resource.Linear (RIO)+import System.IO.Resource.Linear qualified as RIO+import System.IO.Resource.Linear.Internal qualified as Internal++-- | A strict version of "LinearLocks.Mutex".+data Mutex (lvl :: Nat) a = Mutex+  { -- NOTE: we're using `MVar (NF a)` instead of e.g. `Control.Concurrent.MVar.Strict.MVar` (from the `strict-concurrency` package)+    -- because we don't want to require `NFData` when taking the mvar's (already evaluated) value and putting it right back in, unmodified.+    --+    -- In other words, this allows `lock` to not require `NFData` to setup the "release on exception" action.+    var :: MVar (NF a),+    -- | The unique ID for this mutex. It's used to ensure t'LinearLocks.LockSet's don't contain duplicate mutexes, see 'LinearLocks.newLockSet'.+    id :: LockId+  }++-- | A t`MutexGuard` represents the ownership of a mutex.+--+-- It can be used to read/write the mutex while the lock is held.+--+-- It must be released with `release`, after which the guard will be consumed and can no longer be used.+data MutexGuard a = MutexGuard+  { resource :: RIO.Resource (MutexResource a),+    -- | The latest value set by the user.+    -- This will be comitted to the MVar when the guard is released.+    newValue :: Ur a+  }++data MutexResource a = MutexResource+  { -- | The value that was read from the `MVar` when it was acquired.+    --+    -- If an exception occurs before the mutex guard is manually released, this value will be put back into the `MVar`.+    initialValue :: (NF a),+    var :: MVar (NF a)+  }++instance (NFData a) => Acquirable (Mutex lvl a) where+  type Guard (Mutex lvl a) = MutexGuard a+  type Level (Mutex lvl a) = lvl++  getId m = m.id++  unsafeAcquire :: forall lvl a. Mutex lvl a -> RIO (MutexGuard a)+  unsafeAcquire m = L.do+    -- Note: we have to match on `UnsafeResource` so we can extract the `guard.initialValue`+    Internal.UnsafeResource key guard <- RIO.unsafeAcquire acq rel+    L.pure+      MutexGuard+        { resource = Internal.UnsafeResource key guard,+          newValue = Ur guard.initialValue.unNF+        }+    where+      acq :: L.IO (Ur (MutexResource a))+      acq = L.do+        Ur a <- L.fromSystemIOU L.$ MVar.takeMVar m.var+        L.pure (Ur (MutexResource {initialValue = a, var = m.var}))++      -- The action to run if an exception is thrown before the guard is manually released with `release`.+      rel :: MutexResource a -> L.IO ()+      rel (MutexResource initialValue var) =+        L.void L.$ L.fromSystemIO L.$ MVar.putMVar var initialValue++instance (NFData a) => Releasable (MutexGuard a) where+  doRelease = release++read :: MutexGuard a %1 -> RIO (Ur a, MutexGuard a)+read (MutexGuard resource (Ur newValue)) =+  L.pure (Ur newValue, MutexGuard {resource, newValue = Ur newValue})++-- | Writes a new value to the mutex, which will be committed when the guard is released.+--+-- If an exception is thrown after `write` but before `release`,+-- the mutex will be rolled back to its original state.+--+-- Note: The value will only be evaluated to Normal Form when the mutex is released, not when it's written.+write :: MutexGuard a %1 -> a -> RIO (MutexGuard a)+write (MutexGuard resource (Ur _)) newValue =+  L.pure (MutexGuard {resource, newValue = Ur newValue})++-- | Releases the mutex and commits the latest value set by `write`.+--+-- Fully evaluates the value to Normal Form before releasing the mutex.+release :: (NFData a) => MutexGuard a %1 -> RIO ()+release (MutexGuard ((Internal.UnsafeResource key mr)) (Ur (mkNF -> !newValue))) = L.do+  -- Note: the resource was initially registered with a release action that puts the original value back into the MVar.+  -- That release action should be run if an exception is thrown before `release` is called,+  -- which ensures the MVar will "rollback" to its original state.+  --+  -- However, if `release` is called explicitly by the user,+  -- we want to update the release action to put `newValue` back into the MVar instead.+  -- Therefore, we must call `release'` with a _new release action_ that puts `newValue` into the MVar.+  release' (Internal.UnsafeResource key mr) L.do+    L.void L.$ L.fromSystemIO L.$ MVar.putMVar mr.var newValue++-- | Creates a new mutex with the given initial value.+--+-- The @lvl@ parameter determines the order in which this mutex can be acquired relative to other mutexes.+--+-- It does not have to be unique, multiple mutexes can have the same level.+-- Mutexes with the same level can be added to a t`LinearLocks.LockSet` and acquired with 'LinearLocks.acquireMany'.+--+-- This function fully evaluates the initial value to Normal Form.+new :: forall a. (NFData a) => forall (lvl :: Nat) -> a -> IO (Mutex lvl a)+new _lvl (mkNF -> !a) = do+  var <- MVar.newMVar a+  id <- nextLockId+  pure Mutex {var, id}
+ src/LinearLocks/Internal/StrictRWLock.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RequiredTypeArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_HADDOCK not-home #-}++module LinearLocks.Internal.StrictRWLock where++import Control.Concurrent.ReadWriteLock qualified as Conc+import Control.DeepSeq (NFData)+import Control.Functor.Linear qualified as L+import Control.Monad.IO.Class.Linear qualified as L+import Data.IORef (IORef)+import Data.IORef qualified as IORef+import Data.Kind (Type)+import GHC.TypeLits (Nat, type (+), type (<=))+import LinearLocks.Internal+import Prelude.Linear (Ur (..))+import Prelude.Linear qualified as L hiding (IO)+import System.IO.Linear qualified as L+import System.IO.Resource.Linear (RIO)+import System.IO.Resource.Linear qualified as RIO++-- $setup+-- >>> newtype Config = Config { verbose :: Bool } deriving newtype NFData++{- ORMOLU_DISABLE -}+{- | A strict version of "LinearLocks.RWLock".++>>> import LinearLocks+>>> import LinearLocks.RWLock.Strict qualified as RWLock+>>> import Prelude.Linear (Ur (..))+>>> import Control.Functor.Linear qualified as Linear++>>> :{+example :: IO ()+example = do+  configLock <- RWLock.new 0 Config { verbose = True }+  --+  -- Enter a lockscope+  lockScope \key -> Linear.do+    -- Acquire the lock in "write mode"+    (guard, key) <- RWLock.acquireWrite key configLock+    --+    -- Read/write+    (Ur config, guard) <- RWLock.read guard+    guard <- RWLock.write guard config { verbose = False }+    --+    -- Release lock+    RWLock.releaseWrite guard+    dropKeyAndReturn key ()+:}+-}+{- ORMOLU_ENABLE -}+data RWLock (lvl :: Nat) a = RWLock+  { var :: IORef (NF a),+    -- | A read-write lock gating access to the `IORef`.+    lock :: Conc.RWLock,+    -- | The unique ID for this lock. It's used to ensure t'LinearLocks.LockSet's don't contain duplicate locks, see 'LinearLocks.newLockSet'.+    id :: LockId+  }++-- | Creates a new read-write lock with the given initial value.+--+-- The @lvl@ parameter determines the order in which this lock can be acquired relative to other locks.+--+-- It does not have to be unique, multiple locks can have the same level.+-- Locks with the same level can be added to a t`LinearLocks.LockSet` and acquired with 'LinearLocks.acquireMany'.+--+-- This function fully evaluates the initial value to Normal Form.+new :: forall a. (NFData a) => forall (lvl :: Nat) -> a -> IO (RWLock lvl a)+new _lvl (mkNF -> !a) = do+  lock <- Conc.new+  var <- IORef.newIORef a+  id <- nextLockId+  pure RWLock {var, lock, id}++class Readable guard where+  type Elem guard :: Type+  read :: guard %1 -> RIO (Ur (Elem guard), guard)++----------------------------------------------------------------------------+-- Read mode+----------------------------------------------------------------------------++-- | Acquires the t'RWLock' in "read mode". Consumes the key and return a new key (with an increased level).+acquireRead ::+  forall a keyLvl lockLvl.+  (keyLvl <= lockLvl) =>+  LockKey keyLvl %1 ->+  RWLock lockLvl a ->+  RIO (ReadGuard a, LockKey (lockLvl + 1))+acquireRead key m = acquire key (AsRead m)++-- | A t`ReadGuard` represents the ownership of a RWLock in read mode.+--+-- It must be released with `releaseRead`, after which the guard will be consumed and can no longer be used.+data ReadGuard a = ReadGuard+  { resource :: RIO.Resource Resource,+    -- | The value that was read when the lock was acquired.+    readValue :: Ur a+  }++newtype Resource = Resource+  { lock :: Conc.RWLock+  }++-- | Newtype used to add t'RWLock's to t'LinearLocks.LockSet's.+newtype AsRead lvl a = AsRead (RWLock lvl a)++instance Acquirable (AsRead lvl a) where+  type Guard (AsRead lvl a) = ReadGuard a+  type Level (AsRead lvl a) = lvl++  getId (AsRead m) = m.id++  unsafeAcquire :: forall lvl a. AsRead lvl a -> RIO (ReadGuard a)+  unsafeAcquire (AsRead m) = L.do+    -- Acquire the rwlock in "read mode" and *then* read the `IORef`.+    resource <- RIO.unsafeAcquire acq rel+    Ur readValue <- L.liftSystemIOU (IORef.readIORef m.var)+    L.pure+      ReadGuard+        { resource = resource,+          readValue = Ur readValue.unNF+        }+    where+      acq :: L.IO (Ur Resource)+      acq = L.do+        L.fromSystemIO L.$ Conc.acquireRead m.lock+        L.pure (Ur (Resource {lock = m.lock}))++      rel :: Resource -> L.IO ()+      rel (Resource lock) =+        L.fromSystemIO L.$ Conc.releaseRead lock++-- | Releases the lock.+releaseRead :: ReadGuard a %1 -> RIO ()+releaseRead (ReadGuard resource (Ur _readValue)) =+  RIO.release resource++instance Releasable (ReadGuard a) where+  doRelease = releaseRead++instance Readable (ReadGuard a) where+  type Elem (ReadGuard a) = a++  read :: ReadGuard a %1 -> RIO (Ur a, ReadGuard a)+  read (ReadGuard resource (Ur readValue)) =+    L.pure (Ur readValue, ReadGuard {resource, readValue = Ur readValue})++----------------------------------------------------------------------------+-- Write mode+----------------------------------------------------------------------------++-- | Acquires the t'RWLock' in "write mode". Consumes the key and return a new key (with an increased level).+acquireWrite ::+  forall a keyLvl lockLvl.+  (keyLvl <= lockLvl) =>+  (NFData a) =>+  LockKey keyLvl %1 ->+  RWLock lockLvl a ->+  RIO (WriteGuard a, LockKey (lockLvl + 1))+acquireWrite key m = acquire key (AsWrite m)++-- | A t`WriteGuard` represents the ownership of a RWLock in write mode.+--+-- It must be released with `releaseWrite`, after which the guard will be consumed and can no longer be used.+data WriteGuard a = WriteGuard+  { resource :: RIO.Resource Resource,+    -- | The latest value set by the user.+    -- This will be comitted when the guard is released.+    newValue :: Ur a,+    var :: Ur (IORef (NF a))+  }++-- | Newtype used to add t'RWLock's to t'LinearLocks.LockSet's.+newtype AsWrite lvl a = AsWrite (RWLock lvl a)++instance (NFData a) => Acquirable (AsWrite lvl a) where+  type Guard (AsWrite lvl a) = WriteGuard a+  type Level (AsWrite lvl a) = lvl++  getId (AsWrite m) = m.id++  unsafeAcquire :: forall lvl a. AsWrite lvl a -> RIO (WriteGuard a)+  unsafeAcquire (AsWrite m) = L.do+    -- Acquire the rwlock in "write mode" and *then* read the `IORef`.+    resource <- RIO.unsafeAcquire acq rel+    Ur initialValue <- L.liftSystemIOU (IORef.readIORef m.var)+    L.pure+      WriteGuard+        { resource = resource,+          newValue = Ur initialValue.unNF,+          var = Ur m.var+        }+    where+      acq :: L.IO (Ur Resource)+      acq = L.do+        L.fromSystemIO L.$ Conc.acquireWrite m.lock+        L.pure (Ur (Resource {lock = m.lock}))++      rel :: Resource -> L.IO ()+      rel (Resource lock) =+        L.fromSystemIO L.$ Conc.releaseWrite lock++-- | Releases the lock and commits the latest value set by `write`.+--+-- Fully evaluates the value to Normal Form before releasing the lock.+releaseWrite :: (NFData a) => WriteGuard a %1 -> RIO ()+releaseWrite (WriteGuard resource (Ur (mkNF -> !newValue)) (Ur var)) = L.do+  L.liftSystemIO $ IORef.writeIORef var newValue+  RIO.release resource++instance (NFData a) => Releasable (WriteGuard a) where+  doRelease = releaseWrite++instance Readable (WriteGuard a) where+  type Elem (WriteGuard a) = a++  read :: WriteGuard a %1 -> RIO (Ur a, WriteGuard a)+  read (WriteGuard resource (Ur newValue) var) =+    L.pure (Ur newValue, WriteGuard {resource, newValue = Ur newValue, var})++-- | Writes a new value to the t'RWLock', which will be committed when the guard is released.+--+-- If an exception is thrown after `write` but before `releaseWrite`,+-- the t'RWLock' will be rolled back to its original state.+--+-- Note: The value will only be evaluated to Normal Form when the mutex is released, not when it's written.+write :: WriteGuard a %1 -> a -> RIO (WriteGuard a)+write (WriteGuard resource (Ur _) var) newValue =+  L.pure (WriteGuard {resource, newValue = Ur newValue, var})
+ src/LinearLocks/Mutex.hs view
@@ -0,0 +1,16 @@+module LinearLocks.Mutex+  ( -- * Mutex+    Mutex,+    new,+    acquire,++    -- * Mutex guards+    MutexGuard,+    Mutex.read,+    write,+    release,+  )+where++import LinearLocks.Internal (acquire)+import LinearLocks.Internal.Mutex as Mutex
+ src/LinearLocks/Mutex/Strict.hs view
@@ -0,0 +1,16 @@+module LinearLocks.Mutex.Strict+  ( -- * Mutex+    Mutex,+    new,+    acquire,++    -- * Mutex guards+    MutexGuard,+    StrictMutex.read,+    write,+    release,+  )+where++import LinearLocks.Internal (acquire)+import LinearLocks.Internal.StrictMutex as StrictMutex
+ src/LinearLocks/RWLock.hs view
@@ -0,0 +1,32 @@+module LinearLocks.RWLock+  ( -- * RWLock+    RWLock,+    new,+    acquireRead,+    acquireWrite,++    -- * Read mode+    ReadGuard,+    RWLock.read,+    releaseRead,++    -- * Write mode+    WriteGuard,+    write,+    releaseWrite,++    -- * Lock sets++    -- | The t'AsRead' and t'AsWrite' newtypes can be used to add t'RWLock's to t'LinearLocks.LockSet's.+    --+    -- >>> import LinearLocks+    -- >>> import LinearLocks.RWLock qualified as RWLock+    -- >>> rw1 <- RWLock.new 0 "hello"+    -- >>> rw2 <- RWLock.new 0 "world"+    -- >>> set <- newLockSet (RWLock.AsRead rw1, RWLock.AsWrite rw2)+    AsRead (..),+    AsWrite (..),+  )+where++import LinearLocks.Internal.RWLock as RWLock
+ src/LinearLocks/RWLock/Strict.hs view
@@ -0,0 +1,32 @@+module LinearLocks.RWLock.Strict+  ( -- * RWLock+    RWLock,+    new,+    acquireRead,+    acquireWrite,++    -- * Read mode+    ReadGuard,+    RWLock.read,+    releaseRead,++    -- * Write mode+    WriteGuard,+    write,+    releaseWrite,++    -- * Lock sets++    -- | The t'AsRead' and t'AsWrite' newtypes can be used to add t'RWLock's to t'LinearLocks.LockSet's.+    --+    -- >>> import LinearLocks+    -- >>> import LinearLocks.RWLock.Strict qualified as RWLock+    -- >>> rw1 <- RWLock.new 0 "hello"+    -- >>> rw2 <- RWLock.new 0 "world"+    -- >>> set <- newLockSet (RWLock.AsRead rw1, RWLock.AsWrite rw2)+    AsRead (..),+    AsWrite (..),+  )+where++import LinearLocks.Internal.StrictRWLock as RWLock
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ test/Test/LinearLocks/LockSetSpec.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoFieldSelectors #-}++module Test.LinearLocks.LockSetSpec where++import Control.Functor.Linear qualified as L+import Control.Monad.IO.Class.Linear qualified as L+import Data.Vector.Unboxed qualified as VU+import LinearLocks+import LinearLocks.Internal.LockSet qualified as Internal+import LinearLocks.Internal.Mutex qualified as Internal+import LinearLocks.Mutex qualified as Mutex+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++-- | Doctests+--+-- >>> :{+-- >>> unit_locks_in_a_set_must_have_the_same_level :: IO ()+-- >>> unit_locks_in_a_set_must_have_the_same_level = do+-- >>>   m1 <- Mutex.new 2 "hello"+-- >>>   m2 <- Mutex.new 3 "world"+-- >>>   set <- newLockSet (m1, m2)+-- >>>   pure ()+-- >>> :}+-- ...+-- ... • 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)++  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++    L.liftSystemIO do+      str1 @?= "m1"+      str2 @?= "m2"+      str3 @?= "m3"++    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)++  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"++    Mutex.release mg3+    Mutex.release mg2+    Mutex.release mg1+    dropKeyAndReturn key ()++  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++    L.liftSystemIO do+      str3 @?= "m3 updated"+      str2 @?= "m2 updated"+      str1 @?= "m1 updated"++    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 ""++  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 ""++  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 ""++  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++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))++  lockScope \key -> L.do+    ((g1, g2, g3), key) <- acquireMany key set++    (Ur res1, g1) <- StrictMutex.read g1+    (Ur res2, g2) <- Mutex.read g2+    (Ur res3, g3) <- RWLock.read g3++    L.liftSystemIO do+      res1 @?= "hello"+      res2 @?= 99+      res3 @?= True++    StrictMutex.release g1+    Mutex.release g2+    RWLock.releaseRead g3+    dropKeyAndReturn key ()
+ test/Test/LinearLocks/MutexSpec.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoFieldSelectors #-}++module Test.LinearLocks.MutexSpec where++import Control.Concurrent (ThreadId, myThreadId)+import Control.Concurrent.MVar qualified as MVar+import Control.Exception (SomeException, throwIO, try)+import Control.Functor.Linear qualified as L+import Control.Monad (void)+import Control.Monad.IO.Class.Linear qualified as L+import Data.Function ((&))+import GHC.Conc (atomically)+import LinearLocks+import LinearLocks.Internal qualified as Internal+import LinearLocks.Internal.Mutex qualified as Internal+import LinearLocks.Mutex qualified as Mutex+import ListT qualified+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++-- | Doctests+--+-- >>> :{+-- >>> unit_mutexes_cannot_be_locked_in_wrong_order :: IO ()+-- >>> unit_mutexes_cannot_be_locked_in_wrong_order = do+-- >>>   m1 <- Mutex.new 2 "hello"+-- >>>   m2 <- Mutex.new 4 "world"+-- >>>   lockScope \key -> L.do+-- >>>     (mg2, key) <- Mutex.acquire key m2+-- >>>     (mg1, key) <- Mutex.acquire key m1+-- >>>     Mutex.release mg1+-- >>>     Mutex.release mg2+-- >>>     dropKeyAndReturn key ()+-- >>> :}+-- ...+-- ... • 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"++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 ()++  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 <- MVar.readMVar mutex.var+  str @?= "world"++unit_realeases_mvar :: IO ()+unit_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++    Mutex.release mg++    L.liftSystemIO do+      isEmpty <- MVar.isEmptyMVar mutex.var+      isEmpty @?= False++    dropKeyAndReturn key ()++  isEmpty <- MVar.isEmptyMVar mutex.var+  isEmpty @?= 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 ()++  run `shouldThrow` \(_ :: NestedLocksScopeException) -> True++unit_updates_thread_ids :: IO ()+unit_updates_thread_ids = do+  tid <- myThreadId++  getThreadIds >>= \tids -> tids @?= []+  lockScope \key -> L.do+    L.liftSystemIO L.$ getThreadIds >>= \tids -> tids @?= [tid]+    dropKeyAndReturn key ()+  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 @?= [tid]+          L.liftSystemIO L.$ throwIO (userError "oops")+          dropKeyAndReturn key ()+  run `shouldThrow` anyIOException+  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 @?= [tid]+          L.liftSystemIO do+            lockScope \key -> dropKeyAndReturn key ()+          dropKeyAndReturn key ()+  run `shouldThrow` \(_ :: NestedLocksScopeException) -> True+  getThreadIds >>= \tids -> tids @?= []++  -- 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++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 ()++  -- 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"++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 ()++  -- 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"++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]++unit_release_doesnt_evaluate_value_to_normal_form :: IO ()+unit_release_doesnt_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 ()
+ test/Test/LinearLocks/RWLockSpec.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoFieldSelectors #-}++module Test.LinearLocks.RWLockSpec where++import Control.Concurrent.ReadWriteLock qualified as Conc+import Control.Exception (SomeException, throwIO, try)+import Control.Functor.Linear qualified as L+import Control.Monad (void, when)+import Control.Monad.IO.Class.Linear qualified as L+import Data.IORef qualified as IORef+import LinearLocks+import LinearLocks.Internal.RWLock qualified as Internal+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++-- | Doctests+--+-- >>> :{+-- >>> unit_mutexes_cannot_be_locked_in_wrong_order :: IO ()+-- >>> unit_mutexes_cannot_be_locked_in_wrong_order = do+-- >>>   m1 <- RWLock.new 2 "hello"+-- >>>   m2 <- RWLock.new 4 "world"+-- >>>   lockScope \key -> L.do+-- >>>     (g2, key) <- RWLock.acquireRead key m2+-- >>>     (g1, key) <- RWLock.acquireRead key m1+-- >>>     RWLock.releaseRead g1+-- >>>     RWLock.releaseRead g2+-- >>>     dropKeyAndReturn key ()+-- >>> :}+-- ...+-- ... • 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"++  -- 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"++unit_write_mutex :: IO ()+unit_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 ()++  -- 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 "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"++  str <- IORef.readIORef rwl.var+  str @?= "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++    -- 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++    --  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 ()++  --  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++    -- 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++    --  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 ()++  --  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 ()++  -- 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"++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 ()++  -- 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"++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]++unit_release_doesnt_evaluate_value_to_normal_form :: IO ()+unit_release_doesnt_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 ()++assertCanRead :: RWLock.RWLock lvl a -> Bool -> IO ()+assertCanRead rwl expected = do+  canRead <- Conc.tryAcquireRead rwl.lock+  canRead @?= expected+  -- Release the lock if it was acquired.+  when canRead do+    Conc.releaseRead rwl.lock++assertCanWrite :: RWLock.RWLock lvl a -> Bool -> IO ()+assertCanWrite rwl expected = do+  canWrite <- Conc.tryAcquireWrite rwl.lock+  canWrite @?= expected+  -- Release the lock if it was acquired.+  when canWrite do+    Conc.releaseWrite rwl.lock
+ test/Test/LinearLocks/StrictMutexSpec.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoFieldSelectors #-}++module Test.LinearLocks.StrictMutexSpec where++import Control.Concurrent.MVar qualified as MVar+import Control.Exception (SomeException, throwIO, try)+import Control.Functor.Linear qualified as L+import Control.Monad.IO.Class.Linear qualified as L+import LinearLocks+import LinearLocks.Internal qualified as Internal+import LinearLocks.Internal.StrictMutex qualified as Internal+import LinearLocks.Mutex.Strict qualified as Mutex+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++-- | Doctests+--+-- >>> :{+-- >>> unit_mutexes_cannot_be_locked_in_wrong_order :: IO ()+-- >>> unit_mutexes_cannot_be_locked_in_wrong_order = do+-- >>>   m1 <- Mutex.new 2 "hello"+-- >>>   m2 <- Mutex.new 4 "world"+-- >>>   lockScope \key -> L.do+-- >>>     (mg2, key) <- Mutex.acquire key m2+-- >>>     (mg1, key) <- Mutex.acquire key m1+-- >>>     Mutex.release mg1+-- >>>     Mutex.release mg2+-- >>>     dropKeyAndReturn key ()+-- >>> :}+-- ...+-- ... • 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"++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 ()++  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 <- MVar.readMVar mutex.var+  str.unNF @?= "world"++unit_realeases_mvar :: IO ()+unit_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++    Mutex.release mg++    L.liftSystemIO do+      isEmpty <- MVar.isEmptyMVar mutex.var+      isEmpty @?= False++    dropKeyAndReturn key ()++  isEmpty <- MVar.isEmptyMVar mutex.var+  isEmpty @?= 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 ()++  -- 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")++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 ()++  -- 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")++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"++unit_release_evaluates_value_to_normal_form :: IO ()+unit_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])++  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"++  -- The exception should be thrown WHILE running `release`.+  -- `write` should NOT throw.+  msgs <- MVar.takeMVar logs+  msgs @?= ["ran 'acquire'", "ran 'write'"]
+ test/Test/LinearLocks/StrictRWLockSpec.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoFieldSelectors #-}++module Test.LinearLocks.StrictRWLockSpec where++import Control.Concurrent.MVar qualified as MVar+import Control.Concurrent.ReadWriteLock qualified as Conc+import Control.Exception (SomeException, throwIO, try)+import Control.Functor.Linear qualified as L+import Control.Monad (when)+import Control.Monad.IO.Class.Linear qualified as L+import Data.IORef qualified as IORef+import LinearLocks+import LinearLocks.Internal qualified as Internal+import LinearLocks.Internal.StrictRWLock qualified as Internal+import LinearLocks.RWLock.Strict qualified as RWLock+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++-- | Doctests+--+-- >>> :{+-- >>> unit_mutexes_cannot_be_locked_in_wrong_order :: IO ()+-- >>> unit_mutexes_cannot_be_locked_in_wrong_order = do+-- >>>   m1 <- RWLock.new 2 "hello"+-- >>>   m2 <- RWLock.new 4 "world"+-- >>>   lockScope \key -> L.do+-- >>>     (g2, key) <- RWLock.acquireRead key m2+-- >>>     (g1, key) <- RWLock.acquireRead key m1+-- >>>     RWLock.releaseRead g1+-- >>>     RWLock.releaseRead g2+-- >>>     dropKeyAndReturn key ()+-- >>> :}+-- ...+-- ... • 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"++  -- 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"++unit_write_mutex :: IO ()+unit_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 ()++  -- 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 "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"++  str <- IORef.readIORef rwl.var+  str.unNF @?= "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++    -- 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++    --  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 ()++  --  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++    -- 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++    --  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 ()++  --  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 ()++  -- 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"++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 ()++  -- 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"++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"++unit_release_evaluates_value_to_normal_form :: IO ()+unit_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])++  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"++  -- The exception should be thrown WHILE running `release`.+  -- `write` should NOT throw.+  msgs <- MVar.takeMVar logs+  msgs @?= ["ran 'acquire'", "ran 'write'"]++assertCanRead :: RWLock.RWLock lvl a -> Bool -> IO ()+assertCanRead rwl expected = do+  canRead <- Conc.tryAcquireRead rwl.lock+  canRead @?= expected+  -- Release the lock if it was acquired.+  when canRead do+    Conc.releaseRead rwl.lock++assertCanWrite :: RWLock.RWLock lvl a -> Bool -> IO ()+assertCanWrite rwl expected = do+  canWrite <- Conc.tryAcquireWrite rwl.lock+  canWrite @?= expected+  -- Release the lock if it was acquired.+  when canWrite do+    Conc.releaseWrite rwl.lock