heph-sparse-set (empty) → 0.1.0.0

raw patch · 17 files changed

+2873/−0 lines, 17 filesdep +basedep +containersdep +criterionsetup-changed

Dependencies added: base, containers, criterion, deepseq, hedgehog, heph-sparse-set, mtl, nothunks, primitive, random, tasty, tasty-discover, tasty-hedgehog, tasty-hunit, vector

Files

CHANGELOG.md +24/−0
LICENSE +26/−0
README.md +127/−0
Setup.hs +3/−0
bench/Bench.hs +400/−0
bench/BenchLib.hs +33/−0
heph-sparse-set.cabal +149/−0
src/Data/SparseSet/Generic/Mutable.hs +342/−0
src/Data/SparseSet/Generic/Mutable/Internal/GrowVec.hs +181/−0
src/Data/SparseSet/Generic/Mutable/Internal/MutableSparseArray.hs +155/−0
src/Data/SparseSet/Mutable.hs +216/−0
src/Data/SparseSet/Storable/Mutable.hs +198/−0
src/Data/SparseSet/Unboxed/Mutable.hs +198/−0
test/Data/SparseSet/Generic/Internal/GrowVecSpec.hs +173/−0
test/Data/SparseSet/Generic/Internal/MutableSparseArraySpec.hs +119/−0
test/Data/SparseSet/Unboxed/MutableSpec.hs +528/−0
test/Driver.hs +1/−0

+ CHANGELOG.md view

@@ -0,0 +1,24 @@+# Changelog for `heph-sparse-set`++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 - 2025-06-08++### Added++- Initial release of `heph-sparse-set`, a fast, mutable sparse set data structure.+- Provided `MutableSparseSet` implementations for `Unboxed`, `Storable`, and boxed types.+- Introduced amortized O(1) operations for insertions, deletions, and lookups.+- Implemented efficient iteration (`mapM_`, `ifoldM`) and intersection (`ifoldIntersectionM`).+- Included comprehensive test suite with unit tests, property-based tests, and `NoThunks` checks to ensure correctness and prevent space leaks.+- Designed with a flexible `PrimMonad` interface for use in `IO` and `ST` computations.++### Changed++- Explicitly marked as **NOT thread-safe**, prioritizing single-threaded performance.

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright 2025 Jeremy Nuttall++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,127 @@+# heph-sparse-set++A highly-performant, mutable sparse set implementation for Haskell.++This library is part of the forthcoming Hephaestus rendering system, but is sufficiently general purpose for any application that needs its particular behavior.++This library provides a mutable sparse set data structure designed for high-throughput systems where predictable, constant-time operations are critical. It is particularly well-suited for the performance demands of applications like game development (especially in ECS architectures), simulations, and other scenarios managing collections of integer-keyed data.++The design guarantees O(1) amortized complexity for core operations by leveraging direct array indexing and cache-friendly memory layouts.++## Features++- **Algorithmic Guarantees**: Provides amortized O(1) complexity for all core operations: `insert`, `delete`, and `lookup`.+- **Cache-Locality & Efficiency**: `Unboxed` and `Storable` implementations are built to ensure contiguous memory layout and minimal pointer indirection.+- **Monad-Agnostic Interface**: Operates within any `PrimMonad` context, enabling its use in both `IO` and pure `ST` computations without performance degradation.+- **Efficient Iteration**: Offers iterators (`mapM_`, `ifoldM`) that operate directly on the underlying contiguous storage, avoiding the allocation of intermediate lists.+- **Tested for Correctness**: The implementation is validated by a comprehensive test suite.++## Design & Implementation++At its core, `heph-sparse-set` is implemented with three internal vectors to provide its performance characteristics:++1.  A **dense** vector that stores the component data itself in a tightly packed array. Iteration happens over this array.+2.  An **indices** vector, also dense, that stores the entity ID for each element in the dense vector.+3.  A **sparse** vector that maps entity IDs directly to their location in the dense arrays. A lookup is a simple O(1) check in this vector.++When an element is removed, the last element from the dense arrays is swapped into the deleted element's slot (a "swap-and-pop"). This maintains the packed nature of the dense storage and ensures the O(1) time complexity for removals.++## Performance Characteristics++The full benchmark suite can be found in the `bench` directory and run with `cabal bench` or `stack bench`.++The following results compare `heph-sparse-set` against `Data.IntMap.Strict` for **100,000** elements, using the default GHC garbage collector on a quiet system. The results are highly stable (R² > 0.99) and demonstrate the significant performance advantage of `heph-sparse-set` for its target workloads.++| Operation                | `heph-sparse-set` | `Data.IntMap.Strict` | Advantage            | Speedup Factor |+| :----------------------- | :---------------- | :------------------- | :------------------- | :------------- |+| **Get (Existing)**       | **138 μs**        | 3,749 μs             | `heph-sparse-set`    | **~27x**       |+| **Contains (Existing)**  | **111 μs**        | 3,788 μs             | `heph-sparse-set`    | **~34x**       |+| **Update (Dense)**       | **168 μs**        | 11,290 μs            | `heph-sparse-set`    | **~67x**       |+| **Insert (Dense, Asc)**  | **1.86 ms**       | 5.44 ms              | `heph-sparse-set`    | **~2.9x**      |+| **Remove (Dense)**       | **1.02 ms**       | 1.81 ms              | `heph-sparse-set`    | **~1.8x**      |+| **Intersection (50%)**   | **157 μs**        | 1,177 μs             | `heph-sparse-set`    | **~7.5x**      |+| **Mixed Workload**       | **868 μs**        | 10,670 μs            | `heph-sparse-set`    | **~12x**       |+| **Insert (Sparse, Asc)** | 77.23 ms          | **7.67 ms**          | `Data.IntMap.Strict` | **~10x**       |++### Analysis++- **Lookups and Updates**: The core strength of `heph-sparse-set` is its true O(1) complexity for lookups, updates, and containment checks. The **~27x to ~67x speedup** is a direct result of simple array indexing versus the O(log n) tree traversal required by `IntMap`.++- **Dense Workloads**: For densely packed entity IDs, `heph-sparse-set` is significantly faster across all operations. The **~2.9x speedup** for dense insertions highlights the efficiency of amortized O(1) appends to contiguous vectors over the allocations and rebalancing of a tree structure.++- **Iteration and Cache Performance**: The library's advantage in iteration-heavy tasks like `Intersection` and the `Mixed Workload` showcases the benefit of its cache-friendly memory layout. Iterating over the internal dense arrays is significantly faster than the pointer chasing required to traverse the nodes of an `IntMap`.++- **The Sparse Insertion Trade-off**: The table clearly shows the primary trade-off. `Data.IntMap.Strict` is the superior choice for workloads dominated by **sparse, ascending key insertions**, where it performs up to **10x faster**. This is because each such insert in `heph-sparse-set` can trigger a costly reallocation of the internal sparse array. Interestingly, insertions in _descending_ sparse order are much faster in `heph-sparse-set` (`~14.6 ms`) because the sparse array is allocated once to its maximum required size and then filled, avoiding repeated reallocations.++## Usage++Here's a basic usage example with Unboxed sets in `IO`.++```haskell+import Data.SparseSet.Unboxed.Mutable qualified as SS++-- An entity in our system is just an Int+type Entity = Int+type Position = (Int, Int)++main :: IO ()+main = do+  -- Create a new sparse set+  positions <- SS.new @Position++  -- Insert some components+  SS.insert positions 10 (5, 5)   -- Entity 10 has position (5, 5)+  SS.insert positions 42 (1, 2)   -- Entity 42 has position (1, 2)+  SS.insert positions 3  (9, -4)++  -- Look up a component+  maybePos <- SS.lookup positions 42+  putStrLn $ "Position of entity 42: " <> show maybePos -- Just (1,2)++  -- Overwrite an existing component+  SS.insert positions 10 (6, 6)++  -- Delete a component+  deletedVal <- SS.delete positions 3+  putStrLn $ "Deleted component for entity 3: " <> show deletedVal -- Just (9,-4)++  -- Check for existence+  has42 <- SS.contains positions 42 -- True+  putStrLn $ "Set contains 42: " <> show has42+  has3  <- SS.contains positions 3  -- False+  putStrLn $ "Set contains 3: " <> show has3++  -- Efficiently iterate over all (entity, component) pairs+  putStrLn "Current members:"+  SS.imapM_ (\(entity, pos) -> print (entity, pos)) positions+  -- Expected output (order may vary):+  -- (10,(6,6))+  -- (42,(1,2))+```++## Considerations++### Memory Consumption++In general use, the memory consumption of this implementation will grow relative to the maximum key in the set. It is advisable to manage memory consumption deliberately:++1. Use the `compact` method periodically to reduce memory consumption. This is an expensive operation, so a reasonable heuristic would need to be established for your specific system.+2. Use a generational entity ID, so that entity ID growth can be constrained to a reasonable degree.++### Concurrency++This library is intentionally not thread-safe. For concurrent use, thread safety must be provided externally.++### Backwards Compatibility++I took some pains to ensure that this library is reasonably backwards-compatible. However, I'm intentionally designing Hephaestus to use GHC2021, so while this library doesn't use GHC2021, it does depend on modern language extensions that constrain its compatibility.++**Please note that you may experience performance degradation on GHC < 9.2**++- **Minimum supported GHC**: 8.10.4+- **Minimum supported Stackage snapshot**: lts-18.0++## Roadmap++- Compacted immutable sparse sets with read-only semantics for storage+- Atomic operations or wrappers

+ Setup.hs view

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

+ bench/Bench.hs view

