Improve range extraction and singleton unions, and add performance benchmarks

CHANGELOG.md

@@ -12,6 +12,10 @@ Bugfixes:
 
 Other improvements:
 
+- Add focused Minibench workloads with correctness validation for construction, joins, ranges, and subsequent access (#79).
+- Trim `Map.submap` and `Set.range` at their boundaries instead of rebuilding retained entries (#79).
+- Use insertion-specific balancing and singleton-union insertion paths without changing general tree joins (#79).
+
 ## [v3.3.0](https://github.com/purescript/purescript-ordered-collections/releases/tag/v3.3.0) - 2026-10-17
 
 New features:

bench/spago.yaml

@@ -7,6 +7,7 @@ package:
     - console: ">=6.0.0 <7.0.0"
     - control: ">=6.0.0 <7.0.0"
     - effect: ">=4.0.0 <5.0.0"
+    - exceptions: ">=6.0.0 <7.0.0"
     - foldable-traversable: ">=6.0.0 <7.0.0"
     - lists: ">=7.0.0 <8.0.0"
     - maybe: ">=6.0.0 <7.0.0"

bench/src/Bench/Join.js

@@ -0,0 +1,10 @@
+let lastResult;
+
+export const retainResult = (operation) => (unit) => {
+  lastResult = operation(unit);
+  return lastResult;
+};
+
+export const clearResult = () => {
+  lastResult = undefined;
+};

bench/src/Bench/Join.purs

@@ -0,0 +1,155 @@
+-- | Run these benchmarks from the repository's root directory:
+-- |
+-- | ```sh
+-- | npm install
+-- | npm run bench:join
+-- | ```
+-- |
+-- | This builds the code and measures Map and Set operations on collections with
+-- | 1,000 and 100,000 entries. Each case checks its answers and tree balance during
+-- | five practice runs, then times 20 runs. Incorrect results stop the benchmark.
+-- | Setup and checks are not timed; building a collection is timed when that is
+-- | the operation being measured. Results stay in memory until the next run, and
+-- | any memory cleanup during a timed run counts toward its time.
+-- |
+-- | `mean` is the average time; lower is faster. `stddev`, `min`, and `max` show
+-- | how much the times vary. A small difference may just be measurement noise.
+-- | To compare two versions, run each at least three times, alternating versions.
+-- | Use the same computer, Node/compiler/dependency versions, and benchmark code.
+-- | Close other busy programs and do not run the two versions at the same time.
+-- | Save the full output, commit IDs, `node --version`, and `npx purs --version`.
+-- |
+-- | These integer-key examples do not represent every application. Ordinary
+-- | insertion and singleton unions are different workloads; compare the cases
+-- | your code actually uses. Very short operations need timed batches to measure
+-- | small differences reliably. Do not make CI fail on timing thresholds.
+-- | `npm run bench` runs the separate comparison with the historical implementation.
+module Bench.Join (main) where
+
+import Prelude
+
+import Data.Foldable (foldl, for_, sum)
+import Data.List as L
+import Data.Map as M
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Set as S
+import Data.Tuple (Tuple(..))
+import Effect (Effect)
+import Effect.Console (log)
+import Effect.Exception (throw)
+import Performance.Minibench (benchWith)
+
+-- Keep the last result reachable so the runtime cannot discard the work.
+foreign import retainResult :: forall a. (Unit -> a) -> Unit -> a
+foreign import clearResult :: Effect Unit
+
+benchmark :: forall a. String -> (a -> Boolean) -> (Unit -> a) -> Effect Unit
+benchmark name valid operation = do
+  log name
+  let run = retainResult operation
+  -- Validate and warm up outside the timed samples. Minibench then requests GC.
+  for_ (L.range 1 5) \_ ->
+    unless (valid (run unit)) $ throw ("Invalid benchmark result: " <> name)
+  clearResult
+  benchWith 20 run
+  clearResult
+
+main :: Effect Unit
+main = for_ [ 1000, 100000 ] \n -> do
+  log $ "\nJoin workloads, entries = " <> show n
+  let
+    keys = L.range 0 (n - 1)
+    reverseKeys = L.reverse keys
+    permutedKeys = map (\k -> (k * 7919) `mod` n) keys
+    duplicateKeys = map (_ `mod` 128) keys
+    pairs = map (\k -> Tuple k k) keys
+    permutedPairs = map (\k -> Tuple k k) permutedKeys
+    reversePairs = L.reverse pairs
+    duplicatePairs = map (\k -> Tuple k k) duplicateKeys
+    arrayPairs = L.toUnfoldable permutedPairs :: Array (Tuple Int Int)
+    fromKeys = M.fromFoldable <<< map (\k -> Tuple k k)
+    byUnions = foldl (\m k -> M.union m (M.singleton k k)) M.empty
+    byLeftUnions = foldl (\m k -> M.union (M.singleton k k) m) M.empty
+    valid expected m = M.checkValid m && (M.toUnfoldable m :: L.List (Tuple Int Int)) == expected
+    mapBench name expected = benchmark name (valid expected)
+    balanced = fromKeys keys
+    ascending = byUnions keys
+    descending = byUnions reverseKeys
+    half = n / 2
+    overlap = fromKeys (L.range half (n + half - 1))
+    disjoint = fromKeys (L.range n (2 * n - 1))
+    sparseKeys = map (_ * 97) (L.range 0 ((n - 1) / 97))
+    sparse = fromKeys sparseKeys
+    queries = map (\i -> (i * 7919) `mod` n) (L.range 0 4095)
+    expectedLookup = sum queries
+    lookups m = foldl (\acc k -> acc + fromMaybe (-1) (M.lookup k m)) 0 queries
+    fullRange = M.submap (Just 0) (Just (n - 1)) balanced
+    extraKeys = L.range n (n + 127)
+    deletedKeys = L.range 0 127
+
+  mapBench "fromFoldable" pairs \_ -> M.fromFoldable pairs
+  mapBench "fromFoldable / permuted" pairs \_ -> M.fromFoldable permutedPairs
+  mapBench "fromFoldable / descending" pairs \_ -> M.fromFoldable reversePairs
+  mapBench "fromFoldable / duplicate-heavy" (L.take 128 pairs) \_ -> M.fromFoldable duplicatePairs
+  mapBench "fromFoldable / permuted array" pairs \_ -> M.fromFoldable arrayPairs
+  benchmark "Set.fromFoldable / permuted"
+    (\s -> S.checkValid s && (S.toUnfoldable s :: L.List Int) == keys)
+    \_ -> S.fromFoldable permutedKeys
+  benchmark "Set.fromFoldable / duplicate-heavy"
+    (\s -> S.checkValid s && (S.toUnfoldable s :: L.List Int) == L.take 128 keys)
+    \_ -> S.fromFoldable duplicateKeys
+  mapBench "insert / replace existing" (map (\k -> Tuple k (-k)) keys) \_ ->
+    foldl (\m k -> M.insert k (-k) m) balanced permutedKeys
+  mapBench "insertWith / replace existing" (map (\k -> Tuple k (-1)) keys) \_ ->
+    foldl (\m k -> M.insertWith (-) k (k + 1) m) balanced permutedKeys
+  mapBench "delete then reinsert" pairs \_ ->
+    foldl (\m k -> M.insert k k (M.delete k m)) balanced permutedKeys
+  mapBench "singleton unions / ascending" pairs \_ -> byUnions keys
+  mapBench "singleton unions / descending" pairs \_ -> byUnions reverseKeys
+  mapBench "singleton unions / permuted" pairs \_ -> byUnions permutedKeys
+  mapBench "singleton unions / duplicate-heavy" (L.take 128 pairs) \_ -> byUnions duplicateKeys
+  mapBench "singleton-left unions / ascending" pairs \_ -> byLeftUnions keys
+  mapBench "singleton-left unions / descending" pairs \_ -> byLeftUnions reverseKeys
+  mapBench "singleton-left unions / permuted" pairs \_ -> byLeftUnions permutedKeys
+  mapBench "submap / full" pairs \_ -> M.submap (Just 0) (Just (n - 1)) balanced
+  mapBench "submap / half" (L.take half pairs) \_ -> M.submap (Just 0) (Just (half - 1)) balanced
+  mapBench "submap / singleton" (L.singleton (Tuple half half)) \_ -> M.submap (Just half) (Just half) balanced
+  mapBench "submap / interior" (L.take half (L.drop (half / 2) pairs)) \_ ->
+    M.submap (Just (half / 2)) (Just (half / 2 + half - 1)) balanced
+  mapBench "submap / lower only" (L.drop half pairs) \_ -> M.submap (Just half) Nothing balanced
+  mapBench "submap / upper only" (L.take half pairs) \_ -> M.submap Nothing (Just (half - 1)) balanced
+  mapBench "submap / reversed bounds" L.Nil \_ -> M.submap (Just half) (Just (half - 1)) balanced
+  mapBench "submap / outside" L.Nil \_ -> M.submap (Just n) Nothing balanced
+
+  mapBench "union / identical" pairs \_ -> M.union balanced balanced
+  mapBench "union / empty left" pairs \_ -> M.union M.empty balanced
+  mapBench "union / empty right" pairs \_ -> M.union balanced M.empty
+  mapBench "difference / identical" L.Nil \_ -> M.difference balanced balanced
+
+  for_ [ Tuple "left" identity, Tuple "right" flip ] \(Tuple side order) -> do
+    mapBench ("union / overlap / " <> side) (map (\k -> Tuple k k) (L.range 0 (n + half - 1))) \_ ->
+      order M.union balanced overlap
+    mapBench ("union / disjoint / " <> side) (pairs <> map (\k -> Tuple k k) (L.range n (2 * n - 1))) \_ ->
+      order M.union balanced disjoint
+    mapBench ("union / sparse / " <> side) pairs \_ -> order M.union balanced sparse
+
+  mapBench "difference / disjoint / left" pairs \_ -> M.difference balanced disjoint
+  mapBench "difference / disjoint / right" (map (\k -> Tuple k k) (L.range n (2 * n - 1))) \_ -> M.difference disjoint balanced
+  mapBench "difference / sparse / large-small" (L.filter (\(Tuple k _) -> k `mod` 97 /= 0) pairs) \_ -> M.difference balanced sparse
+  mapBench "difference / sparse / small-large" L.Nil \_ -> M.difference sparse balanced
+  mapBench "intersection / overlap" (L.drop half pairs) \_ -> M.intersection balanced overlap
+
+  for_ [ Tuple "fromFoldable" balanced, Tuple "ascending unions" ascending, Tuple "descending unions" descending, Tuple "full submap" fullRange ] \(Tuple name tree) -> do
+    unless (valid pairs tree) $ throw ("Invalid lookup fixture: " <> name)
+    benchmark ("4096 lookups / " <> name) (_ == expectedLookup) \_ -> lookups tree
+    mapBench ("128 deletes / " <> name) (L.drop 128 pairs) \_ ->
+      foldl (flip M.delete) tree deletedKeys
+    mapBench ("128 inserts / " <> name) (pairs <> map (\k -> Tuple k k) extraKeys) \_ ->
+      foldl (\m k -> M.insert k k m) tree extraKeys
+
+  for_ [ Tuple "ascending" keys, Tuple "descending" reverseKeys ] \(Tuple name input) ->
+    benchmark ("singleton unions + 4096 lookups / " <> name)
+      (\(Tuple tree total) -> valid pairs tree && total == expectedLookup)
+      \_ -> do
+        let tree = byUnions input
+        Tuple tree (lookups tree)

package.json

@@ -6,6 +6,7 @@
     "bench:build": "spago build -p ordered-collections-bench",
     "bench:run": "node --expose-gc --input-type=module --eval \"import * as Bench_Main from './output/Bench.Main/index.js';Bench_Main.main()\"",
     "bench": "npm run bench:build && npm run bench:run",
+    "bench:join": "npm run bench:build && node --expose-gc --input-type=module --eval \"import('./output/Bench.Join/index.js').then(m => m.main())\"",
     "format": "purs-tidy format-in-place src test bench/src && oxfmt --write .",
     "format:check": "purs-tidy check src test bench/src && oxfmt --check ."
   },

src/Data/Map/Internal.purs

@@ -71,7 +71,7 @@ import Control.Plus (class Plus)
 import Data.Eq (class Eq1)
 import Data.Foldable (class Foldable, foldl, foldr)
 import Data.FoldableWithIndex (class FoldableWithIndex, foldlWithIndex, foldrWithIndex)
-import Data.Function.Uncurried (Fn2, Fn3, Fn4, Fn7, mkFn2, mkFn3, mkFn4, mkFn7, runFn2, runFn3, runFn4, runFn7)
+import Data.Function.Uncurried (Fn2, Fn3, Fn4, Fn5, Fn7, mkFn2, mkFn3, mkFn4, mkFn5, mkFn7, runFn2, runFn3, runFn4, runFn5, runFn7)
 import Data.FunctorWithIndex (class FunctorWithIndex)
 import Data.List (List(..), (:))
 import Data.Maybe (Maybe(..))
@@ -452,7 +452,42 @@ foldSubmapBy appendFn memptyValue kmin kmax f = do
 -- |       not (member key m')
 -- | ```
 submap :: forall k v. Ord k => Maybe k -> Maybe k -> Map k v -> Map k v
-submap kmin kmax = foldSubmapBy union empty kmin kmax singleton
+submap kmin kmax m = case kmin, kmax of
+  Just lo, Just hi | lo > hi -> Leaf
+  _, _ -> go m
+  where
+  -- Trimming only removes entries, so unchanged size means nothing was removed.
+  go tree = case tree of
+    Leaf -> Leaf
+    Node _ _ k v l r -> case kmin, kmax of
+      Just lo, _ | k < lo -> go r
+      _, Just hi | k > hi -> go l
+      _, _ -> do
+        let
+          l' = trimLower kmin l
+          r' = trimUpper kmax r
+        if size l' == size l && size r' == size r then tree
+        else runFn4 unsafeBalancedNode k v l' r'
+
+  trimLower Nothing tree = tree
+  trimLower bound@(Just lo) tree = case tree of
+    Leaf -> Leaf
+    Node _ _ k v l r
+      | k < lo -> trimLower bound r
+      | otherwise -> do
+          let l' = trimLower bound l
+          if size l' == size l then tree
+          else runFn4 unsafeBalancedNode k v l' r
+
+  trimUpper Nothing tree = tree
+  trimUpper bound@(Just hi) tree = case tree of
+    Leaf -> Leaf
+    Node _ _ k v l r
+      | k > hi -> trimUpper bound l
+      | otherwise -> do
+          let r' = trimUpper bound r
+          if size r' == size r then tree
+          else runFn4 unsafeBalancedNode k v l r'
 
 -- | Test if a key is a member of a map
 member :: forall k v. Ord k => k -> Map k v -> Boolean
@@ -580,7 +615,12 @@ values = foldr Cons Nil
 -- | Compute the union of two maps, using the specified function
 -- | to combine values for duplicate keys.
 unionWith :: forall k v. Ord k => (v -> v -> v) -> Map k v -> Map k v -> Map k v
-unionWith app m1 m2 = runFn4 unsafeUnionWith compare app m1 m2
+unionWith app m1 m2 = case m1, m2 of
+  Leaf, _ -> m2
+  _, Leaf -> m1
+  _, Node _ _ _ _ Leaf Leaf -> runFn5 unsafeUnionSingleton compare app false m2 m1
+  Node _ _ _ _ Leaf Leaf, _ -> runFn5 unsafeUnionSingleton compare app true m1 m2
+  _, _ -> runFn4 unsafeUnionWith compare app m1 m2
 
 -- | Compute the union of two maps, preferring values from the first map in the case
 -- | of duplicate keys
@@ -716,6 +756,26 @@ unsafeNode = mkFn4 \k v l r -> case l of
       Node h2 s2 _ _ _ _ ->
         Node (1 + if h1 > h2 then h1 else h2) (1 + s1 + s2) k v l r
 
+-- | Rebalance after a single insertion. Both children must be balanced and
+-- | ordered, and their heights must differ by at most two.
+unsafeInsertNode :: forall k v. Fn4 k v (Map k v) (Map k v) (Map k v)
+unsafeInsertNode = mkFn4 \k v l r -> case l, r of
+  Node lh _ lk lv ll lr, _ | lh > height r + 1 ->
+    case lr of
+      Node rh _ rk rv rl rr | rh > height ll ->
+        runFn4 unsafeNode rk rv (runFn4 unsafeNode lk lv ll rl) (runFn4 unsafeNode k v rr r)
+      _ -> runFn4 unsafeNode lk lv ll (runFn4 unsafeNode k v lr r)
+  _, Node rh _ rk rv rl rr | rh > height l + 1 ->
+    case rl of
+      Node lh _ lk lv ll lr | lh > height rr ->
+        runFn4 unsafeNode lk lv (runFn4 unsafeNode k v l ll) (runFn4 unsafeNode rk rv lr rr)
+      _ -> runFn4 unsafeNode rk rv (runFn4 unsafeNode k v l rl) rr
+  _, _ -> runFn4 unsafeNode k v l r
+  where
+  height = case _ of
+    Leaf -> 0
+    Node h _ _ _ _ _ -> h
+
 -- | Low-level Node constructor which maintains the balance invariants.
 -- | This is unsafe because it assumes the child Maps are ordered and balanced.
 -- | Their heights may differ arbitrarily: join along the taller tree's inner
@@ -814,6 +874,35 @@ unsafeSplit = mkFn3 \comp k m -> case m of
       EQ ->
         Split (Just mv) ml mr
 
+-- | Insert a map containing at most one entry into another map.
+-- | This is unsafe because it assumes that size bound and appropriate ordering.
+-- | `singletonLeft` identifies the singleton's original union side. Collisions
+-- | keep the original right operand's key; `app` receives left then right values.
+unsafeUnionSingleton :: forall k v. Fn5 (k -> k -> Ordering) (v -> v -> v) Boolean (Map k v) (Map k v) (Map k v)
+unsafeUnionSingleton = mkFn5 \comp app singletonLeft single tree -> case single of
+  Leaf -> tree
+  Node _ _ k v _ _ -> do
+    let
+      -- Insertion grows a child by at most one. Below the old parent height,
+      -- the parent remains balanced with the same height.
+      go = case _ of
+        Leaf -> single
+        Node h s mk mv l r -> case comp k mk of
+          LT -> do
+            let l' = go l
+            case l' of
+              Node lh ls _ _ _ _ | lh < h -> Node h (1 + ls + size r) mk mv l' r
+              _ -> runFn4 unsafeInsertNode mk mv l' r
+          GT -> do
+            let r' = go r
+            case r' of
+              Node rh rs _ _ _ _ | rh < h -> Node h (1 + size l + rs) mk mv l r'
+              _ -> runFn4 unsafeInsertNode mk mv l r'
+          EQ ->
+            if singletonLeft then Node h s mk (app v mv) l r
+            else Node h s k (app mv v) l r
+    go tree
+
 -- | Low-level unionWith implementation.
 -- | This is unsafe because it assumes the ordering function is appropriate.
 unsafeUnionWith :: forall k v. Fn4 (k -> k -> Ordering) (v -> v -> v) (Map k v) (Map k v) (Map k v)

test/Test/Data/Map.purs

@@ -30,6 +30,14 @@ newtype TestMap k v = TestMap (M.Map k v)
 instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where
   arbitrary = TestMap <$> genMap arbitrary arbitrary
 
+newtype TaggedKey = TaggedKey { key :: Int, tag :: String }
+
+instance eqTaggedKey :: Eq TaggedKey where
+  eq (TaggedKey a) (TaggedKey b) = a.key == b.key
+
+instance ordTaggedKey :: Ord TaggedKey where
+  compare (TaggedKey a) (TaggedKey b) = compare a.key b.key
+
 data SmallKey = A | B | C | D | E | F | G | H | I | J
 
 derive instance eqSmallKey :: Eq SmallKey
@@ -236,6 +244,25 @@ mapTests = do
       Just v -> Just v == v2
       Nothing -> not (in1 || in2)
 
+  log "Singleton unions preserve balance, persistence, and combining argument order"
+  for_ [ A.range 0 127, A.reverse (A.range 0 127), map (\k -> (k * 37) `mod` 128) (A.range 0 127) ] \ks ->
+    for_ [ false, true ] \singletonLeft -> do
+      let
+        join = if singletonLeft then flip (M.unionWith (-)) else M.unionWith (-)
+        initial = foldl (\m k -> join m (M.singleton k (3 * k + 10))) M.empty ks
+        combined = foldl (\m k -> join m (M.singleton k (k + 1))) initial ks
+        expected = map (\k -> Tuple k (if singletonLeft then -2 * k - 9 else 2 * k + 9)) (A.range 0 127)
+      quickCheck' 1 (M.checkValid combined && M.toUnfoldable combined == expected)
+      quickCheck' 1 (M.checkValid initial && M.toUnfoldable initial == map (\k -> Tuple k (3 * k + 10)) (A.range 0 127))
+
+  log "Singleton unions keep the right-hand representative key"
+  let
+    tagged = M.fromFoldable (map (\k -> Tuple (TaggedKey { key: k, tag: "tree" }) (k * 3 + 10)) (A.range 0 2))
+    taggedOne = M.singleton (TaggedKey { key: 1, tag: "singleton" }) 9
+    tags m = map (\(Tuple (TaggedKey k) v) -> Tuple k.tag v) (M.toUnfoldable m :: Array (Tuple TaggedKey Int))
+  quickCheck' 1 (tags (M.unionWith (-) tagged taggedOne) == [ Tuple "tree" 10, Tuple "singleton" 4, Tuple "tree" 16 ])
+  quickCheck' 1 (tags (M.unionWith (-) taggedOne tagged) == [ Tuple "tree" 10, Tuple "tree" (-4), Tuple "tree" 16 ])
+
   log "Lookup from intersection"
   quickCheck $ \(TestMap m1) (TestMap m2) k ->
     M.lookup (smallKey k) (M.intersection (m1 :: M.Map SmallKey Int) (m2 :: M.Map SmallKey Int)) ==
@@ -370,12 +397,23 @@ mapTests = do
   quickCheck \(TestMap m :: TestMap SmallKey Int) ->
     M.submap Nothing Nothing m === m
 
-  log "submap preserves balance across unequal subtree heights"
+  log "submap preserves a six-entry map over its full range"
   let
     rangeInput = M.fromFoldable (map (\k -> Tuple k (k * 3)) (A.range 0 5))
     bounded = M.submap (Just 0) (Just 5) rangeInput
   quickCheck' 1 (M.checkValid bounded && bounded == rangeInput)
 
+  log "submap trims asymmetric boundaries and preserves all retained entries"
+  for_ [ A.range 0 63, A.reverse (A.range 0 63) ] \keys -> do
+    let input = M.fromFoldable (map (\k -> Tuple k (3 * k + 1)) keys)
+    for_ [ Nothing, Just (-1), Just 0, Just 1, Just 17, Just 48, Just 63, Just 64 ] \lo ->
+      for_ [ Nothing, Just (-1), Just 0, Just 16, Just 31, Just 62, Just 63, Just 64 ] \hi -> do
+        let
+          result = M.submap lo hi input
+          inRange k = maybe true (\min -> min <= k) lo && maybe true (\max -> k <= max) hi
+          expected = map (\k -> Tuple k (3 * k + 1)) (A.filter inRange (A.range 0 63))
+        quickCheck' 1 (M.checkValid result && M.toUnfoldable result == expected)
+
   log "submap with lower bound"
   quickCheck' 1 $
     M.submap (Just B) Nothing (M.fromFoldable [ Tuple A 0, Tuple B 0 ])