@@ -0,0 +1,400 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Redundant irrefutable pattern" #-}+module Main (main) where++import BenchLib+import Control.DeepSeq+import Control.Monad (replicateM, void)+import Control.Monad.Primitive+import Control.Monad.State.Strict (evalState, state)+import Data.Foldable+import Data.IntMap.Strict qualified as M+import GHC.Generics (Generic)+import System.Random (StdGen, Uniform, mkStdGen, randomR)++import Data.IORef (modifyIORef', newIORef)+import Data.SparseSet.Unboxed.Mutable (MutableSparseSet)+import Data.SparseSet.Unboxed.Mutable qualified as SS++type TestComponent = Int+type TestEntity = Int++-- Common sizes for benchmarks+benchmarkSizes :: [Int]+benchmarkSizes = [10_000, 100_000]++randomSeed :: Int+randomSeed = 7113_1337++main :: IO ()+main = defaultMain [sparseSetBenchmarks, intMapBenchmarks]++-- Main benchmark suite entry point+sparseSetBenchmarks :: Benchmark+sparseSetBenchmarks =+  bgroup+    "Data.SparseSet.Unboxed.Mutable"+    [ makeInsertBenchGroup "Insert_DenseIDs_Sequential_AscendingOrder" False insertSequential+    , makeInsertBenchGroup "Insert_DenseIDs_Sequential_DescendingOrder" True insertSequential+    , makeInsertBenchGroup "Insert_SparseIDs_Step100_AscendingOrder" False insertSparseStep100+    , makeInsertBenchGroup "Insert_SparseIDs_Step100_DescendingOrder" True insertSparseStep100+    , makeUpdateBenchGroup "Update_DenseIDs_Sequential"+    , makeGetBenchGroup "Get_Existing_DenseIDs" True+    , makeGetBenchGroup "Get_NonExisting_DenseIDs" False+    , makeContainsBenchGroup "Contains_Existing_DenseIDs" True+    , makeContainsBenchGroup "Contains_NonExisting_DenseIDs" False+    , makeRemoveBenchGroup "Remove_DenseIDs_AscendingOrder" removeAscending+    , makeRemoveBenchGroup "Remove_DenseIDs_DescendingOrder" removeDescending+    , makeIterationBenchGroup "Iterate_DenseIDs"+    , makeIntersectionBenchGroup "Iterate_Intersection"+    , makeMixedBenchGroup "MixedWorkload_DenseIDs"+    ]+ where+  insertSequential set i = SS.insert set i i+  insertSparseStep100 set i = let entity = i * 100 in SS.insert set entity entity+  removeAscending _ = SS.delete+  removeDescending totalSize set i = SS.delete set (totalSize - 1 - i)++-- Generic benchmark group for N inserts+makeInsertBenchGroup+  :: String+  -> Bool+  -> (MutableSparseSet RealWorld TestComponent -> Int -> IO b)+  -> Benchmark+makeInsertBenchGroup groupName desc insert =+  bgroup+    groupName+    [ bench (show n) $+      perRunEnv+        (SS.new @TestComponent)+        \ ~set -> do+          traverse_ (insert set) (if desc then [n - 1, n - 2 .. 0] else [0 .. n - 1])+    | n <- benchmarkSizes+    ]++-- Generic benchmark group for N updates on existing elements+makeUpdateBenchGroup :: String -> Benchmark+makeUpdateBenchGroup groupName =+  bgroup+    groupName+    [ bench (show n ++ "_updates") $+      perRunEnv+        ( do+            set <- SS.new @TestComponent+            for_ [0 .. n - 1] \i -> SS.insert set i i+            pure set+        )+        \ ~set -> do+          for_ [0 .. n - 1] \i ->+            SS.insert set i (i + 1)+    | n <- benchmarkSizes+    ]++-- Generic benchmark group for N get operations+makeGetBenchGroup :: String -> Bool -> Benchmark+makeGetBenchGroup groupName getExisting =+  bgroup+    groupName+    [ env+      ( do+          -- Setup is run once per benchmark case (e.g., for n=100)+          set <- SS.new @TestComponent+          forM_ [0 .. n - 1] $ \i -> SS.insert set i i+          let idsToAccess =+                if getExisting+                  then [0 .. n - 1] -- Existing IDs+                  else [n .. (2 * n) - 1] -- Non-existing IDs+          pure (set, idsToAccess)+      )+      \ ~(set, idsToAccess) ->+        -- set and idsToAccess are from env+        bench (show n) $ nfIO do+          traverse_ (SS.lookup set) idsToAccess+    | n <- benchmarkSizes+    ]++-- Generic benchmark group for N contains operations+makeContainsBenchGroup :: String -> Bool -> Benchmark+makeContainsBenchGroup groupName checkExisting =+  bgroup+    groupName+    [ env+      ( do+          set <- SS.new @TestComponent+          forM_ [0 .. n - 1] $ \i -> SS.insert set i i+          let idsToAccess =+                if checkExisting+                  then [0 .. n - 1]+                  else [n .. (2 * n) - 1]+          pure (set, idsToAccess)+      )+      $ \ ~(set, idsToAccess) ->+        bench (show n) $ nfIO do+          traverse_ (SS.contains set) idsToAccess+    | n <- benchmarkSizes+    ]++-- Generic benchmark group for N removes+makeRemoveBenchGroup+  :: String -> (Int -> MutableSparseSet RealWorld TestComponent -> Int -> IO b) -> Benchmark+makeRemoveBenchGroup groupName removeAction =+  bgroup+    groupName+    [ bench (show n ++ "_removes") $+      perRunEnv+        ( do+            set <- SS.new @TestComponent+            for_ [0 .. n - 1] $ \i -> SS.insert set i i+            pure set+        )+        \ ~set ->+          traverse_ (removeAction n set) [0 .. n - 1]+    | n <- benchmarkSizes+    ]++makeIterationBenchGroup :: String -> Benchmark+makeIterationBenchGroup groupName =+  bgroup+    groupName+    [ env+      ( do+          -- Setup is run once per benchmark case+          set <- SS.new @TestComponent+          forM_ [0 .. n - 1] $ \i -> SS.insert set i i+          ref <- newIORef 0+          pure (set, ref)+      )+      \ ~(set, ref) ->+        bench (show n) $ nfIO do+          SS.mapM_ (\k -> modifyIORef' ref (+ k)) set+    | n <- benchmarkSizes+    ]++-- Generic benchmark group for N intersection operations+makeIntersectionBenchGroup :: String -> Benchmark+makeIntersectionBenchGroup groupName =+  bgroup+    groupName+    [ env+      ( do+          -- Create two sets with a 50% overlap.+          setA <- SS.new @TestComponent+          forM_ [0 .. n - 1] $ \i -> SS.insert setA i i++          setB <- SS.new @TestComponent+          let offset = n `div` 2+          forM_ [offset .. n + offset - 1] $ \i -> SS.insert setB i i++          ref <- newIORef @Int 0++          pure (setA, setB, ref)+      )+      \ ~(setA, setB, ref) ->+        bench (show n) $ nfIO do+          SS.ifoldIntersectionM (\_ k _ _ -> modifyIORef' ref (+ k)) () setA setB+    | n <- benchmarkSizes+    ]++-- Mixed Workload Benchmarks+data MixedOp = MIns TestEntity TestComponent | MRem TestEntity | MGet TestEntity | MCont TestEntity+  deriving (Show, Generic)++instance Uniform MixedOp++instance NFData MixedOp++generateMixedOps :: Int -> Int -> StdGen -> [MixedOp]+generateMixedOps numOps maxEntity = evalState (replicateM numOps genOp)+ where+  genOp = do+    opType <- state $ randomR (1 :: Int, 4)+    entity <- state $ randomR (0, maxEntity - 1)+    component <- state $ randomR (0, 1000)+    pure case opType of+      1 -> MIns entity component+      2 -> MRem entity+      3 -> MGet entity+      4 -> MCont entity+      _ -> error "Bad operation"++makeMixedBenchGroup :: String -> Benchmark+makeMixedBenchGroup groupName =+  bgroup+    groupName+    [ env+      (pure $ generateMixedOps n n (mkStdGen randomSeed))+      \ ~ops ->+        -- maxEntity = n, fixed seed+        bench (show n ++ "_ops") $ nfIO do+          set <- SS.new+          forM_ ops $ \case+            MIns e c -> SS.insert set e c+            MRem e -> void $ SS.delete set e+            MGet e -> void $ SS.lookup set e+            MCont e -> void $ SS.contains set e+    | n <- benchmarkSizes+    ]++generateMapWithSequentialKeys :: Int -> M.IntMap TestComponent+generateMapWithSequentialKeys n = foldl' (\acc i -> M.insert i i acc) M.empty [0 .. n - 1]++intMapBenchmarks :: Benchmark+intMapBenchmarks =+  bgroup+    "Data.IntMap.Strict"+    [ makeMapInsertBenchGroup "Insert_DenseIDs_Sequential_Map_AscendingOrder" False (\idx _ -> (idx, idx))+    , makeMapInsertBenchGroup "Insert_DenseIDs_Sequential_Map_DesendingOrder" True (\idx _ -> (idx, idx))+    , makeMapInsertBenchGroup+        "Insert_SparseIDs_Step100_Map_AscendingOrder"+        False+        (\idx _ -> (idx * 100, idx * 100))+    , makeMapInsertBenchGroup+        "Insert_SparseIDs_Step100_Map_DescendingOrder"+        True+        (\idx _ -> (idx * 100, idx * 100))+    , makeMapUpdateBenchGroup "Update_DenseIDs_Sequential_Map"+    , makeMapGetBenchGroup "Get_Existing_DenseIDs_Map" True+    , makeMapGetBenchGroup "Get_NonExisting_DenseIDs_Map" False+    , makeMapContainsBenchGroup "Contains_Existing_DenseIDs_Map" True -- Added for completeness+    , makeMapContainsBenchGroup "Contains_NonExisting_DenseIDs_Map" False+    , makeMapRemoveBenchGroup "Remove_DenseIDs_AscendingOrder_Map" (\_ _ entityIdx -> entityIdx)+    , makeMapRemoveBenchGroup+        "Remove_DenseIDs_DescendingOrder_Map"+        (\_ mapSize entityIdx -> mapSize - 1 - entityIdx)+    , makeMapIterationBenchGroup "Iterate_DenseIDs_Map"+    , makeMapIntersectionBenchGroup "Iterate_Intersection_Map"+    , makeMapMixedBenchGroup "MixedWorkload_DenseIDs_Map"+    ]++makeMapInsertBenchGroup+  :: String -> Bool -> (Int -> Int -> (TestEntity, TestComponent)) -> Benchmark+makeMapInsertBenchGroup groupName desc valueGenerator =+  bgroup+    groupName+    [ bench (show n) $+      nf+        ( \size ->+            foldl'+              (\m i -> let (k, v) = valueGenerator i size in M.insert k v m)+              M.empty+              (if desc then [n - 1, n - 2 .. 0] else [0 .. n - 1])+        )+        n+    | n <- benchmarkSizes+    ]++makeMapUpdateBenchGroup :: String -> Benchmark+makeMapUpdateBenchGroup groupName =+  bgroup+    groupName+    [ env (pure (generateMapWithSequentialKeys n)) $ \ ~initialMap ->+      bench (show n ++ "_updates") $+        -- For Map, an "update" is just an insert on an existing key+        nf (\m -> foldl' (\currentMap i -> M.insert i (i + 1) currentMap) m [0 .. n - 1]) initialMap+    | n <- benchmarkSizes+    ]++makeMapGetBenchGroup :: String -> Bool -> Benchmark+makeMapGetBenchGroup groupName getExisting =+  bgroup+    groupName+    [ env+      ( do+          let initialMap = generateMapWithSequentialKeys n+          let idsToAccess =+                if getExisting+                  then [0 .. n - 1] -- Existing IDs+                  else [n .. (2 * n) - 1] -- Non-existing IDs+          pure (initialMap, idsToAccess)+      )+      $ \ ~(m, idsToAccess) ->+        bench (show n) $ nf (map (`M.lookup` m)) idsToAccess+    | n <- benchmarkSizes+    ]++makeMapContainsBenchGroup :: String -> Bool -> Benchmark+makeMapContainsBenchGroup groupName checkExisting =+  bgroup+    groupName+    [ env+      ( do+          let initialMap = generateMapWithSequentialKeys n+          let idsToAccess =+                if checkExisting+                  then [0 .. n - 1]+                  else [n .. (2 * n) - 1]+          pure (initialMap, idsToAccess)+      )+      $ \ ~(m, idsToAccess) ->+        bench (show n) $ nf (map (`M.member` m)) idsToAccess+    | n <- benchmarkSizes+    ]++makeMapIterationBenchGroup :: String -> Benchmark+makeMapIterationBenchGroup groupName =+  bgroup+    groupName+    [ env+      ( do+          let initialMap = generateMapWithSequentialKeys n+          ref <- newIORef 0+          pure (initialMap, ref)+      )+      $ \ ~(initialMap, ref) ->+        bench (show n) $ nfIO do+          traverse_ (\k -> modifyIORef' ref (+ k)) initialMap+    | n <- benchmarkSizes+    ]++makeMapIntersectionBenchGroup :: String -> Benchmark+makeMapIntersectionBenchGroup groupName =+  bgroup+    groupName+    [ env+      ( do+          -- Create two maps with the same 50% overlap.+          let mapA = generateMapWithSequentialKeys n+              offset = n `div` 2+              mapB = foldl' (\acc i -> M.insert i i acc) M.empty [offset .. n + offset - 1]+          ref <- newIORef @Int 0+          pure (mapA, mapB, ref)+      )+      \ ~(mapA, mapB, ref) ->+        bench (show n) $ nfIO do+          let intersectionMap = M.intersectionWithKey (\eid _ _ -> eid) mapA mapB+          traverse_ (\k -> modifyIORef' ref (+ k)) intersectionMap+    | n <- benchmarkSizes+    ]++makeMapRemoveBenchGroup+  :: String -> (M.IntMap TestComponent -> Int -> Int -> TestEntity) -> Benchmark+makeMapRemoveBenchGroup groupName entityToRemoveGenerator =+  bgroup+    groupName+    [ env (pure (generateMapWithSequentialKeys n)) $ \ ~initialMap ->+      bench (show n ++ "_removes") $+        nf+          (\m -> foldl' (\currentMap i -> M.delete (entityToRemoveGenerator m n i) currentMap) m [0 .. n - 1])+          initialMap+    | n <- benchmarkSizes+    ]++makeMapMixedBenchGroup :: String -> Benchmark+makeMapMixedBenchGroup groupName =+  bgroup+    groupName+    [ env (pure $ generateMixedOps n n (mkStdGen randomSeed)) $ \ops ->+      bench (show n ++ "_ops") $ nf (runMapOps M.empty) ops+    | n <- benchmarkSizes+    ]+ where+  runMapOps :: M.IntMap TestComponent -> [MixedOp] -> M.IntMap TestComponent+  runMapOps = foldl' applyMapOp++  applyMapOp :: M.IntMap TestComponent -> MixedOp -> M.IntMap TestComponent+  applyMapOp currentMap op = case op of+    MIns e c -> M.insert e c currentMap+    MRem e -> M.delete e currentMap+    MGet e -> let !_ = M.lookup e currentMap in currentMap -- Force lookup+    MCont e -> let !_ = M.member e currentMap in currentMap -- Force member check

+ bench/BenchLib.hs view

@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Allows plug-and-play for tasty-bench and criterion+module BenchLib (+  Benchmark,+  Benchmarkable,+  bgroup,+  defaultMain,+  env,+  perBatchEnv,+  perRunEnv,+  bench,+  nf,+  nfIO,+  whnf,+) where++import Control.DeepSeq+import Criterion+import Criterion.Main++import Data.Primitive.MutVar+import Data.SparseSet.Generic.Mutable qualified as G+import Data.SparseSet.Unboxed.Mutable qualified as U++-- |+-- __NOTE__: The definition is the same as that for MVar and IORef in `deepseq`, so the same+-- caveat applies: Only strict in reference, not in value.+instance NFData (MutVar s a) where+  rnf = rwhnf++instance (NFData (v s a)) => NFData (G.MutableSparseSet v s a)+instance NFData (U.MutableSparseSet s a)

+ heph-sparse-set.cabal view

@@ -0,0 +1,149 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.38.0.+--+-- see: https://github.com/sol/hpack++name:           heph-sparse-set+version:        0.1.0.0+synopsis:       Really fast mutable sparse sets+description:    Please see the README on GitHub at <https://github.com/jtnuttall/heph/tree/main/heph-sparse-set#readme>+category:       Data Structures+homepage:       https://github.com/jtnuttall/heph/tree/main/heph-sparse-set#readme+bug-reports:    https://github.com/jtnuttall/heph/issues+author:         Jeremy Nuttall+maintainer:     jeremy@jeremy-nuttall.com+copyright:      2025 Jeremy Nuttall+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 9.8.4 || == 9.6.5 || == 8.10.7+extra-doc-files:+    README.md+    LICENSE+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/jtnuttall/heph++library+  exposed-modules:+      Data.SparseSet.Generic.Mutable+      Data.SparseSet.Generic.Mutable.Internal.GrowVec+      Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray+      Data.SparseSet.Mutable+      Data.SparseSet.Storable.Mutable+      Data.SparseSet.Unboxed.Mutable+  other-modules:+      Paths_heph_sparse_set+  autogen-modules:+      Paths_heph_sparse_set+  hs-source-dirs:+      src+  default-extensions:+      BangPatterns+      DeriveGeneric+      GeneralizedNewtypeDeriving+      FlexibleContexts+      ImportQualifiedPost+      NumericUnderscores+      RankNTypes+      StandaloneDeriving+      TupleSections+      TypeApplications+      BlockArguments+      DerivingStrategies+      LambdaCase+      RecordWildCards+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , deepseq >=1.4 && <1.6+    , primitive >=0.7 && <0.10+    , vector >=0.12.3.0 && <0.14+  default-language: Haskell2010++test-suite heph-sparse-set-test+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  other-modules:+      Data.SparseSet.Generic.Internal.GrowVecSpec+      Data.SparseSet.Generic.Internal.MutableSparseArraySpec+      Data.SparseSet.Unboxed.MutableSpec+      Paths_heph_sparse_set+  autogen-modules:+      Paths_heph_sparse_set+  hs-source-dirs:+      test+  default-extensions:+      BangPatterns+      DeriveGeneric+      GeneralizedNewtypeDeriving+      FlexibleContexts+      ImportQualifiedPost+      NumericUnderscores+      RankNTypes+      StandaloneDeriving+      TupleSections+      TypeApplications+      BlockArguments+      DerivingStrategies+      LambdaCase+      RecordWildCards+  ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      tasty-discover:tasty-discover+  build-depends:+      base >=4.7 && <5+    , containers >=0.6.2 && <0.8+    , deepseq >=1.4 && <1.6+    , hedgehog >=1.0.4 && <1.6+    , heph-sparse-set+    , nothunks >=0.1.3.0 && <0.4+    , primitive >=0.7 && <0.10+    , tasty >=1.4.1 && <1.6+    , tasty-discover >=4.2.1 && <6+    , tasty-hedgehog >=1.1 && <1.5+    , tasty-hunit ==0.10.*+    , vector >=0.12.3.0 && <0.14+  default-language: Haskell2010++benchmark heph-sparse-set-bench+  type: exitcode-stdio-1.0+  main-is: Bench.hs+  other-modules:+      BenchLib+      Paths_heph_sparse_set+  autogen-modules:+      Paths_heph_sparse_set+  hs-source-dirs:+      bench+  default-extensions:+      BangPatterns+      DeriveGeneric+      GeneralizedNewtypeDeriving+      FlexibleContexts+      ImportQualifiedPost+      NumericUnderscores+      RankNTypes+      StandaloneDeriving+      TupleSections+      TypeApplications+      BlockArguments+      DerivingStrategies+      LambdaCase+      RecordWildCards+  ghc-options: -Wall -Wcompat -threaded -rtsopts -O2+  build-depends:+      base >=4.7 && <5+    , containers+    , criterion >=1.5.9 && <1.7+    , deepseq+    , heph-sparse-set+    , mtl >=1.2 && <2.4+    , primitive >=0.7 && <0.10+    , random >=0.3.3 && <1.3+    , vector >=0.12.3.0 && <0.14+  default-language: Haskell2010

+ src/Data/SparseSet/Generic/Mutable.hs view

@@ -0,0 +1,342 @@+-- |+-- Description : Fast, mutable sparse sets.+-- Copyright   : (c) Jeremy Nuttall, 2025+-- License     : BSD-3-Clause+-- Maintainer  : jeremy@jeremy-nuttall.com+-- Stability   : experimental+-- Portability : GHC+--+-- Generic mutable sparse sets, usable in any state transformer monad.+--+-- __This implementation is NOT thread-safe.__ Thread safety must be maintained by a whole-set+-- locking mechanism.+module Data.SparseSet.Generic.Mutable (+  MutableSparseSet,++  -- * Creation+  withCapacity,+  new,++  -- * Read+  length,+  contains,+  members,+  lookup,++  -- * Update+  insert,+  delete,+  clear,+  compact,++  -- * Iteration+  foldM,+  ifoldM,+  mapM_,+  imapM_,+  ifoldIntersectionM,+)+where++import Control.Monad hiding (foldM, foldM_, mapM_)+import Control.Monad.Primitive+import Data.Primitive+import Data.Typeable (Typeable)+import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as MVG+import Data.Vector.Primitive.Mutable qualified as MVP+import GHC.Generics (Generic)+import Prelude hiding (length, lookup, mapM_)++import Data.SparseSet.Generic.Mutable.Internal.GrowVec (GrowVec)+import Data.SparseSet.Generic.Mutable.Internal.GrowVec qualified as GrowVec+import Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray (MutableSparseArray)+import Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray qualified as MSA+import Data.Vector.Internal.Check (HasCallStack)++data MutableSparseSet v s a = MutableSparseSet+  { ssDense :: {-# UNPACK #-} !(MutVar s (GrowVec v s a))+  , ssIndices :: {-# UNPACK #-} !(MutVar s (GrowVec MVP.MVector s Int))+  , ssSparse :: {-# UNPACK #-} !(MutVar s (MutableSparseArray s))+  }+  deriving (Generic, Typeable)++-- | Create a sparse set with a given dense and sparse capacity+--+-- It's a good idea to use this function if you have an estimate of your data requirements,+-- as it can prevent costly re-allocations as the set grows.+--+-- @since 0.1.0.0+withCapacity+  :: forall a v m+   . (PrimMonad m, MVG.MVector v a)+  => Int+  -- ^ Capacity for the dense set+  -> Int+  -- ^ Capacity for the sparse set+  -> m (MutableSparseSet v (PrimState m) a)+withCapacity dc sc =+  MutableSparseSet+    <$> (newMutVar =<< GrowVec.withCapacity dc)+    <*> (newMutVar =<< GrowVec.withCapacity dc)+    <*> (newMutVar =<< MSA.withCapacity sc)+{-# INLINE withCapacity #-}++-- | Create an empty sparse set with default capacities.+--+-- @since 0.1.0.0+new :: forall a v m. (PrimMonad m, MVG.MVector v a) => m (MutableSparseSet v (PrimState m) a)+new =+  MutableSparseSet+    <$> (newMutVar =<< GrowVec.new)+    <*> (newMutVar =<< GrowVec.new)+    <*> (newMutVar =<< MSA.new)+{-# INLINE new #-}++-- | O(1) Number of elements in the set (dense)+--+-- @since 0.1.0.0+length :: forall a v m. (PrimMonad m) => MutableSparseSet v (PrimState m) a -> m Int+length MutableSparseSet{..} = GrowVec.length <$> readMutVar ssDense+{-# INLINE length #-}++-- | O(1) Check whether an element is in the set+--+-- @since 0.1.0.0+contains :: forall a v m. (PrimMonad m) => MutableSparseSet v (PrimState m) a -> Int -> m Bool+contains MutableSparseSet{..} i = readMutVar ssSparse >>= (`MSA.contains` i)+{-# INLINE contains #-}++-- | O(n) The members of the set in an unspecified order.+--+-- @since 0.1.0.0+members+  :: forall w a v m. (VG.Vector v Int, PrimMonad m) => MutableSparseSet w (PrimState m) a -> m (v Int)+members MutableSparseSet{..} = fmap VG.convert . GrowVec.freeze =<< readMutVar ssIndices+{-# INLINE members #-}++-- | O(1) Look up an element in the set+--+-- @since 0.1.0.0+lookup+  :: forall a v m+   . (PrimMonad m, MVG.MVector v a)+  => MutableSparseSet v (PrimState m) a+  -> Int+  -> m (Maybe a)+lookup MutableSparseSet{..} i = do+  mSi <- (`MSA.lookup` i) =<< readMutVar ssSparse+  case mSi of+    Just si -> Just <$> (readMutVar ssDense >>= (`GrowVec.unsafeRead` si))+    Nothing -> pure Nothing+{-# INLINE lookup #-}++-- | O(1) amortized. Insert a value for a given key.+--+-- If the key is already in the set, its value is overwritten.+--+-- __INVARIANT__: Keys cannot be negative. An unchecked exception is+-- thrown if a negative key is added to the set.+--+-- @since 0.1.0.0+insert+  :: forall a v m+   . (HasCallStack, PrimMonad m, MVG.MVector v a)+  => MutableSparseSet v (PrimState m) a+  -> Int+  -> a+  -> m ()+insert MutableSparseSet{..} i v+  | i < 0 = error $ "Key cannot be negative, got: " <> show i+  | otherwise =+      readMutVar ssSparse >>= (`MSA.lookup` i) >>= \case+        Just di -> do+          dense <- readMutVar ssDense+          GrowVec.unsafeWrite dense di v+        Nothing -> do+          dense <- readMutVar ssDense+          writeMutVar ssDense =<< GrowVec.snoc dense v+          sparse <- readMutVar ssSparse >>= \arr -> MSA.unsafeInsert arr i (GrowVec.length dense)+          writeMutVar ssSparse sparse+          writeMutVar ssIndices =<< (`GrowVec.snoc` i) =<< readMutVar ssIndices+{-# INLINE insert #-}++-- | O(1) Delete an element from the set+--+-- @since 0.1.0.0+delete+  :: forall a v m+   . (PrimMonad m, MVG.MVector v a)+  => MutableSparseSet v (PrimState m) a+  -> Int+  -> m (Maybe a)+delete MutableSparseSet{..} i = do+  sparse <- readMutVar ssSparse+  MSA.delete sparse i >>= \case+    Just di -> do+      dense <- readMutVar ssDense+      indices <- readMutVar ssIndices+      (value, dense') <- GrowVec.unsafeSwapRemove dense di+      writeMutVar ssDense dense'+      (_, indices') <- GrowVec.unsafeSwapRemove indices di+      writeMutVar ssIndices indices'+      unless (di == GrowVec.length dense - 1) do+        swapped <- GrowVec.unsafeRead indices' di+        writeMutVar ssSparse =<< MSA.unsafeInsert sparse swapped di+      pure $ Just value+    Nothing -> pure Nothing+{-# INLINE delete #-}++-- | O(n) Clear all elements from the set.+--+-- @since 0.1.0.0+clear :: forall a v m. (PrimMonad m) => MutableSparseSet v (PrimState m) a -> m ()+clear MutableSparseSet{..} = do+  indices <- readMutVar ssIndices+  sparse <- readMutVar ssSparse+  GrowVec.mapM_ (MSA.unsafeDelete sparse) indices++  atomicModifyMutVar' ssDense ((,()) . GrowVec.cleared)+  atomicModifyMutVar' ssIndices ((,()) . GrowVec.cleared)+{-# INLINE clear #-}++-- | O(n) Shrink the capacity of the set to fit exactly the current number of elements.+--+-- @since 0.1.0.0+compact+  :: forall a v m. (PrimMonad m, MVG.MVector v a) => MutableSparseSet v (PrimState m) a -> m ()+compact MutableSparseSet{..} = do+  writeMutVar ssDense =<< GrowVec.compact =<< readMutVar ssDense+  indices <- readMutVar ssIndices+  indices' <- GrowVec.compact indices+  writeMutVar ssIndices indices'+  GrowVec.maximum indices >>= \case+    Nothing -> pure ()+    Just maxIndex -> do+      sparse <- readMutVar ssSparse+      writeMutVar ssSparse =<< MSA.unsafeCompactTo sparse (maxIndex + 1)+{-# INLINE compact #-}++-- | O(n) Iterate over the values of the set with an accumulator.+--+-- @since 0.1.0.0+foldM+  :: (PrimMonad m, MVG.MVector v a)+  => (b -> a -> m b)+  -> b+  -> MutableSparseSet v (PrimState m) a+  -> m b+foldM f initAcc MutableSparseSet{..} = do+  denseGV <- readMutVar ssDense+  let !len = GrowVec.length denseGV+      go !idx !acc+        | idx >= len = pure acc+        | otherwise = do+            component <- GrowVec.unsafeRead denseGV idx+            newAcc <- f acc component+            go (idx + 1) newAcc++  go 0 initAcc+{-# INLINE foldM #-}++-- | O(n) Iterate over the keys and values of the set with an accumulator.+--+-- @since 0.1.0.0+ifoldM+  :: (PrimMonad m, MVG.MVector v a)+  => (b -> (Int, a) -> m b)+  -> b+  -> MutableSparseSet v (PrimState m) a+  -> m b+ifoldM f initAcc MutableSparseSet{..} = do+  denseGV <- readMutVar ssDense+  indicesGV <- readMutVar ssIndices+  let !len = GrowVec.length denseGV+      go !idx !acc+        | idx >= len = pure acc+        | otherwise = do+            entity <- GrowVec.unsafeRead indicesGV idx+            component <- GrowVec.unsafeRead denseGV idx+            newAcc <- f acc (entity, component)+            go (idx + 1) newAcc++  go 0 initAcc+{-# INLINE ifoldM #-}++-- | O(n) Iterate over the values of the set.+--+-- @since 0.1.0.0+mapM_+  :: (PrimMonad m, MVG.MVector v a)+  => (a -> m ())+  -> MutableSparseSet v (PrimState m) a+  -> m ()+mapM_ f MutableSparseSet{..} = do+  denseGV <- readMutVar ssDense+  let !len = GrowVec.length denseGV+      go !idx+        | idx >= len = pure ()+        | otherwise = do+            component <- GrowVec.unsafeRead denseGV idx+            f component+            go (idx + 1)+  go 0+{-# INLINE mapM_ #-}++-- | O(n) Iterate over the keys and values of the set.+--+-- @since 0.1.0.0+imapM_+  :: (PrimMonad m, MVG.MVector v a)+  => ((Int, a) -> m ())+  -> MutableSparseSet v (PrimState m) a+  -> m ()+imapM_ f MutableSparseSet{..} = do+  denseGV <- readMutVar ssDense+  indicesGV <- readMutVar ssIndices+  let !len = GrowVec.length denseGV+      go !idx+        | idx >= len = pure ()+        | otherwise = do+            entity <- GrowVec.unsafeRead indicesGV idx+            component <- GrowVec.unsafeRead denseGV idx+            f (entity, component)+            go (idx + 1)+  go 0+{-# INLINE imapM_ #-}++-- | O(min(n, m)) Iterate over the intersection of two sets with an accumulator.+--+-- The order of the arguments does not matter - the smaller of the two sets is+-- selected as the iteratee.+--+-- @since 0.1.0.0+ifoldIntersectionM+  :: (PrimMonad m, MVG.MVector v a, MVG.MVector v b)+  => (c -> Int -> a -> b -> m c)+  -- ^ Accumulator+  -> c+  -- ^ Initial value+  -> MutableSparseSet v (PrimState m) a+  -- ^ Set A+  -> MutableSparseSet v (PrimState m) b+  -- ^ Set B+  -> m c+ifoldIntersectionM f c a b = do+  la <- length a+  lb <- length b++  if la <= lb+    then ifoldM (goLookupB b) c a+    else ifoldM (goLookupA a) c b+ where+  goLookupB otherSetB acc (entity, componentA) =+    lookup otherSetB entity >>= \case+      Nothing -> pure acc+      Just componentB -> f acc entity componentA componentB++  goLookupA otherSetA acc (entity, componentB) =+    lookup otherSetA entity >>= \case+      Nothing -> pure acc+      Just componentA -> f acc entity componentA componentB+{-# INLINE ifoldIntersectionM #-}

+ src/Data/SparseSet/Generic/Mutable/Internal/GrowVec.hs view

@@ -0,0 +1,181 @@+-- |+-- Description : A generic growable mutable vector with O(1) amortized append.+-- Copyright   : (c) Jeremy Nuttall, 2025+-- License     : BSD-3-Clause+-- Maintainer  : jeremy@jeremy-nuttall.com+-- Stability   : experimental+-- Portability : GHC+--+-- __WARNING:__ The functions in this module are generally unchecked and unsafe. Be careful to understand+-- and maintain invariants if using them. Misuse may result in undefined behavior.+--+-- Internal modules can change without warning between minor versions.+module Data.SparseSet.Generic.Mutable.Internal.GrowVec (+  GrowVec,+  withCapacity,+  new,+  length,+  capacity,+  snoc,+  readMaybe,+  unsafeRead,+  maximum,+  unsafeWrite,+  unsafeSwapRemove,+  mapM_,+  cleared,+  compact,+  freeze,+  unsafeFreeze,+)+where++import Control.DeepSeq (NFData)+import Control.Monad.Primitive+import Data.Typeable (Typeable)+import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as VGM+import GHC.Generics (Generic)+import Prelude hiding (length, mapM_, maximum)++data GrowVec v s a = GrowVec {-# UNPACK #-} !Int (v s a)+  deriving (Show, Generic, Typeable)++instance (NFData (v s a)) => NFData (GrowVec v s a)++-- | Create a new, empty vector with the given capacity+--+-- @since 0.1.0.0+withCapacity :: forall a v m. (PrimMonad m, VGM.MVector v a) => Int -> m (GrowVec v (PrimState m) a)+withCapacity c = GrowVec 0 <$> VGM.new (withMinCapacity c)+{-# INLINE withCapacity #-}++-- | Create a new, empty vector with a default capcity+--+-- @since 0.1.0.0+new :: forall a v m. (PrimMonad m, VGM.MVector v a) => m (GrowVec v (PrimState m) a)+new = GrowVec 0 <$> VGM.new 16+{-# INLINE new #-}++-- | O(1) The logical length of the vector.+length :: forall a v s. GrowVec v s a -> Int+length (GrowVec l _) = l+{-# INLINE length #-}++-- | O(1) The capacity of the vector.+capacity :: (VGM.MVector v a) => GrowVec v s a -> Int+capacity (GrowVec _ v) = VGM.length v+{-# INLINE capacity #-}++-- | Calculate the additional number of elements given the current length.+--+-- __INVARIANT__: length must be >= 2+--+-- @since 0.1.0.0+growthFactor :: Int -> Int+growthFactor l = (l `quot` 2) * 3+{-# INLINE growthFactor #-}++-- | O(1) amortized. Append to the vector, reallocating and copying if necessary.+--+-- Since this can't be done in-place, you must use the resulting vector in further computations.+--+-- @since 0.1.0.0+snoc+  :: (VGM.MVector v a, PrimMonad m) => GrowVec v (PrimState m) a -> a -> m (GrowVec v (PrimState m) a)+snoc gv a = do+  gv' <- grow gv+  unsafeWrite gv' (length gv) a+  pure gv'+ where+  grow (GrowVec l v)+    | capacity gv <= l = GrowVec (l + 1) <$> VGM.grow v (growthFactor l)+    | otherwise = pure $ GrowVec (l + 1) v+{-# INLINE snoc #-}++readMaybe+  :: forall a m v. (PrimMonad m, VGM.MVector v a) => GrowVec v (PrimState m) a -> Int -> m (Maybe a)+readMaybe (GrowVec l v) i+  | l < 0 || i >= l = pure Nothing+  | otherwise = Just <$> VGM.unsafeRead v i+{-# INLINE readMaybe #-}++-- | O(1) Read from a position in the vector. This position must be less than the length of the vector. This is not checked.+--+-- @since 0.1.0.0+unsafeRead+  :: forall a m v. (PrimMonad m, VGM.MVector v a) => GrowVec v (PrimState m) a -> Int -> m a+unsafeRead (GrowVec _ v) = VGM.unsafeRead v+{-# INLINE unsafeRead #-}++-- | O(n) The maximum value in the vector. Useful for compaction.+--+-- @since 0.1.0.0+maximum+  :: (PrimMonad m, VGM.MVector v a, Ord a, Bounded a) => GrowVec v (PrimState m) a -> m (Maybe a)+maximum (GrowVec l v)+  | l <= 0 = pure Nothing+  | otherwise = Just <$> VGM.foldl' max minBound (VGM.unsafeSlice 0 l v)+{-# INLINE maximum #-}++-- | O(1) Write to a position in the vector. This position must be less than the length of the vector. This is not checked.+--+-- @since 0.1.0.0+unsafeWrite+  :: forall a m v. (PrimMonad m, VGM.MVector v a) => GrowVec v (PrimState m) a -> Int -> a -> m ()+unsafeWrite (GrowVec _ v) = VGM.unsafeWrite v+{-# INLINE unsafeWrite #-}++-- | O(1) Swap-and-pop an element in the vector+--+-- @since 0.1.0.0+unsafeSwapRemove+  :: forall a m v+   . (PrimMonad m, VGM.MVector v a)+  => GrowVec v (PrimState m) a+  -> Int+  -> m (a, GrowVec v (PrimState m) a)+unsafeSwapRemove (GrowVec l v) i = do+  old <- VGM.read v i+  VGM.swap v i (l - 1)+  pure (old, GrowVec (l - 1) v)+{-# INLINE unsafeSwapRemove #-}++mapM_ :: (PrimMonad m, VGM.MVector v a) => (a -> m b) -> GrowVec v (PrimState m) a -> m ()+mapM_ f (GrowVec l v) = VGM.mapM_ f (VGM.unsafeSlice 0 l v)+{-# INLINE mapM_ #-}++-- | O(1) Create a new, empty vector by setting logical length to 0. This does not change the+-- underlying vector in any way.+--+-- @since 0.1.0.0+cleared :: forall a s v. GrowVec v s a -> GrowVec v s a+cleared (GrowVec _ v) = GrowVec 0 v+{-# INLINE cleared #-}++-- | O(n) Shrink the vector so that its capacity matches its current length+--+-- @since 0.1.0.0+compact+  :: (VGM.MVector v a, PrimMonad m) => GrowVec v (PrimState m) a -> m (GrowVec v (PrimState m) a)+compact gv@(GrowVec l v)+  | capacity gv == l = pure gv+  | otherwise = do+      let l' = withMinCapacity l+      v' <- VGM.clone (VGM.unsafeSlice 0 l' v)+      pure (GrowVec l v')++freeze :: (PrimMonad m, VG.Vector v a) => GrowVec (VG.Mutable v) (PrimState m) a -> m (v a)+freeze (GrowVec l v) = VG.freeze (VGM.unsafeSlice 0 l v)+{-# INLINE freeze #-}++unsafeFreeze :: (PrimMonad m, VG.Vector v a) => GrowVec (VG.Mutable v) (PrimState m) a -> m (v a)+unsafeFreeze (GrowVec l v) = VG.unsafeFreeze (VGM.unsafeSlice 0 l v)+{-# INLINE unsafeFreeze #-}++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------+withMinCapacity :: Int -> Int+withMinCapacity c = max c 4+{-# INLINE withMinCapacity #-}

+ src/Data/SparseSet/Generic/Mutable/Internal/MutableSparseArray.hs view

@@ -0,0 +1,155 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}++-- |+-- Description : Mutable sparse arrays, suitable for sparse set implementation.+-- Copyright   : (c) Jeremy Nuttall, 2025+-- License     : BSD-3-Clause+-- Maintainer  : jeremy@jeremy-nuttall.com+-- Stability   : experimental+-- Portability : GHC+--+-- __WARNING:__ The functions in this module are generally unchecked and unsafe. Be careful to understand+-- and maintain invariants if using them. Misuse may result in undefined behavior.+--+-- Internal modules can change without warning between minor versions.+module Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray (+  MutableSparseArray,+  withCapacity,+  new,+  contains,+  lookup,+  unsafeInsert,+  delete,+  unsafeDelete,+  clear,+  unsafeCompactTo,+  freeze,+  unsafeFreeze,+)+where++import Control.DeepSeq (NFData)+import Control.Monad (when)+import Control.Monad.Primitive+import Data.Maybe (isJust)+import Data.Typeable (Typeable)+import Data.Vector.Generic.Mutable qualified as VGM+import Data.Vector.Primitive qualified as VP+import Data.Vector.Primitive.Mutable qualified as VPM+import GHC.Generics (Generic)+import Prelude hiding (lookup, maximum)++pattern ABSURD :: Int+pattern ABSURD = -1++-- | Mutable sparse integer array parameterized by its state token.+--+-- @since 0.1.0.0+newtype MutableSparseArray s = MutableSparseArray+  {getSparseArray :: VPM.MVector s Int}+  deriving newtype (NFData)+  deriving stock (Generic, Typeable)++-- | Create a new, empty array from a given capacity.+--+-- @since 0.1.0.0+withCapacity :: (PrimMonad m) => Int -> m (MutableSparseArray (PrimState m))+withCapacity rc = stToPrim do+  let c = max rc 4+  arr <- VPM.new c+  when (c > 0) $ fillArray 0 c arr+  pure $ MutableSparseArray arr+{-# INLINE withCapacity #-}++-- | Create a new, empty array.+--+-- @since 0.1.0.0+new :: (PrimMonad m) => m (MutableSparseArray (PrimState m))+new = withCapacity 32+{-# INLINE new #-}++contains :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m Bool+contains arr i = isJust <$> lookup arr i+{-# INLINE contains #-}++lookup :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m (Maybe Int)+#if MIN_VERSION_vector(0,13,0)+lookup (MutableSparseArray arr) i = (>>= msaReprToMaybe) <$> VPM.readMaybe arr i+#else+lookup (MutableSparseArray arr) i+  | i < 0 || i >= VPM.length arr = pure Nothing+  | otherwise = msaReprToMaybe <$> VPM.unsafeRead arr i+#endif+{-# INLINE lookup #-}++unsafeInsert+  :: (PrimMonad m)+  => MutableSparseArray (PrimState m)+  -> Int+  -> Int+  -> m (MutableSparseArray (PrimState m))+unsafeInsert (MutableSparseArray arr) i v+  | i < 0 = error $ "Negative index " <> show i+  | otherwise = do+      let len = VPM.length arr+          growBy = max (i + 1) ((len `quot` 2) * 3)+      mArr <-+        if i >= len+          then do+            r <- VPM.unsafeGrow arr growBy+            fillArray len growBy r+            pure r+          else pure arr++      VPM.unsafeWrite mArr i v+      pure $ MutableSparseArray mArr+{-# INLINE unsafeInsert #-}++delete :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m (Maybe Int)+delete (MutableSparseArray arr) i+  | i < 0 || i >= VPM.length arr = pure Nothing+  | otherwise = msaReprToMaybe <$> VPM.unsafeExchange arr i ABSURD+{-# INLINE delete #-}++-- | Currently checks that the index is not negative, but this may change in the future+--+-- @since 0.1.0.0+unsafeDelete :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m (Maybe Int)+unsafeDelete (MutableSparseArray arr) i+  | i < 0 = error $ "Negative index " <> show i+  | otherwise = msaReprToMaybe <$> VPM.unsafeExchange arr i ABSURD+{-# INLINE unsafeDelete #-}++clear :: (PrimMonad m) => MutableSparseArray (PrimState m) -> m ()+clear (MutableSparseArray arr) = VPM.set arr ABSURD+{-# INLINE clear #-}++unsafeCompactTo+  :: (PrimMonad m) => MutableSparseArray (PrimState m) -> Int -> m (MutableSparseArray (PrimState m))+unsafeCompactTo (MutableSparseArray arr) len+  | len < 0 = error "Cannot compact to negative capacity"+  | len >= VPM.length arr = pure $ MutableSparseArray arr+  | otherwise = MutableSparseArray <$> VPM.clone (VPM.slice 0 len arr)+{-# INLINE unsafeCompactTo #-}++freeze :: (PrimMonad m) => MutableSparseArray (PrimState m) -> m (VP.Vector Int)+freeze (MutableSparseArray arr) = VP.freeze arr+{-# INLINE freeze #-}++unsafeFreeze :: (PrimMonad m) => MutableSparseArray (PrimState m) -> m (VP.Vector Int)+unsafeFreeze (MutableSparseArray arr) = VP.unsafeFreeze arr+{-# INLINE unsafeFreeze #-}++--------------------------------------------------------------------------------+-- Utilities+--------------------------------------------------------------------------------+msaReprToMaybe :: Int -> Maybe Int+msaReprToMaybe v+  | v <= ABSURD = Nothing+  | otherwise = Just v+{-# INLINE msaReprToMaybe #-}++fillArray :: (PrimMonad m, VGM.MVector v Int) => Int -> Int -> v (PrimState m) Int -> m ()+fillArray len growBy arr = stToPrim $ VGM.basicSet (VGM.basicUnsafeSlice len growBy arr) ABSURD+{-# INLINE fillArray #-}

+ src/Data/SparseSet/Mutable.hs view

@@ -0,0 +1,216 @@+{-# LANGUAGE CPP #-}++-- |+-- Description : Fast, mutable sparse sets.+-- Copyright   : (c) Jeremy Nuttall, 2025+-- License     : BSD-3-Clause+-- Maintainer  : jeremy@jeremy-nuttall.com+-- Stability   : experimental+-- Portability : GHC+--+-- Boxed, strict mutable sparse sets. Prefer Storable or Unboxed sparse sets where possible as they are+-- significantly more performant.+--+-- All inserted values are forced to WHNF. Performance is likely to be better with vector >= 0.13.2.0+--+-- __This implementation is NOT thread-safe.__ Thread safety must be maintained by a whole-set+-- locking mechanism.+module Data.SparseSet.Mutable (+  MutableSparseSet,+  IOMutableSparseSet,+  STMutableSparseSet,++  -- * Creation+  withCapacity,+  new,++  -- * Read+  length,+  contains,+  members,+  lookup,++  -- * Update+  insert,+  delete,+  clear,+  compact,++  -- * Iteration+  foldM,+  ifoldM,+  mapM_,+  imapM_,+  ifoldIntersectionM,+)+where++import Control.Monad.Primitive+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Prelude hiding (length, lookup, mapM_)++#if MIN_VERSION_vector(0,13,2)+import Data.Vector.Strict qualified as V+import Data.Vector.Strict.Mutable qualified as MV+#else+import Data.Vector qualified as V+import Data.Vector.Mutable qualified as MV+#endif++import Data.SparseSet.Generic.Mutable qualified as G++newtype MutableSparseSet s a = MSS (G.MutableSparseSet MV.MVector s a)+  deriving stock (Generic, Typeable)++type IOMutableSparseSet = MutableSparseSet RealWorld+type STMutableSparseSet s = MutableSparseSet s++-- | Create a sparse set with a given dense and sparse capacity+--+-- It's a good idea to use this function if you have an estimate of your data requirements,+-- as it can prevent costly re-allocations as the set grows.+--+-- @since 0.1.0.0+withCapacity+  :: (PrimMonad m)+  => Int+  -- ^ Capacity for the dense set+  -> Int+  -- ^ Capacity for the sparse set+  -> m (MutableSparseSet (PrimState m) a)+withCapacity dc sc = MSS <$> G.withCapacity dc sc++-- | Create an empty sparse set with default capacities+--+-- @since 0.1.0.0+new :: forall a m. (PrimMonad m) => m (MutableSparseSet (PrimState m) a)+new = MSS <$> G.new+{-# INLINE new #-}++-- | O(1) Number of elements in the set (dense)+--+-- @since 0.1.0.0+length :: forall a m. (PrimMonad m) => MutableSparseSet (PrimState m) a -> m Int+length (MSS g) = G.length g+{-# INLINE length #-}++-- | O(1) Check whether an element is in the set+--+-- @since 0.1.0.0+contains :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m Bool+contains (MSS g) = G.contains g+{-# INLINE contains #-}++-- | O(n) The members of the set in an unspecified order.+--+-- @since 0.1.0.0+members :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m (V.Vector Int)+members (MSS g) = G.members g+{-# INLINE members #-}++-- | O(1) Look up an element in the set+--+-- @since 0.1.0.0+lookup :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a)+lookup (MSS g) = G.lookup g+{-# INLINE lookup #-}++-- | O(1) amortized. Insert a value for a given key.+--+-- If the key is already in the set, its value is overwritten.+--+-- __INVARIANT__: Keys cannot be negative. An unchecked exception is+-- thrown if a negative key is added to the set.+--+-- @since 0.1.0.0+insert :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> a -> m ()+#if MIN_VERSION_vector(0,13,2)+insert (MSS g) = G.insert g+#else+insert (MSS g) i !v = G.insert g i v+#endif+{-# INLINE insert #-}++-- | O(1) Delete an element from the set+--+-- @since 0.1.0.0+delete :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a)+delete (MSS g) = G.delete g+{-# INLINE delete #-}++-- | O(n) Clear all elements from the set+--+-- @since 0.1.0.0+clear :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m ()+clear (MSS g) = G.clear g+{-# INLINE clear #-}++-- | O(n) Shrink the capacity of the set to fit exactly the current number of elements.+--+-- @since 0.1.0.0+compact :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m ()+compact (MSS g) = G.compact g+{-# INLINE compact #-}++-- | O(n) Fold over the values of the set.+--+-- @since 0.1.0.0+foldM+  :: (PrimMonad m)+  => (b -> a -> m b)+  -> b+  -> MutableSparseSet (PrimState m) a+  -> m b+foldM f initAcc (MSS g) = G.foldM f initAcc g+{-# INLINE foldM #-}++-- | O(n) Fold over the keys and values of the set.+--+-- @since 0.1.0.0+ifoldM+  :: (PrimMonad m)+  => (b -> (Int, a) -> m b)+  -> b+  -> MutableSparseSet (PrimState m) a+  -> m b+ifoldM f initAcc (MSS g) = G.ifoldM f initAcc g+{-# INLINE ifoldM #-}++-- | O(n) Iterate over the values of the set.+--+-- @since 0.1.0.0+mapM_+  :: (PrimMonad m)+  => (a -> m ()) -- Action to perform+  -> MutableSparseSet (PrimState m) a+  -> m ()+mapM_ f (MSS g) = G.mapM_ f g+{-# INLINE mapM_ #-}++-- | O(n) Iterate over the keys and values of the set.+--+-- @since 0.1.0.0+imapM_+  :: (PrimMonad m)+  => ((Int, a) -> m ()) -- Action to perform+  -> MutableSparseSet (PrimState m) a+  -> m ()+imapM_ f (MSS g) = G.imapM_ f g+{-# INLINE imapM_ #-}++-- | O(min(n, m)) Iterate over the intersection of two sets with an accumulator.+--+-- The order of the arguments does not matter - the smaller of the two sets is+-- selected as the iteratee.+--+-- @since 0.1.0.0+ifoldIntersectionM+  :: (PrimMonad m)+  => (c -> Int -> a -> b -> m c)+  -> c+  -> MutableSparseSet (PrimState m) a+  -> MutableSparseSet (PrimState m) b+  -> m c+ifoldIntersectionM acc c (MSS a) (MSS b) = G.ifoldIntersectionM acc c a b+{-# INLINE ifoldIntersectionM #-}

+ src/Data/SparseSet/Storable/Mutable.hs view

@@ -0,0 +1,198 @@+-- |+-- Description : Fast, mutable sparse sets.+-- Copyright   : (c) Jeremy Nuttall, 2025+-- License     : BSD-3-Clause+-- Maintainer  : jeremy@jeremy-nuttall.com+-- Stability   : experimental+-- Portability : GHC+--+-- __This implementation is NOT thread-safe.__ Thread safety must be maintained by a whole-set+-- locking mechanism.+module Data.SparseSet.Storable.Mutable (+  MutableSparseSet,+  IOMutableSparseSet,+  STMutableSparseSet,++  -- * Creation+  withCapacity,+  new,++  -- * Read+  length,+  contains,+  members,+  lookup,++  -- * Update+  insert,+  delete,+  clear,+  compact,++  -- * Iteration+  foldM,+  ifoldM,+  mapM_,+  imapM_,+  ifoldIntersectionM,+)+where++import Control.Monad.Primitive+import Data.Typeable (Typeable)+import Data.Vector.Storable qualified as VS+import GHC.Generics (Generic)+import Prelude hiding (length, lookup, mapM_)++import Data.SparseSet.Generic.Mutable qualified as G++newtype MutableSparseSet s a = MSS (G.MutableSparseSet VS.MVector s a)+  deriving stock (Generic, Typeable)++type IOMutableSparseSet = MutableSparseSet RealWorld+type STMutableSparseSet s = MutableSparseSet s++-- | Create a sparse set with a given dense and sparse capacity+--+-- It's a good idea to use this function if you have an estimate of your data requirements,+-- as it can prevent costly re-allocations as the set grows.+--+-- @since 0.1.0.0+withCapacity+  :: (PrimMonad m, VS.Storable a)+  => Int+  -- ^ Capacity for the dense set+  -> Int+  -- ^ Capacity for the sparse set+  -> m (MutableSparseSet (PrimState m) a)+withCapacity dc sc = MSS <$> G.withCapacity dc sc++-- | Create an empty sparse set with default capacities+--+-- @since 0.1.0.0+new :: forall a m. (PrimMonad m, VS.Storable a) => m (MutableSparseSet (PrimState m) a)+new = MSS <$> G.new+{-# INLINE new #-}++-- | O(1) Number of elements in the set (dense)+--+-- @since 0.1.0.0+length :: forall a m. (PrimMonad m) => MutableSparseSet (PrimState m) a -> m Int+length (MSS g) = G.length g+{-# INLINE length #-}++-- | O(1) Check whether an element is in the set+--+-- @since 0.1.0.0+contains :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m Bool+contains (MSS g) = G.contains g+{-# INLINE contains #-}++-- | O(n) The members of the set in an unspecified order.+--+-- @since 0.1.0.0+members :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m (VS.Vector Int)+members (MSS g) = G.members g+{-# INLINE members #-}++-- | O(1) Look up an element in the set+--+-- @since 0.1.0.0+lookup :: (PrimMonad m, VS.Storable a) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a)+lookup (MSS g) = G.lookup g+{-# INLINE lookup #-}++-- | O(1) amortized. Insert a value for a given key.+--+-- If the key is already in the set, its value is overwritten.+--+-- __INVARIANT__: Keys cannot be negative. An unchecked exception is+-- thrown if a negative key is added to the set.+--+-- @since 0.1.0.0+insert :: (PrimMonad m, VS.Storable a) => MutableSparseSet (PrimState m) a -> Int -> a -> m ()+insert (MSS g) = G.insert g+{-# INLINE insert #-}++-- | O(1) Delete an element from the set+--+-- @since 0.1.0.0+delete :: (PrimMonad m, VS.Storable a) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a)+delete (MSS g) = G.delete g+{-# INLINE delete #-}++-- | O(1) Clear all elements from the set+--+-- @since 0.1.0.0+clear :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m ()+clear (MSS g) = G.clear g+{-# INLINE clear #-}++-- | O(n) Shrink the capacity of the set to fit exactly the current number of elements.+--+-- @since 0.1.0.0+compact :: (PrimMonad m, VS.Storable a) => MutableSparseSet (PrimState m) a -> m ()+compact (MSS g) = G.compact g+{-# INLINE compact #-}++-- | O(n) Fold over the values of the set.+--+-- @since 0.1.0.0+foldM+  :: (PrimMonad m, VS.Storable a)+  => (b -> a -> m b)+  -> b+  -> MutableSparseSet (PrimState m) a+  -> m b+foldM f initAcc (MSS g) = G.foldM f initAcc g+{-# INLINE foldM #-}++-- | O(n) Fold over the keys and values of the set.+--+-- @since 0.1.0.0+ifoldM+  :: (PrimMonad m, VS.Storable a)+  => (b -> (Int, a) -> m b)+  -> b+  -> MutableSparseSet (PrimState m) a+  -> m b+ifoldM f initAcc (MSS g) = G.ifoldM f initAcc g+{-# INLINE ifoldM #-}++-- | O(n) Iterate over the values of the set.+--+-- @since 0.1.0.0+mapM_+  :: (PrimMonad m, VS.Storable a)+  => (a -> m ()) -- Action to perform+  -> MutableSparseSet (PrimState m) a+  -> m ()+mapM_ f (MSS g) = G.mapM_ f g+{-# INLINE mapM_ #-}++-- | O(n) Iterate over the keys and values of the set.+--+-- @since 0.1.0.0+imapM_+  :: (PrimMonad m, VS.Storable a)+  => ((Int, a) -> m ()) -- Action to perform+  -> MutableSparseSet (PrimState m) a+  -> m ()+imapM_ f (MSS g) = G.imapM_ f g+{-# INLINE imapM_ #-}++-- | O(min(n, m)) Iterate over the intersection of two sets with an accumulator.+--+-- The order of the arguments does not matter - the smaller of the two sets is+-- selected as the iteratee.+--+-- @since 0.1.0.0+ifoldIntersectionM+  :: (PrimMonad m, VS.Storable a, VS.Storable b)+  => (c -> Int -> a -> b -> m c)+  -> c+  -> MutableSparseSet (PrimState m) a+  -> MutableSparseSet (PrimState m) b+  -> m c+ifoldIntersectionM acc c (MSS a) (MSS b) = G.ifoldIntersectionM acc c a b+{-# INLINE ifoldIntersectionM #-}

+ src/Data/SparseSet/Unboxed/Mutable.hs view

@@ -0,0 +1,198 @@+-- |+-- Description : Fast, mutable sparse sets.+-- Copyright   : (c) Jeremy Nuttall, 2025+-- License     : BSD-3-Clause+-- Maintainer  : jeremy@jeremy-nuttall.com+-- Stability   : experimental+-- Portability : GHC+--+-- __This implementation is NOT thread-safe.__ Thread safety must be maintained by a whole-set+-- locking mechanism.+module Data.SparseSet.Unboxed.Mutable (+  MutableSparseSet,+  IOMutableSparseSet,+  STMutableSparseSet,++  -- * Creation+  withCapacity,+  new,++  -- * Read+  length,+  contains,+  members,+  lookup,++  -- * Update+  insert,+  delete,+  clear,+  compact,++  -- * Iteration+  foldM,+  ifoldM,+  mapM_,+  imapM_,+  ifoldIntersectionM,+)+where++import Control.Monad.Primitive+import Data.Typeable (Typeable)+import Data.Vector.Unboxed qualified as VU+import GHC.Generics (Generic)+import Prelude hiding (length, lookup, mapM_)++import Data.SparseSet.Generic.Mutable qualified as G++newtype MutableSparseSet s a = MSS (G.MutableSparseSet VU.MVector s a)+  deriving stock (Generic, Typeable)++type IOMutableSparseSet = MutableSparseSet RealWorld+type STMutableSparseSet s = MutableSparseSet s++-- | Create a sparse set with a given dense and sparse capacity+--+-- It's a good idea to use this function if you have an estimate of your data requirements,+-- as it can prevent costly re-allocations as the set grows.+--+-- @since 0.1.0.0+withCapacity+  :: (PrimMonad m, VU.Unbox a)+  => Int+  -- ^ Capacity for the dense set+  -> Int+  -- ^ Capacity for the sparse set+  -> m (MutableSparseSet (PrimState m) a)+withCapacity dc sc = MSS <$> G.withCapacity dc sc++-- | Create an empty sparse set with default capacities+--+-- @since 0.1.0.0+new :: forall a m. (PrimMonad m, VU.Unbox a) => m (MutableSparseSet (PrimState m) a)+new = MSS <$> G.new+{-# INLINE new #-}++-- | O(1) Number of elements in the set (dense)+--+-- @since 0.1.0.0+length :: forall a m. (PrimMonad m) => MutableSparseSet (PrimState m) a -> m Int+length (MSS g) = G.length g+{-# INLINE length #-}++-- | O(1) Check whether an element is in the set+--+-- @since 0.1.0.0+contains :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> Int -> m Bool+contains (MSS g) = G.contains g+{-# INLINE contains #-}++-- | O(n) The members of the set in an unspecified order.+--+-- @since 0.1.0.0+members :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m (VU.Vector Int)+members (MSS g) = G.members g+{-# INLINE members #-}++-- | O(1) Look up an element in the set+--+-- @since 0.1.0.0+lookup :: (PrimMonad m, VU.Unbox a) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a)+lookup (MSS g) = G.lookup g+{-# INLINE lookup #-}++-- | O(1) amortized. Insert a value for a given key.+--+-- If the key is already in the set, its value is overwritten.+--+-- __INVARIANT__: Keys cannot be negative. An unchecked exception is+-- thrown if a negative key is added to the set.+--+-- @since 0.1.0.0+insert :: (PrimMonad m, VU.Unbox a) => MutableSparseSet (PrimState m) a -> Int -> a -> m ()+insert (MSS g) = G.insert g+{-# INLINE insert #-}++-- | O(1) Delete an element from the set+--+-- @since 0.1.0.0+delete :: (PrimMonad m, VU.Unbox a) => MutableSparseSet (PrimState m) a -> Int -> m (Maybe a)+delete (MSS g) = G.delete g+{-# INLINE delete #-}++-- | O(1) Clear all elements from the set+--+-- @since 0.1.0.0+clear :: (PrimMonad m) => MutableSparseSet (PrimState m) a -> m ()+clear (MSS g) = G.clear g+{-# INLINE clear #-}++-- | O(n) Shrink the capacity of the set to fit exactly the current number of elements.+--+-- @since 0.1.0.0+compact :: (PrimMonad m, VU.Unbox a) => MutableSparseSet (PrimState m) a -> m ()+compact (MSS g) = G.compact g+{-# INLINE compact #-}++-- | O(n) Fold over the values of the set.+--+-- @since 0.1.0.0+foldM+  :: (PrimMonad m, VU.Unbox a)+  => (b -> a -> m b)+  -> b+  -> MutableSparseSet (PrimState m) a+  -> m b+foldM f initAcc (MSS g) = G.foldM f initAcc g+{-# INLINE foldM #-}++-- | O(n) Fold over the keys and values of the set.+--+-- @since 0.1.0.0+ifoldM+  :: (PrimMonad m, VU.Unbox a)+  => (b -> (Int, a) -> m b)+  -> b+  -> MutableSparseSet (PrimState m) a+  -> m b+ifoldM f initAcc (MSS g) = G.ifoldM f initAcc g+{-# INLINE ifoldM #-}++-- | O(n) Iterate over the values of the set.+--+-- @since 0.1.0.0+mapM_+  :: (PrimMonad m, VU.Unbox a)+  => (a -> m ()) -- Action to perform+  -> MutableSparseSet (PrimState m) a+  -> m ()+mapM_ f (MSS g) = G.mapM_ f g+{-# INLINE mapM_ #-}++-- | O(n) Iterate over the keys and values of the set.+--+-- @since 0.1.0.0+imapM_+  :: (PrimMonad m, VU.Unbox a)+  => ((Int, a) -> m ()) -- Action to perform+  -> MutableSparseSet (PrimState m) a+  -> m ()+imapM_ f (MSS g) = G.imapM_ f g+{-# INLINE imapM_ #-}++-- | O(min(n, m)) Iterate over the intersection of two sets with an accumulator.+--+-- The order of the arguments does not matter - the smaller of the two sets is+-- selected as the iteratee.+--+-- @since 0.1.0.0+ifoldIntersectionM+  :: (PrimMonad m, VU.Unbox a, VU.Unbox b)+  => (c -> Int -> a -> b -> m c)+  -> c+  -> MutableSparseSet (PrimState m) a+  -> MutableSparseSet (PrimState m) b+  -> m c+ifoldIntersectionM acc c (MSS a) (MSS b) = G.ifoldIntersectionM acc c a b+{-# INLINE ifoldIntersectionM #-}

+ test/Data/SparseSet/Generic/Internal/GrowVecSpec.hs view

@@ -0,0 +1,173 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++module Data.SparseSet.Generic.Internal.GrowVecSpec where++import Control.Monad (foldM, forM)+import Data.Vector.Unboxed.Mutable qualified as VM+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty.HUnit++import Data.SparseSet.Generic.Mutable.Internal.GrowVec qualified as GV++type TestComponent = Int++unit_withCapacity_is_empty :: Assertion+unit_withCapacity_is_empty = do+  vec <- GV.withCapacity @TestComponent @VM.MVector 128+  GV.length vec @?= 0++unit_withCapacity_valid_capacity :: Assertion+unit_withCapacity_valid_capacity = do+  vec <- GV.withCapacity @TestComponent @VM.MVector 0+  vec' <- GV.withCapacity @TestComponent @VM.MVector 1+  assertBool "capacity must be greater than 2" (GV.capacity vec >= 2 && GV.capacity vec' >= 2)++-- HUnit Tests for specific scenarios+unit_new_is_empty :: Assertion+unit_new_is_empty = do+  vec <- GV.new @TestComponent @VM.MVector+  GV.length vec @?= 0++unit_snoc_increases_length :: Assertion+unit_snoc_increases_length = do+  vec <- GV.new @TestComponent @VM.MVector+  vec' <- GV.snoc vec 100+  GV.length vec' @?= 1++unit_read_after_snoc :: Assertion+unit_read_after_snoc = do+  vec <- GV.new @TestComponent @VM.MVector+  vec' <- GV.snoc vec 100+  mVal <- GV.readMaybe vec' 0+  mVal @?= Just 100++unit_swapRemove_middle :: Assertion+unit_swapRemove_middle = do+  vec <- GV.new @TestComponent @VM.MVector+  vec1 <- GV.snoc vec 10+  vec2 <- GV.snoc vec1 20+  vec3 <- GV.snoc vec2 30 -- vec = [10, 20, 30]+  (removed, vec4) <- GV.unsafeSwapRemove vec3 1 -- remove 20+  -- now vec should be [10, 30]+  val0 <- GV.unsafeRead vec4 0+  val1 <- GV.unsafeRead vec4 1+  mVal2 <- GV.readMaybe vec4 2+  removed @?= 20+  GV.length vec4 @?= 2+  val0 @?= 10+  val1 @?= 30+  mVal2 @?= Nothing++unit_compact_preserves_elements :: Assertion+unit_compact_preserves_elements = do+  vec1 <- GV.withCapacity @TestComponent @VM.MVector 100+  vec2 <- GV.snoc vec1 10+  vec3 <- GV.snoc vec2 20+  vec4 <- GV.compact vec3+  GV.length vec4 @?= 2+  val0 <- GV.unsafeRead vec4 0+  val1 <- GV.unsafeRead vec4 1+  val0 @?= 10+  val1 @?= 20++unit_maximum_empty :: Assertion+unit_maximum_empty = do+  vec <- GV.new @TestComponent @VM.MVector+  mMax <- GV.maximum vec+  mMax @?= Nothing++unit_maximum_single :: Assertion+unit_maximum_single = do+  vec <- GV.new @TestComponent @VM.MVector+  vec' <- GV.snoc vec 42+  mMax <- GV.maximum vec'+  mMax @?= Just 42++unit_maximum_multiple :: Assertion+unit_maximum_multiple = do+  vec <- GV.new @TestComponent @VM.MVector+  vec1 <- GV.snoc vec (-10)+  vec2 <- GV.snoc vec1 30+  vec3 <- GV.snoc vec2 5+  mMax <- GV.maximum vec3+  mMax @?= Just 30++unit_clear :: Assertion+unit_clear = do+  vec <- GV.new @TestComponent @VM.MVector+  vec1 <- GV.snoc vec 10+  vec2 <- GV.snoc vec1 20+  let vec3 = GV.cleared vec2+  GV.length vec2 @?= 2 -- Original is unchanged+  GV.length vec3 @?= 0 -- New is empty++-- Hedgehog property-based tests+data GrowVecOp+  = OpSnoc TestComponent+  | OpWrite Int TestComponent+  | OpSwapRemove Int+  | OpClear+  deriving (Show, Eq)++genOp :: Int -> Gen GrowVecOp+genOp currentLen =+  Gen.frequency $+    [ (10, OpSnoc <$> Gen.int (Range.linear 0 1000))+    ]+      <> [ (5, OpWrite <$> Gen.int (Range.linear 0 (currentLen - 1)) <*> Gen.int (Range.linear 0 1000))+         | currentLen > 0+         ]+      <> [ (3, OpSwapRemove <$> Gen.int (Range.linear 0 (currentLen - 1))) | currentLen > 0+         ]+      <> [(1, pure OpClear) | currentLen > 0]++genOps :: Gen [GrowVecOp]+genOps = do+  size <- Gen.int (Range.linear 0 100)+  go size []+ where+  go :: Int -> [GrowVecOp] -> Gen [GrowVecOp]+  go n acc | n <= 0 = pure (reverse acc)+  go n acc = do+    let currentModel = applyOpsToModel (reverse acc) []+    op <- genOp (length currentModel)+    go (n - 1) (op : acc)++-- Pure list model of the GrowVec operations+applyOpToModel :: GrowVecOp -> [TestComponent] -> [TestComponent]+applyOpToModel (OpSnoc c) xs = xs ++ [c]+applyOpToModel (OpWrite idx val) xs = take idx xs ++ [val] ++ drop (idx + 1) xs+applyOpToModel (OpSwapRemove idx) xs+  | idx == lastIdx = take idx xs+  | otherwise = take idx xs ++ [last xs] ++ drop (idx + 1) (take lastIdx xs)+ where+  lastIdx = length xs - 1+applyOpToModel OpClear _ = []++applyOpsToModel :: [GrowVecOp] -> [TestComponent] -> [TestComponent]+applyOpsToModel ops model = foldl (flip applyOpToModel) model ops++hprop_growvec_model :: Property+hprop_growvec_model = property $ do+  ops <- forAll genOps+  let finalModel = applyOpsToModel ops []+  vec <- GV.new @TestComponent @VM.MVector+  vec' <-+    foldM+      ( \v op -> case op of+          OpSnoc c -> GV.snoc v c+          OpWrite idx val -> GV.unsafeWrite v idx val >> pure v+          OpSwapRemove idx -> snd <$> GV.unsafeSwapRemove v idx+          OpClear -> pure $ GV.cleared v+      )+      vec+      ops++  let len = GV.length vec'+  contents <- forM [0 .. len - 1] (GV.unsafeRead vec')++  len === length finalModel+  contents === finalModel

+ test/Data/SparseSet/Generic/Internal/MutableSparseArraySpec.hs view

@@ -0,0 +1,119 @@+module Data.SparseSet.Generic.Internal.MutableSparseArraySpec where++import Control.Monad (foldM)+import Data.List (nub)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty.HUnit++import Data.SparseSet.Generic.Mutable.Internal.MutableSparseArray qualified as MSA+import Data.Traversable++-- HUnit Tests for specific scenarios+unit_new_is_empty :: Assertion+unit_new_is_empty = do+  arr <- MSA.new+  mVal <- MSA.lookup arr 0+  c <- MSA.contains arr 0+  mVal @?= Nothing+  c @?= False++unit_insert_and_lookup :: Assertion+unit_insert_and_lookup = do+  arr <- MSA.new+  arr' <- MSA.unsafeInsert arr 10 100+  mVal <- MSA.lookup arr' 10+  mVal @?= Just 100++unit_insert_grows_and_fills :: Assertion+unit_insert_grows_and_fills = do+  arr <- MSA.new+  arr' <- MSA.unsafeInsert arr 10 100+  -- The array should have grown, but indices other than 10 should be empty+  mVal0 <- MSA.lookup arr' 0+  mVal5 <- MSA.lookup arr' 5+  mVal0 @?= Nothing+  mVal5 @?= Nothing++unit_delete_removes_entry :: Assertion+unit_delete_removes_entry = do+  arr <- MSA.new+  arr' <- MSA.unsafeInsert arr 10 100+  deleted <- MSA.delete arr' 10+  mVal <- MSA.lookup arr' 10+  deleted @?= Just 100+  mVal @?= Nothing++unit_clear :: Assertion+unit_clear = do+  arr <- MSA.new+  arr1 <- MSA.unsafeInsert arr 5 50+  arr2 <- MSA.unsafeInsert arr1 10 100+  MSA.clear arr2+  mVal5 <- MSA.lookup arr2 5+  mVal10 <- MSA.lookup arr2 10+  mVal5 @?= Nothing+  mVal10 @?= Nothing++-- Hedgehog property-based tests+data ArrayOp+  = OpInsert Int Int -- key, value+  | OpDelete Int -- key+  | OpClear+  deriving (Show, Eq)++genKey :: Gen Int+genKey = Gen.int (Range.linear 0 100)++genValue :: Gen Int+genValue = Gen.int (Range.linear 0 1000)++genOp :: Gen ArrayOp+genOp =+  Gen.frequency+    [ (10, OpInsert <$> genKey <*> genValue)+    , (5, OpDelete <$> genKey)+    , (1, pure OpClear)+    ]++genOps :: Gen [ArrayOp]+genOps = Gen.list (Range.linear 0 100) genOp++-- Model-based testing+applyOpToModel :: ArrayOp -> Map Int Int -> Map Int Int+applyOpToModel (OpInsert k v) = Map.insert k v+applyOpToModel (OpDelete k) = Map.delete k+applyOpToModel OpClear = const Map.empty++applyOpsToModel :: [ArrayOp] -> Map Int Int -> Map Int Int+applyOpsToModel ops model = foldl (flip applyOpToModel) model ops++getAllKeys :: [ArrayOp] -> [Int]+getAllKeys = nub . foldr opKeys []+ where+  opKeys (OpInsert k _) acc = k : acc+  opKeys (OpDelete k) acc = k : acc+  opKeys OpClear acc = acc++hprop_msa_model :: Property+hprop_msa_model = property $ do+  ops <- forAll genOps+  let allKeys = 0 : getAllKeys ops+  let finalModel = applyOpsToModel ops Map.empty+  arr <- MSA.new+  arr' <-+    foldM+      ( \a op -> case op of+          OpInsert k v -> MSA.unsafeInsert a k v+          OpDelete k -> MSA.delete a k >> pure a+          OpClear -> MSA.clear a >> pure a+      )+      arr+      ops+  sutFinalState <- for allKeys $ \k -> (k,) <$> MSA.lookup arr' k++  let modelFinalState = fmap (\k -> (k, Map.lookup k finalModel)) allKeys+  sutFinalState === modelFinalState

+ test/Data/SparseSet/Unboxed/MutableSpec.hs view

@@ -0,0 +1,528 @@+{-# LANGUAGE DerivingVia #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Data.SparseSet.Unboxed.MutableSpec where++import Control.Monad+import Control.Monad.Primitive+import Data.Foldable+import Data.IORef+import Data.List (sort)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (catMaybes, isJust)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Traversable+import Data.Typeable (Typeable)+import Data.Vector.Unboxed qualified as U+import Hedgehog+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import NoThunks.Class+import Test.Tasty.HUnit++import Data.SparseSet.Unboxed.Mutable (MutableSparseSet)+import Data.SparseSet.Unboxed.Mutable qualified as SS++-- Component type for most tests+type TestComponent = Int++-- Entity ID type+type TestEntity = Int++deriving via+  InspectHeap (MutableSparseSet s a)+  instance+    (Typeable a, Typeable s)+    => NoThunks (MutableSparseSet s a)++--------------------------------------------------------------------------------+-- HUnit+--------------------------------------------------------------------------------+assertNoThunks :: (NoThunks a) => String -> a -> IO ()+assertNoThunks lbl a = case unsafeNoThunks a of+  Just ti -> assertFailure $ "[" <> lbl <> "] Found unexpected thunks: " <> show ti+  Nothing -> pure ()+{-# INLINE assertNoThunks #-}++unit_new_empty_set :: Assertion+unit_new_empty_set = do+  set <- SS.new @TestComponent+  len <- SS.length set+  c0 <- SS.contains set 0+  g0 <- SS.lookup set 0+  len @?= 0+  c0 @?= False+  g0 @?= Nothing++unit_new_empty_set_no_thunks :: Assertion+unit_new_empty_set_no_thunks = do+  set <- SS.new @TestComponent+  assertNoThunks "empty set" set+  g0 <- SS.lookup set 0+  assertNoThunks "empty set - nonexisting" g0++unit_single_insert :: Assertion+unit_single_insert = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  len <- SS.length set+  c0 <- SS.contains set 0+  not_c1 <- SS.contains set 1+  g0 <- SS.lookup set 0+  len @?= 1+  c0 @?= True+  not_c1 @?= False+  g0 @?= Just 100++unit_single_insert_no_thunks :: Assertion+unit_single_insert_no_thunks = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  assertNoThunks "singleton set" set+  g0 <- SS.lookup set 0+  assertNoThunks "singleton set result" g0++unit_insert_update :: Assertion+unit_insert_update = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  SS.insert set 0 200+  len <- SS.length set+  g0 <- SS.lookup set 0+  len @?= 1+  g0 @?= Just 200++unit_insert_update_no_thunks :: Assertion+unit_insert_update_no_thunks = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  SS.insert set 0 200+  len <- SS.length set+  g0 <- SS.lookup set 0+  len @?= 1+  g0 @?= Just 200++unit_delete_existing :: Assertion+unit_delete_existing = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  SS.insert set 1 101+  deletedVal <- SS.delete set 0+  len <- SS.length set+  c0 <- SS.contains set 0+  g0 <- SS.lookup set 0+  c1 <- SS.contains set 1+  g1 <- SS.lookup set 1+  deletedVal @?= Just 100+  len @?= 1+  c0 @?= False+  g0 @?= Nothing+  c1 @?= True+  g1 @?= Just 101++unit_delete_non_existing :: Assertion+unit_delete_non_existing = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  deletedVal <- SS.delete set 1 -- Try to delete non-existing+  len <- SS.length set+  c0 <- SS.contains set 0+  g0 <- SS.lookup set 0+  deletedVal @?= Nothing+  len @?= 1+  c0 @?= True+  g0 @?= Just 100++unit_delete_last_element_no_swap :: Assertion+unit_delete_last_element_no_swap = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  SS.insert set 1 101+  deletedVal <- SS.delete set 1 -- Delete the last inserted (likely last in dense)+  len <- SS.length set+  g1 <- SS.lookup set 1+  g0 <- SS.lookup set 0+  deletedVal @?= Just 101+  len @?= 1+  g1 @?= Nothing+  g0 @?= Just 100++unit_delete_causes_swap :: Assertion+unit_delete_causes_swap = do+  set <- SS.new @TestComponent+  -- Order of insertion might matter for dense array layout if not careful,+  -- but sparse set logic should be independent of insertion order for correctness.+  -- Entities: 0, 10, 5. Values: 100, 110, 105+  -- Assume dense indices map somewhat to insertion:+  -- sparse: 0->DI0, 10->DI1, 5->DI2+  -- dense: [val_for_0, val_for_10, val_for_5]+  -- indices: [0, 10, 5]+  SS.insert set 0 100+  SS.insert set 10 110+  SS.insert set 5 105+  -- At this point, length is 3.+  -- Let's say internal dense layout is [100 (for 0), 110 (for 10), 105 (for 5)]+  -- Indices: [0, 10, 5]+  -- Sparse: 0->0, 10->1, 5->2++  -- Delete entity 0 (at dense index 0).+  -- Element for entity 5 (value 105) at dense_idx 2 should be swapped into dense_idx 0.+  deletedVal <- SS.delete set 0+  len <- SS.length set++  g0 <- SS.lookup set 0+  g10 <- SS.lookup set 10+  g5 <- SS.lookup set 5++  deletedVal @?= Just 100+  len @?= 2+  g0 @?= Nothing+  g10 @?= Just 110+  g5 @?= Just 105++unit_delete_swap_no_thunks :: Assertion+unit_delete_swap_no_thunks = do+  set <- SS.new @TestComponent+  assertNoThunks "empty" set+  SS.insert set 0 100+  assertNoThunks "1 elem" set+  SS.insert set 10 110+  assertNoThunks "2 elem" set+  SS.insert set 5 105+  assertNoThunks "3 elem" set+  deletedVal <- SS.delete set 0+  assertNoThunks "delete" set+  assertNoThunks "deleted value" deletedVal++  g0 <- SS.lookup set 0+  assertNoThunks "get 0" g0+  g10 <- SS.lookup set 10+  assertNoThunks "get 10" g10+  g5 <- SS.lookup set 5+  assertNoThunks "get 5" g5++unit_delete_then_insert :: Assertion+unit_delete_then_insert = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  SS.insert set 10 110+  SS.insert set 5 105+  deleted <- SS.delete set 0+  l0 <- SS.lookup set 0+  SS.insert set 0 200+  l1 <- SS.lookup set 0+  len <- SS.length set++  deleted @?= Just 100+  l0 @?= Nothing+  l1 @?= Just 200+  len @?= 3++unit_insert_large_index :: Assertion+unit_insert_large_index = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  SS.insert set 5000 500 -- Test sparse array growth+  len <- SS.length set+  g0 <- SS.lookup set 0+  g5000 <- SS.lookup set 5000+  c5000 <- SS.contains set 5000+  len @?= 2+  g0 @?= Just 100+  g5000 @?= Just 500+  c5000 @?= True++unit_clear :: Assertion+unit_clear = do+  set <- SS.new @TestComponent+  SS.insert set 0 100+  SS.insert set 500 32+  SS.insert set 31 (-5)+  SS.clear set+  SS.mapM_ (\_ -> assertFailure "Set must be empty") set++unit_ifoldM__empty :: Assertion+unit_ifoldM__empty = do+  set <- SS.new @TestComponent+  result <- SS.ifoldM (\acc (e, c) -> pure $ (e, c) : acc) [] set+  result @?= []++unit_mapM__sum :: Assertion+unit_mapM__sum = do+  set <- SS.new @TestComponent+  SS.insert set 10 1+  SS.insert set 20 2+  SS.insert set 30 3+  sumRef <- newIORef 0+  SS.mapM_ (\c -> modifyIORef' sumRef (+ c)) set+  finalSum <- readIORef sumRef+  finalSum @?= 6++-- This new test case verifies the ifoldIntersectionM function+-- using only the public API for Unboxed sparse sets.+unit_ifoldIntersectionM :: Assertion+unit_ifoldIntersectionM = do+  -- Setup:+  -- Set A: Unboxed Ints+  setA <- SS.new @Int+  SS.insert setA 10 100+  SS.insert setA 20 200+  SS.insert setA 30 300++  -- Set B: Unboxed Bools+  setB <- SS.new @Bool+  SS.insert setB 20 True+  SS.insert setB 30 False+  SS.insert setB 40 True++  -- Set C: An empty set+  setCEmpty <- SS.new @Int++  -- The folding function collects the results into a list.+  -- Its type signature matches the arguments from setA and setB.+  let fIntBool acc e ca cb = pure $ (e, ca, cb) : acc++  -- Test 1: Intersection of A (Ints) and B (Bools)+  result1 <- SS.ifoldIntersectionM fIntBool [] setA setB+  -- The result list is built in reverse order, so we sort for a stable comparison.+  sort result1 @?= [(20, 200, True), (30, 300, False)]++  -- Test 2: Intersection of B (Bools) and A (Ints)+  -- For this, the folding function's components must be in the opposite order.+  let fBoolInt acc e cb ca = pure $ (e, ca, cb) : acc+  result2 <- SS.ifoldIntersectionM fBoolInt [] setB setA+  -- The final tuple structure is the same, so the result should be identical.+  sort result2 @?= [(20, 200, True), (30, 300, False)]++  -- Test 3: Intersection with an empty set+  resultEmpty <- SS.ifoldIntersectionM fIntBool [] setA setCEmpty+  resultEmpty @?= []++--------------------------------------------------------------------------------+-- Hedgehog Property-Based Tests+--------------------------------------------------------------------------------++-- Generators+genEntityId :: Gen TestEntity+genEntityId = Gen.int (Range.linear 0 200) -- Range can be adjusted for different test profiles++genSmallEntityId :: Gen TestEntity+genSmallEntityId = Gen.int (Range.linear 0 10)++genComponent :: Gen TestComponent+genComponent = Gen.int (Range.linear (-1000) 1000)++-- Operations for stateful model testing+data SparseSetOp+  = OpInsert TestEntity TestComponent+  | OpDelete TestEntity+  deriving (Show, Eq)++genSparseSetOp :: Gen SparseSetOp+genSparseSetOp =+  Gen.frequency+    [ (7, OpInsert <$> genEntityId <*> genComponent) -- More inserts initially+    , (3, OpDelete <$> genEntityId)+    ]++genSparseSetOpSmallEntities :: Gen SparseSetOp+genSparseSetOpSmallEntities =+  Gen.frequency+    [ (7, OpInsert <$> genSmallEntityId <*> genComponent)+    , (3, OpDelete <$> genSmallEntityId)+    ]++-- Apply a list of operations to a pure model+applyOpsToModel :: [SparseSetOp] -> Map TestEntity TestComponent -> Map TestEntity TestComponent+applyOpsToModel ops model = foldl applyOpToModel model ops+ where+  applyOpToModel m (OpInsert e c) = Map.insert e c m+  applyOpToModel m (OpDelete e) = Map.delete e m++-- Apply a list of operations to the MutableSparseSet+applyOpsToSet+  :: (Foldable t, PrimMonad m) => MutableSparseSet (PrimState m) TestComponent -> t SparseSetOp -> m ()+applyOpsToSet set ops = for_ ops \case+  OpInsert e c -> SS.insert set e c+  OpDelete e -> void $ SS.delete set e -- Ignore deleted value for this helper++extractOpEntities :: SparseSetOp -> [TestEntity]+extractOpEntities = \case+  OpInsert e _ -> [e]+  OpDelete e -> [e]++-- Extract all current (entity, component) pairs and length from the set+extractFullStateFromSet+  :: (PrimMonad m, U.Unbox a) => MutableSparseSet (PrimState m) a -> Set Int -> m (Int, Map Int a)+extractFullStateFromSet set allKnownEntities = do+  len <- SS.length set+  mapEntries <-+    fmap+      (Map.fromList . catMaybes)+      ( for (toList allKnownEntities) \e -> do+          mVal <- SS.lookup set e+          pure $ (e,) <$> mVal+      )+  pure (len, mapEntries)++extractFullStateFromSetViaIterator+  :: (PrimMonad m, U.Unbox a) => MutableSparseSet (PrimState m) a -> m (Int, Map Int a)+extractFullStateFromSetViaIterator set = do+  len <- SS.length set+  entries <- SS.ifoldM (\acc (e, c) -> pure $ Map.insert e c acc) Map.empty set+  pure (len, entries)++hprop_sequential_operations :: Property+hprop_sequential_operations = property do+  -- Generate a sequence of operations+  ops <- forAll $ Gen.list (Range.linear 0 100) genSparseSetOp++  -- Determine all entities ever mentioned to check them later+  let allMentionedEntities = Set.fromList $ concatMap extractOpEntities ops+      finalModel = applyOpsToModel ops Map.empty++  do+    set <- SS.new @TestComponent+    applyOpsToSet set ops+    (setLength, setMap) <- extractFullStateFromSet set allMentionedEntities+    setLength === Map.size finalModel+    setMap === finalModel++  do+    set <- SS.new @TestComponent+    applyOpsToSet set ops+    for_ (Set.toList allMentionedEntities) $ \e -> do+      sutContains <- SS.contains set e+      let modelContains = Map.member e finalModel+      sutContains === modelContains++hprop_clear_removes_all :: Property+hprop_clear_removes_all = property $ do+  ops <- forAll $ Gen.list (Range.linear 1 100) genSparseSetOp+  let allMentionedEntities = Set.fromList $ concatMap extractOpEntities ops++  set <- SS.new @TestComponent+  applyOpsToSet set ops+  SS.clear set+  finalLen <- SS.length set+  found <- or <$> traverse (fmap isJust . SS.lookup set) (toList allMentionedEntities)+  finalLen === 0+  found === False++hprop_compact_preserves_content :: Property+hprop_compact_preserves_content = property $ do+  ops <- forAll $ Gen.list (Range.linear 0 100) genSparseSetOp++  set <- SS.new @TestComponent+  applyOpsToSet set ops++  let model = applyOpsToModel ops Map.empty+  (lenBefore, stateBefore) <- extractFullStateFromSetViaIterator set+  SS.compact set+  (lenAfter, stateAfter) <- extractFullStateFromSetViaIterator set++  stateBefore === model+  lenBefore === lenAfter+  stateBefore === stateAfter++hprop_insert_then_get :: Property+hprop_insert_then_get = property do+  entity <- forAll genEntityId+  component <- forAll genComponent+  set <- SS.new @TestComponent+  SS.insert set entity component+  l <- SS.length set+  v <- SS.lookup set entity+  c <- SS.contains set entity+  l === 1+  v === Just component+  c === True++hprop_insert_update_then_get :: Property+hprop_insert_update_then_get = property do+  entity <- forAll genEntityId+  component1 <- forAll genComponent+  component2 <- forAll genComponent+  set <- SS.new @TestComponent+  SS.insert set entity component1+  SS.insert set entity component2 -- Update+  l <- SS.length set+  v <- SS.lookup set entity+  l === 1+  v === Just component2++hprop_insert_delete_then_get :: Property+hprop_insert_delete_then_get = property do+  entity <- forAll genEntityId+  component <- forAll genComponent+  set <- SS.new @TestComponent+  SS.insert set entity component+  rv <- SS.delete set entity+  l <- SS.length set+  v <- SS.lookup set entity+  c <- SS.contains set entity+  rv === Just component+  l === 0+  v === Nothing+  c === False++hprop_delete_non_existent :: Property+hprop_delete_non_existent = property do+  entity <- forAll genEntityId+  set <- SS.new @TestComponent+  rv <- SS.delete set entity+  l <- SS.length set+  rv === Nothing+  l === 0++hprop_double_delete :: Property+hprop_double_delete = property do+  entity <- forAll genEntityId+  component <- forAll genComponent+  set <- SS.new @TestComponent+  SS.insert set entity component+  r1 <- SS.delete set entity+  r2 <- SS.delete set entity -- Delete again+  l <- SS.length set+  v <- SS.lookup set entity+  r1 === Just component+  r2 === Nothing+  l === 0+  v === Nothing++-- This property specifically stresses the swap logic by creating a denser set.+hprop_dense_delete_integrity :: Property+hprop_dense_delete_integrity = property do+  ops <- forAll $ Gen.list (Range.linear 5 30) genSparseSetOpSmallEntities++  let allMentionedEntities = Set.fromList $ concatMap extractOpEntities ops+      finalModel = applyOpsToModel ops Map.empty++  set <- SS.new @TestComponent+  applyOpsToSet set ops+  (setLength, setMap) <- extractFullStateFromSet set allMentionedEntities++  setLength === Map.size finalModel+  setMap === finalModel++hprop_ifoldIntersectionM_model :: Property+hprop_ifoldIntersectionM_model = property do+  opsA <- forAll $ Gen.list (Range.linear 0 100) genSparseSetOp+  opsB <- forAll $ Gen.list (Range.linear 0 100) genSparseSetOp++  setA <- SS.new @TestComponent+  applyOpsToSet setA opsA+  let modelA = applyOpsToModel opsA Map.empty++  setB <- SS.new @TestComponent+  applyOpsToSet setB opsB+  let modelB = applyOpsToModel opsB Map.empty++  let collectEntities acc entity _ _ = pure (entity : acc)+  sutIntersectedEntities <- SS.ifoldIntersectionM collectEntities [] setA setB++  let modelIntersectedEntities = Set.intersection (Map.keysSet modelA) (Map.keysSet modelB)++  Set.fromList sutIntersectedEntities === modelIntersectedEntities

+ test/Driver.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-}