From ce198aed7fbcdf453f839e1ffa3a596da28f071c Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sun, 29 Dec 2019 17:11:13 -0600 Subject: [PATCH 001/147] Improve the Data.IntMap.mergeWithKey test to test more cases and have clearer output --- containers-tests/tests/intmap-properties.hs | 45 +++---------------- containers/src/Data/IntMap/Internal.hs | 6 +-- containers/src/Data/IntMap/Strict/Internal.hs | 12 +++-- 3 files changed, 17 insertions(+), 46 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 4a55bc0b9..e3d5f80d3 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -793,34 +793,9 @@ test_toDescList = do toDescList (fromList [(5,"a"), (-3,"b")]) @?= [(5,"a"), (-3,"b")] test_showTree :: Assertion -test_showTree = do - showTree posTree @?= expectedPosTree - showTree negTree @?= expectedNegTree - where mkAscTree ls = fromDistinctAscList [(x,()) | x <- ls] - posTree = mkAscTree [1..5] - negTree = mkAscTree [(-2)..2] - expectedPosTree = unlines - [ "*" - , "+--*" - , "| +-- 1:=()" - , "| +--*" - , "| +-- 2:=()" - , "| +-- 3:=()" - , "+--*" - , " +-- 4:=()" - , " +-- 5:=()" - ] - expectedNegTree = unlines - [ "*" - , "+--*" - , "| +--*" - , "| | +-- 0:=()" - , "| | +-- 1:=()" - , "| +-- 2:=()" - , "+--*" - , " +-- -2:=()" - , " +-- -1:=()" - ] +test_showTree = + (let t = fromDistinctAscList [(x,()) | x <- [1..5]] + in showTree t) @?= "1 ()\n+--5 ()\n |\n +--3 ()\n | |\n | +-.\n | |\n | +--2 ()\n | |\n | +-.\n | |\n | +-.\n |\n +--4 ()\n |\n +-.\n |\n +-.\n" test_fromAscList :: Assertion test_fromAscList = do @@ -1259,17 +1234,9 @@ prop_withoutKeys m s0 = where s = keysSet s0 -prop_mergeWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool -prop_mergeWithKeyModel xs ys - = and [ testMergeWithKey f keep_x keep_y - | f <- [ \_k x1 _x2 -> Just x1 - , \_k _x1 x2 -> Just x2 - , \_k _x1 _x2 -> Nothing - , \k x1 x2 -> if k `mod` 2 == 0 then Nothing else Just (2 * x1 + 3 * x2) - ] - , keep_x <- [ True, False ] - , keep_y <- [ True, False ] - ] +prop_mergeWithKeyModel :: Fun (Int, Int, Int) (Maybe Int) -> Bool -> Bool -> [(Int,Int)] -> [(Int,Int)] -> Bool +prop_mergeWithKeyModel f keep_x keep_y xs ys + = testMergeWithKey (apply3 f) keep_x keep_y where xs' = List.nubBy ((==) `on` fst) xs ys' = List.nubBy ((==) `on` fst) ys diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index b8bc3ffb8..477aeaff8 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -3201,7 +3201,7 @@ fromMonoListWithKey distinct f = go -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` -- `addAll` consumes the rest of the list, adding to the tree `tx` - addAll !_kx !tx [] + addAll !kx !tx [] = tx addAll !kx !tx ((ky,vy) : zs) | m <- branchMask kx ky @@ -3209,7 +3209,7 @@ fromMonoListWithKey distinct f = go = addAll kx (linkWithMask m ky ty {-kx-} tx) zs' -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. - addMany' !_m !kx vx [] + addMany' !m !kx vx [] = Inserted (Tip kx vx) [] addMany' !m !kx vx zs0@((ky,vy) : zs) | Nondistinct <- distinct, kx == ky @@ -3222,7 +3222,7 @@ fromMonoListWithKey distinct f = go = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs' -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. - addMany !_m !_kx tx [] + addMany !m !kx tx [] = Inserted tx [] addMany !m !kx tx zs0@((ky,vy) : zs) | mask kx m /= mask ky m diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 2b695c0fe..938e9e770 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} #include "containers.h" @@ -258,8 +257,11 @@ import qualified Data.IntMap.Internal as L import Data.IntMap.Internal ( IntMap (..) , Key + , Prefix + , Mask , mask , branchMask + , shorter , nomatch , zero , natFromInt @@ -1146,6 +1148,8 @@ fromDistinctAscList :: [(Key,a)] -> IntMap a fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) {-# NOINLINE fromDistinctAscList #-} +data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada + -- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys -- and a combining function. -- @@ -1173,7 +1177,7 @@ fromMonoListWithKey distinct f = go -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` -- `addAll` consumes the rest of the list, adding to the tree `tx` - addAll !_kx !tx [] + addAll !kx !tx [] = tx addAll !kx !tx ((ky,vy) : zs) | m <- branchMask kx ky @@ -1181,7 +1185,7 @@ fromMonoListWithKey distinct f = go = addAll kx (linkWithMask m ky ty {-kx-} tx) zs' -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. - addMany' !_m !kx vx [] + addMany' !m !kx vx [] = Inserted (Tip kx $! vx) [] addMany' !m !kx vx zs0@((ky,vy) : zs) | Nondistinct <- distinct, kx == ky @@ -1194,7 +1198,7 @@ fromMonoListWithKey distinct f = go = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs' -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. - addMany !_m !_kx tx [] + addMany !m !kx tx [] = Inserted tx [] addMany !m !kx tx zs0@((ky,vy) : zs) | mask kx m /= mask ky m From 9856cbea761ad730e4ddc164b4297097221ad2d9 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 12 Sep 2016 21:53:12 -0500 Subject: [PATCH 002/147] Rewrite Data.IntMap to be faster and use less memory MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Memory usage: The old implementation had 6n-5 words of overhead (i.e. discounting storage of the keys and the pointers to values). The new implementation has only 3n-1 words of overhead. Large runtime regressions: - fromAscList and fromDistinctAscList are currently just aliases for fromList - I have no clue about foldlWithKey' - keysSet, fromSet, restrictKeys, and withoutKeys are currently implemented naively and are probably much slower Benchmarks after: Benchmark intmap-benchmarks: RUNNING... benchmarking lookup time 351.2 μs (348.0 μs .. 353.4 μs) 0.999 R² (0.999 R² .. 1.000 R²) mean 348.4 μs (345.8 μs .. 350.5 μs) std dev 7.589 μs (5.950 μs .. 8.951 μs) variance introduced by outliers: 14% (moderately inflated) benchmarking insert time 710.6 μs (708.1 μs .. 713.5 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 709.2 μs (707.8 μs .. 711.0 μs) std dev 5.133 μs (4.064 μs .. 6.746 μs) benchmarking insertWith empty time 784.2 μs (782.1 μs .. 786.3 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 783.8 μs (781.9 μs .. 786.2 μs) std dev 7.298 μs (5.164 μs .. 10.90 μs) benchmarking insertWith update time 1.815 ms (1.809 ms .. 1.823 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.815 ms (1.810 ms .. 1.819 ms) std dev 16.52 μs (12.94 μs .. 22.60 μs) benchmarking insertWith' empty time 794.3 μs (792.9 μs .. 795.7 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 794.5 μs (792.8 μs .. 796.1 μs) std dev 6.120 μs (4.768 μs .. 8.325 μs) benchmarking insertWith' update time 1.491 ms (1.486 ms .. 1.496 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.496 ms (1.491 ms .. 1.503 ms) std dev 18.86 μs (14.67 μs .. 24.30 μs) benchmarking insertWithKey empty time 790.0 μs (786.0 μs .. 793.7 μs) 1.000 R² (0.999 R² .. 1.000 R²) mean 794.1 μs (790.1 μs .. 807.6 μs) std dev 22.04 μs (5.555 μs .. 45.51 μs) variance introduced by outliers: 18% (moderately inflated) benchmarking insertWithKey update time 2.034 ms (2.029 ms .. 2.042 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 2.033 ms (2.028 ms .. 2.039 ms) std dev 17.85 μs (14.47 μs .. 22.44 μs) benchmarking insertWithKey' empty time 797.9 μs (796.6 μs .. 798.9 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 797.3 μs (795.8 μs .. 798.9 μs) std dev 5.257 μs (4.250 μs .. 6.617 μs) benchmarking insertWithKey' update time 1.504 ms (1.499 ms .. 1.510 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.504 ms (1.500 ms .. 1.511 ms) std dev 18.15 μs (12.36 μs .. 29.84 μs) benchmarking insertLookupWithKey empty time 917.9 μs (914.9 μs .. 920.7 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 915.4 μs (912.2 μs .. 918.1 μs) std dev 10.09 μs (8.160 μs .. 12.89 μs) benchmarking insertLookupWithKey update time 2.332 ms (2.326 ms .. 2.338 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 2.334 ms (2.329 ms .. 2.341 ms) std dev 20.29 μs (16.52 μs .. 24.81 μs) benchmarking map time 149.6 μs (149.1 μs .. 150.0 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 151.7 μs (151.0 μs .. 153.6 μs) std dev 3.726 μs (1.409 μs .. 7.458 μs) variance introduced by outliers: 19% (moderately inflated) benchmarking mapWithKey time 162.1 μs (161.9 μs .. 162.3 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 162.1 μs (162.0 μs .. 162.4 μs) std dev 623.3 ns (379.3 ns .. 1.039 μs) benchmarking foldlWithKey time 1.188 ms (1.184 ms .. 1.193 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.190 ms (1.187 ms .. 1.194 ms) std dev 10.63 μs (8.096 μs .. 14.74 μs) benchmarking foldlWithKey' time 93.76 μs (93.72 μs .. 93.88 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 93.80 μs (93.74 μs .. 93.98 μs) std dev 371.8 ns (30.91 ns .. 714.5 ns) benchmarking foldrWithKey time 22.71 ns (22.62 ns .. 22.80 ns) 0.998 R² (0.996 R² .. 1.000 R²) mean 22.65 ns (22.13 ns .. 23.43 ns) std dev 2.077 ns (1.152 ns .. 3.451 ns) variance introduced by outliers: 90% (severely inflated) benchmarking delete time 392.1 μs (384.0 μs .. 408.8 μs) 0.994 R² (0.985 R² .. 1.000 R²) mean 386.7 μs (384.2 μs .. 395.9 μs) std dev 14.89 μs (710.6 ns .. 31.54 μs) variance introduced by outliers: 32% (moderately inflated) benchmarking update time 1.277 ms (1.275 ms .. 1.280 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.277 ms (1.274 ms .. 1.279 ms) std dev 8.210 μs (6.086 μs .. 11.37 μs) benchmarking updateLookupWithKey time 2.538 ms (2.529 ms .. 2.547 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 2.534 ms (2.527 ms .. 2.540 ms) std dev 22.10 μs (18.13 μs .. 28.85 μs) benchmarking alter time 1.555 ms (1.550 ms .. 1.559 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.554 ms (1.550 ms .. 1.558 ms) std dev 13.60 μs (11.01 μs .. 16.65 μs) benchmarking mapMaybe time 184.7 μs (184.1 μs .. 185.3 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 185.1 μs (184.5 μs .. 185.9 μs) std dev 2.239 μs (1.418 μs .. 3.591 μs) benchmarking mapMaybeWithKey time 186.9 μs (184.6 μs .. 191.9 μs) 0.992 R² (0.977 R² .. 1.000 R²) mean 187.6 μs (185.1 μs .. 197.7 μs) std dev 14.17 μs (2.403 μs .. 31.55 μs) variance introduced by outliers: 69% (severely inflated) benchmarking fromList time 717.2 μs (713.4 μs .. 719.9 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 713.2 μs (710.5 μs .. 716.1 μs) std dev 9.082 μs (7.906 μs .. 10.82 μs) benchmarking fromAscList time 718.4 μs (713.7 μs .. 722.3 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 712.8 μs (710.4 μs .. 715.4 μs) std dev 8.612 μs (7.509 μs .. 10.04 μs) benchmarking fromDistinctAscList time 717.4 μs (713.4 μs .. 720.7 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 712.6 μs (710.7 μs .. 714.8 μs) std dev 6.553 μs (5.526 μs .. 7.963 μs) Benchmark intmap-benchmarks: FINISH Benchmarks before: Benchmark intmap-benchmarks: RUNNING... benchmarking lookup time 462.8 μs (457.1 μs .. 466.8 μs) 0.999 R² (0.998 R² .. 1.000 R²) mean 461.9 μs (457.6 μs .. 464.5 μs) std dev 10.83 μs (7.533 μs .. 14.53 μs) variance introduced by outliers: 15% (moderately inflated) benchmarking insert time 908.2 μs (906.9 μs .. 909.8 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 908.7 μs (907.0 μs .. 910.9 μs) std dev 6.776 μs (5.050 μs .. 9.429 μs) benchmarking insertWith empty time 904.2 μs (903.1 μs .. 905.6 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 903.8 μs (902.0 μs .. 905.8 μs) std dev 5.991 μs (4.748 μs .. 7.628 μs) benchmarking insertWith update time 1.962 ms (1.957 ms .. 1.968 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.965 ms (1.959 ms .. 1.971 ms) std dev 18.44 μs (13.84 μs .. 24.77 μs) benchmarking insertWith' empty time 918.0 μs (916.0 μs .. 920.9 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 918.9 μs (915.3 μs .. 923.0 μs) std dev 13.87 μs (10.57 μs .. 18.18 μs) benchmarking insertWith' update time 1.682 ms (1.672 ms .. 1.706 ms) 0.998 R² (0.995 R² .. 1.000 R²) mean 1.686 ms (1.678 ms .. 1.709 ms) std dev 44.73 μs (18.01 μs .. 85.74 μs) variance introduced by outliers: 14% (moderately inflated) benchmarking insertWithKey empty time 906.4 μs (905.0 μs .. 907.8 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 905.8 μs (904.3 μs .. 907.2 μs) std dev 5.118 μs (4.080 μs .. 6.452 μs) benchmarking insertWithKey update time 2.039 ms (2.019 ms .. 2.054 ms) 1.000 R² (0.999 R² .. 1.000 R²) mean 2.021 ms (2.014 ms .. 2.029 ms) std dev 25.52 μs (20.98 μs .. 31.95 μs) benchmarking insertWithKey' empty time 912.6 μs (910.4 μs .. 916.3 μs) 1.000 R² (0.999 R² .. 1.000 R²) mean 925.0 μs (919.7 μs .. 930.8 μs) std dev 18.31 μs (15.26 μs .. 21.70 μs) benchmarking insertWithKey' update time 1.690 ms (1.687 ms .. 1.695 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.693 ms (1.689 ms .. 1.699 ms) std dev 17.40 μs (13.96 μs .. 23.11 μs) benchmarking insertLookupWithKey empty time 1.772 ms (1.766 ms .. 1.778 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.771 ms (1.768 ms .. 1.774 ms) std dev 10.39 μs (9.049 μs .. 12.27 μs) benchmarking insertLookupWithKey update time 4.051 ms (4.019 ms .. 4.092 ms) 1.000 R² (0.999 R² .. 1.000 R²) mean 4.031 ms (4.018 ms .. 4.048 ms) std dev 50.84 μs (38.55 μs .. 67.42 μs) benchmarking map time 172.7 μs (171.4 μs .. 173.7 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 171.3 μs (171.0 μs .. 171.9 μs) std dev 1.377 μs (870.7 ns .. 1.961 μs) benchmarking mapWithKey time 227.8 μs (226.9 μs .. 228.8 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 227.1 μs (226.6 μs .. 227.7 μs) std dev 1.799 μs (1.315 μs .. 2.385 μs) benchmarking foldlWithKey time 1.554 ms (1.513 ms .. 1.618 ms) 0.995 R² (0.991 R² .. 1.000 R²) mean 1.546 ms (1.538 ms .. 1.566 ms) std dev 40.51 μs (21.11 μs .. 81.14 μs) variance introduced by outliers: 14% (moderately inflated) benchmarking foldlWithKey' time 46.11 μs (45.90 μs .. 46.25 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 45.64 μs (45.52 μs .. 45.78 μs) std dev 421.3 ns (342.6 ns .. 499.9 ns) benchmarking foldrWithKey time 105.9 ns (105.7 ns .. 106.3 ns) 1.000 R² (1.000 R² .. 1.000 R²) mean 105.9 ns (105.7 ns .. 106.0 ns) std dev 461.7 ps (320.4 ps .. 689.5 ps) benchmarking delete time 357.5 μs (356.7 μs .. 359.0 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 357.6 μs (357.3 μs .. 358.5 μs) std dev 1.734 μs (1.000 μs .. 3.244 μs) benchmarking update time 1.542 ms (1.539 ms .. 1.548 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.541 ms (1.538 ms .. 1.544 ms) std dev 10.09 μs (7.858 μs .. 13.96 μs) benchmarking updateLookupWithKey time 2.444 ms (2.439 ms .. 2.448 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 2.457 ms (2.451 ms .. 2.467 ms) std dev 24.38 μs (17.83 μs .. 32.20 μs) benchmarking alter time 1.536 ms (1.532 ms .. 1.540 ms) 1.000 R² (1.000 R² .. 1.000 R²) mean 1.538 ms (1.535 ms .. 1.541 ms) std dev 10.88 μs (8.249 μs .. 16.94 μs) benchmarking mapMaybe time 223.8 μs (223.6 μs .. 224.0 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 224.4 μs (223.5 μs .. 226.4 μs) std dev 4.150 μs (616.6 ns .. 7.538 μs) variance introduced by outliers: 11% (moderately inflated) benchmarking mapMaybeWithKey time 223.3 μs (223.0 μs .. 223.6 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 223.3 μs (223.1 μs .. 223.6 μs) std dev 749.0 ns (456.5 ns .. 1.329 μs) benchmarking fromList time 848.4 μs (847.1 μs .. 849.4 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 847.0 μs (845.7 μs .. 848.5 μs) std dev 4.540 μs (3.715 μs .. 6.255 μs) benchmarking fromAscList time 604.2 μs (602.4 μs .. 605.6 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 602.6 μs (601.4 μs .. 604.0 μs) std dev 4.334 μs (3.383 μs .. 5.573 μs) benchmarking fromDistinctAscList time 226.4 μs (225.7 μs .. 227.7 μs) 1.000 R² (1.000 R² .. 1.000 R²) mean 226.0 μs (225.7 μs .. 226.4 μs) std dev 988.2 ns (534.4 ns .. 1.965 μs) Benchmark intmap-benchmarks: FINISH --- containers/src/Data/IntMap.hs | 67 +- containers/src/Data/IntMap/Internal.hs | 4770 ++++++----------- containers/src/Data/IntMap/Lazy.hs | 1385 ++++- containers/src/Data/IntMap/Merge/Internal.hs | 595 ++ containers/src/Data/IntMap/Merge/Lazy.hs | 169 +- containers/src/Data/IntMap/Merge/Strict.hs | 263 +- containers/src/Data/IntMap/Strict/Internal.hs | 1773 +++--- 7 files changed, 4759 insertions(+), 4263 deletions(-) create mode 100644 containers/src/Data/IntMap/Merge/Internal.hs diff --git a/containers/src/Data/IntMap.hs b/containers/src/Data/IntMap.hs index 75855ded2..15df20d3e 100644 --- a/containers/src/Data/IntMap.hs +++ b/containers/src/Data/IntMap.hs @@ -16,6 +16,7 @@ -- Module : Data.IntMap -- Copyright : (c) Daan Leijen 2002 -- (c) Andriy Palamarchuk 2008 +-- (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable @@ -36,20 +37,6 @@ -- > import Data.IntMap (IntMap) -- > import qualified Data.IntMap as IntMap -- --- The implementation is based on /big-endian patricia trees/. This data --- structure performs especially well on binary operations like 'union' --- and 'intersection'. However, my benchmarks show that it is also --- (much) faster on insertions and deletions when compared to a generic --- size-balanced map implementation (see "Data.Map"). --- --- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", --- Workshop on ML, September 1998, pages 77-86, --- --- --- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve --- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), --- October 1968, pages 514-534. --- -- Operation comments contain the operation time complexity in -- the Big-O notation . -- Many operations have a worst-case complexity of /O(min(n,W))/. @@ -70,32 +57,36 @@ module Data.IntMap #endif ) where +import Prelude hiding (foldr) +import qualified Data.IntMap.Strict as Strict import Data.IntMap.Lazy -#ifdef __GLASGOW_HASKELL__ -import Utils.Containers.Internal.TypeError - --- | This function is being removed and is no longer usable. --- Use 'Data.IntMap.Strict.insertWith' -insertWith' :: Whoops "Data.IntMap.insertWith' is gone. Use Data.IntMap.Strict.insertWith." - => (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith' _ _ _ _ = undefined +-- | /O(log n)/. Same as 'insertWith', but the result of the combining function +-- is evaluated to WHNF before inserted to the map. +{-# DEPRECATED insertWith' "As of version 0.5, replaced by 'Data.IntMap.Strict.insertWith'." #-} +{-# INLINE insertWith' #-} +insertWith' :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWith' = Strict.insertWith --- | This function is being removed and is no longer usable. --- Use 'Data.IntMap.Strict.insertWithKey'. -insertWithKey' :: Whoops "Data.IntMap.insertWithKey' is gone. Use Data.IntMap.Strict.insertWithKey." - => (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWithKey' _ _ _ _ = undefined +-- | /O(log n)/. Same as 'insertWithKey', but the result of the combining +-- function is evaluated to WHNF before inserted to the map. +{-# DEPRECATED insertWithKey' "As of version 0.5, replaced by 'Data.IntMap.Strict.insertWithKey'." #-} +{-# INLINE insertWithKey' #-} +insertWithKey' :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithKey' = Strict.insertWithKey --- | This function is being removed and is no longer usable. --- Use 'Data.IntMap.Lazy.foldr'. -fold :: Whoops "Data.IntMap.fold' is gone. Use Data.IntMap.foldr or Prelude.foldr." - => (a -> b -> b) -> b -> IntMap a -> b -fold _ _ _ = undefined +-- | /O(n)/. Fold the values in the map using the given +-- right-associative binary operator. This function is an equivalent +-- of 'foldr' and is present for compatibility only. +{-# DEPRECATED fold "As of version 0.5, replaced by 'foldr'." #-} +{-# INLINE fold #-} +fold :: (a -> b -> b) -> b -> IntMap a -> b +fold = foldr --- | This function is being removed and is no longer usable. --- Use 'foldrWithKey'. -foldWithKey :: Whoops "Data.IntMap.foldWithKey is gone. Use foldrWithKey." - => (Key -> a -> b -> b) -> b -> IntMap a -> b -foldWithKey _ _ _ = undefined -#endif +-- | /O(n)/. Fold the keys and values in the map using the given +-- right-associative binary operator. This function is an equivalent +-- of 'foldrWithKey' and is present for compatibility only. +{-# DEPRECATED foldWithKey "As of version 0.5, replaced by 'foldrWithKey'." #-} +{-# INLINE foldWithKey #-} +foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldWithKey = foldrWithKey diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 477aeaff8..7a409e6ed 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,27 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -#endif -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE TypeFamilies #-} -#endif - -{-# OPTIONS_HADDOCK not-home #-} - -#include "containers.h" +{-# LANGUAGE BangPatterns, EmptyDataDecls #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Internal -- Copyright : (c) Daan Leijen 2002 -- (c) Andriy Palamarchuk 2008 --- (c) wren romano 2016 +-- (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable @@ -46,14 +30,6 @@ -- @since 0.5.9 ----------------------------------------------------------------------------- --- [Note: INLINE bit fiddling] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- It is essential that the bit fiddling functions like mask, zero, branchMask --- etc are inlined. If they do not, the memory allocation skyrockets. The GHC --- usually gets it right, but it is disastrous if it does not. Therefore we --- explicitly mark these functions INLINE. - - -- [Note: Local 'go' functions and capturing] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Care must be taken when using 'go' function which captures an argument. @@ -62,496 +38,114 @@ -- must be checked for increased allocation when creating and modifying such -- functions. +module Data.IntMap.Internal where + +import Control.DeepSeq (NFData(..)) +import Control.Applicative (Applicative(..)) --- [Note: Order of constructors] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The order of constructors of IntMap matters when considering performance. --- Currently in GHC 7.0, when type has 3 constructors, they are matched from --- the first to the last -- the best performance is achieved when the --- constructors are ordered by frequency. --- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil --- improves the benchmark by circa 10%. - -module Data.IntMap.Internal ( - -- * Map type - IntMap(..), Key -- instance Eq,Show - - -- * Operators - , (!), (!?), (\\) - - -- * Query - , null - , size - , member - , notMember - , lookup - , findWithDefault - , lookupLT - , lookupGT - , lookupLE - , lookupGE - , disjoint - - -- * Construction - , empty - , singleton - - -- ** Insertion - , insert - , insertWith - , insertWithKey - , insertLookupWithKey - - -- ** Delete\/Update - , delete - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - , alterF - - -- * Combine - - -- ** Union - , union - , unionWith - , unionWithKey - , unions - , unionsWith - - -- ** Difference - , difference - , differenceWith - , differenceWithKey - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithKey - - -- ** General combining function - , SimpleWhenMissing - , SimpleWhenMatched - , runWhenMatched - , runWhenMissing - , merge - -- *** @WhenMatched@ tactics - , zipWithMaybeMatched - , zipWithMatched - -- *** @WhenMissing@ tactics - , mapMaybeMissing - , dropMissing - , preserveMissing - , mapMissing - , filterMissing - - -- ** Applicative general combining function - , WhenMissing (..) - , WhenMatched (..) - , mergeA - -- *** @WhenMatched@ tactics - -- | The tactics described for 'merge' work for - -- 'mergeA' as well. Furthermore, the following - -- are available. - , zipWithMaybeAMatched - , zipWithAMatched - -- *** @WhenMissing@ tactics - -- | The tactics described for 'merge' work for - -- 'mergeA' as well. Furthermore, the following - -- are available. - , traverseMaybeMissing - , traverseMissing - , filterAMissing - - -- ** Deprecated general combining function - , mergeWithKey - , mergeWithKey' - - -- * Traversal - -- ** Map - , map - , mapWithKey - , traverseWithKey - , traverseMaybeWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeys - , mapKeysWith - , mapKeysMonotonic - - -- * Folds - , foldr - , foldl - , foldrWithKey - , foldlWithKey - , foldMapWithKey - - -- ** Strict folds - , foldr' - , foldl' - , foldrWithKey' - , foldlWithKey' - - -- * Conversion - , elems - , keys - , assocs - , keysSet - , fromSet - - -- ** Lists - , toList - , fromList - , fromListWith - , fromListWithKey - - -- ** Ordered lists - , toAscList - , toDescList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - - -- * Filter - , filter - , filterWithKey - , restrictKeys - , withoutKeys - , partition - , partitionWithKey - - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - - , split - , splitLookup - , splitRoot - - -- * Submap - , isSubmapOf, isSubmapOfBy - , isProperSubmapOf, isProperSubmapOfBy - - -- * Min\/Max - , lookupMin - , lookupMax - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax - , updateMin - , updateMax - , updateMinWithKey - , updateMaxWithKey - , minView - , maxView - , minViewWithKey - , maxViewWithKey - - -- * Debugging - , showTree - , showTreeWith - - -- * Internal types - , Mask, Prefix, Nat - - -- * Utility - , natFromInt - , intFromNat - , link - , linkWithMask - , bin - , binCheckLeft - , binCheckRight - , zero - , nomatch - , match - , mask - , maskW - , shorter - , branchMask - , highestBitMask - - -- * Used by "IntMap.Merge.Lazy" and "IntMap.Merge.Strict" - , mapWhenMissing - , mapWhenMatched - , lmapWhenMissing - , contramapFirstWhenMatched - , contramapSecondWhenMatched - , mapGentlyWhenMissing - , mapGentlyWhenMatched - ) where - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity (..)) -import Control.Applicative (liftA2) -#else -import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2) import Data.Monoid (Monoid(..)) -import Data.Traversable (Traversable(traverse)) +import qualified Data.Foldable (Foldable(..)) +import Data.Traversable (Traversable(..)) + +import Data.Functor ((<$>)) + import Data.Word (Word) -#endif -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup(stimes)) -#endif -#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (stimesIdempotentMonoid) -import Data.Functor.Classes -#endif - -import Control.DeepSeq (NFData(rnf)) -import Data.Bits -import qualified Data.Foldable as Foldable -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable()) -#endif -import Data.Maybe (fromMaybe) -import Data.Typeable -import Prelude hiding (lookup, map, filter, foldr, foldl, null) - -import Data.IntSet.Internal (Key) -import qualified Data.IntSet.Internal as IntSet -import Utils.Containers.Internal.BitUtil -import Utils.Containers.Internal.StrictPair - -#if __GLASGOW_HASKELL__ -import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), - DataType, mkDataType) -import GHC.Exts (build) -#if !MIN_VERSION_base(4,8,0) -import Data.Functor ((<$)) -#endif -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as GHCExts -#endif -import Text.Read -#endif -import qualified Control.Category as Category -#if __GLASGOW_HASKELL__ >= 709 -import Data.Coerce -#endif - - --- A "Nat" is a natural machine word (an unsigned Int) -type Nat = Word - -natFromInt :: Key -> Nat -natFromInt = fromIntegral -{-# INLINE natFromInt #-} - -intFromNat :: Nat -> Key -intFromNat = fromIntegral -{-# INLINE intFromNat #-} - -{-------------------------------------------------------------------- - Types ---------------------------------------------------------------------} - - --- | A map of integers to values @a@. - --- See Note: Order of constructors -data IntMap a = Bin {-# UNPACK #-} !Prefix - {-# UNPACK #-} !Mask - !(IntMap a) - !(IntMap a) --- Fields: --- prefix: The most significant bits shared by all keys in this Bin. --- mask: The switching bit to determine if a key should follow the left --- or right subtree of a 'Bin'. --- Invariant: Nil is never found as a child of Bin. --- Invariant: The Mask is a power of 2. It is the largest bit position at which --- two keys of the map differ. --- Invariant: Prefix is the common high-order bits that all elements share to --- the left of the Mask bit. --- Invariant: In (Bin prefix mask left right), left consists of the elements that --- don't have the mask bit set; right is all the elements that do. - | Tip {-# UNPACK #-} !Key a - | Nil - -type Prefix = Int -type Mask = Int - - --- Some stuff from "Data.IntSet.Internal", for 'restrictKeys' and --- 'withoutKeys' to use. -type IntSetPrefix = Int -type IntSetBitMap = Word - -bitmapOf :: Int -> IntSetBitMap -bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask) -{-# INLINE bitmapOf #-} - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} +import qualified Data.Bits (xor) --- | /O(min(n,W))/. Find the value at a key. --- Calls 'error' when the element can not be found. --- --- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map --- > fromList [(5,'a'), (3,'b')] ! 5 == 'a' +import qualified Data.IntSet (IntSet, fromDistinctAscList, member, notMember) -(!) :: IntMap a -> Key -> a -(!) m k = find k m +import Prelude hiding (foldr, foldl, lookup, null, map, min, max) --- | /O(min(n,W))/. Find the value at a key. --- Returns 'Nothing' when the element can not be found. --- --- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing --- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a' --- --- @since 0.5.11 +type Key = Int -(!?) :: IntMap a -> Key -> Maybe a -(!?) m k = lookup k m +i2w :: Int -> Word +i2w = fromIntegral --- | Same as 'difference'. -(\\) :: IntMap a -> IntMap b -> IntMap a -m1 \\ m2 = difference m1 m2 +-- We need to compare xors using unsigned comparisons +xor :: Key -> Key -> Word +xor a b = Data.Bits.xor (i2w a) (i2w b) -infixl 9 !?,\\{-This comment teaches CPP correct behaviour -} +data L +data R -{-------------------------------------------------------------------- - Types ---------------------------------------------------------------------} +newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) +data IntMap_ t a = NonEmpty {-# UNPACK #-} !Key a !(Node t a) | Empty deriving (Eq) +data Node t a = Bin {-# UNPACK #-} !Key a !(Node L a) !(Node R a) | Tip deriving (Eq, Show) -instance Monoid (IntMap a) where - mempty = empty - mconcat = unions -#if !(MIN_VERSION_base(4,9,0)) - mappend = union -#else - mappend = (<>) - --- | @since 0.5.7 -instance Semigroup (IntMap a) where - (<>) = union - stimes = stimesIdempotentMonoid -#endif - --- | Folds in order of increasing key. -instance Foldable.Foldable IntMap where - fold = go - where go Nil = mempty - go (Tip _ v) = v - go (Bin _ m l r) - | m < 0 = go r `mappend` go l - | otherwise = go l `mappend` go r - {-# INLINABLE fold #-} - foldr = foldr - {-# INLINE foldr #-} - foldl = foldl - {-# INLINE foldl #-} - foldMap f t = go t - where go Nil = mempty - go (Tip _ v) = f v - go (Bin _ m l r) - | m < 0 = go r `mappend` go l - | otherwise = go l `mappend` go r - {-# INLINE foldMap #-} - foldl' = foldl' - {-# INLINE foldl' #-} - foldr' = foldr' - {-# INLINE foldr' #-} -#if MIN_VERSION_base(4,8,0) - length = size - {-# INLINE length #-} - null = null - {-# INLINE null #-} - toList = elems -- NB: Foldable.toList /= IntMap.toList - {-# INLINE toList #-} - elem = go - where go !_ Nil = False - go x (Tip _ y) = x == y - go x (Bin _ _ l r) = go x l || go x r - {-# INLINABLE elem #-} - maximum = start - where start Nil = error "Data.Foldable.maximum (for Data.IntMap): empty map" - start (Tip _ y) = y - start (Bin _ m l r) - | m < 0 = go (start r) l - | otherwise = go (start l) r - - go !m Nil = m - go m (Tip _ y) = max m y - go m (Bin _ _ l r) = go (go m l) r - {-# INLINABLE maximum #-} - minimum = start - where start Nil = error "Data.Foldable.minimum (for Data.IntMap): empty map" - start (Tip _ y) = y - start (Bin _ m l r) - | m < 0 = go (start r) l - | otherwise = go (start l) r - - go !m Nil = m - go m (Tip _ y) = min m y - go m (Bin _ _ l r) = go (go m l) r - {-# INLINABLE minimum #-} - sum = foldl' (+) 0 - {-# INLINABLE sum #-} - product = foldl' (*) 1 - {-# INLINABLE product #-} -#endif - --- | Traverses in order of increasing key. -instance Traversable IntMap where - traverse f = traverseWithKey (\_ -> f) - {-# INLINE traverse #-} +instance Show a => Show (IntMap a) where + show m = "fromList " ++ show (toList m) -instance NFData a => NFData (IntMap a) where - rnf Nil = () - rnf (Tip _ v) = rnf v - rnf (Bin _ _ l r) = rnf l `seq` rnf r +instance Functor IntMap where + fmap f (IntMap m) = IntMap (fmap f m) + +instance Functor (IntMap_ t) where + fmap _ Empty = Empty + fmap f (NonEmpty min minV node) = NonEmpty min (f minV) (fmap f node) + +instance Functor (Node t) where + fmap _ Tip = Tip + fmap f (Bin k v l r) = Bin k (f v) (fmap f l) (fmap f r) + +instance Data.Foldable.Foldable IntMap where + foldMap f = start + where + start (IntMap Empty) = mempty + start (IntMap (NonEmpty _ minV root)) = f minV `mappend` goL root + + goL Tip = mempty + goL (Bin _ maxV l r) = goL l `mappend` goR r `mappend` f maxV + + goR Tip = mempty + goR (Bin _ minV l r) = f minV `mappend` goL l `mappend` goR r + + foldr = foldr + foldr' = foldr' + foldl = foldl + foldl' = foldl' + +instance Traversable IntMap where + traverse f = start + where + start (IntMap Empty) = pure (IntMap Empty) + start (IntMap (NonEmpty min minV node)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f minV <*> goL node -#if __GLASGOW_HASKELL__ + goL Tip = pure Tip + goL (Bin max maxV l r) = (\l' r' v' -> Bin max v' l' r') <$> goL l <*> goR r <*> f maxV -{-------------------------------------------------------------------- - A Data instance ---------------------------------------------------------------------} + goR Tip = pure Tip + goR (Bin min minV l r) = Bin min <$> f minV <*> goL l <*> goR r --- This instance preserves data abstraction at the cost of inefficiency. --- We provide limited reflection services for the sake of data abstraction. +instance Monoid (IntMap a) where + mempty = empty + mappend = union -instance Data a => Data (IntMap a) where - gfoldl f z im = z fromList `f` (toList im) - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> error "gunfold" - dataTypeOf _ = intMapDataType - dataCast1 f = gcast1 f +instance NFData a => NFData (IntMap a) where + rnf (IntMap Empty) = () + rnf (IntMap (NonEmpty _ v n)) = rnf v `seq` rnf n -fromListConstr :: Constr -fromListConstr = mkConstr intMapDataType "fromList" [] Prefix +instance NFData a => NFData (Node t a) where + rnf Tip = () + rnf (Bin _ v l r) = rnf v `seq` rnf l `seq` rnf r -intMapDataType :: DataType -intMapDataType = mkDataType "Data.IntMap.Internal.IntMap" [fromListConstr] +-- | /O(min(n,W))/. Find the value at a key. +-- Calls 'error' when the element can not be found. +-- +-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map +-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a' +(!) :: IntMap a -> Key -> a +(!) m k = findWithDefault (error $ "IntMap.!: key " ++ show k ++ " is not an element of the map") k m -#endif +-- | Same as 'difference'. +(\\) :: IntMap a -> IntMap b -> IntMap a +(\\) = difference -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} -- | /O(1)/. Is the map empty? -- --- > Data.IntMap.null (empty) == True +-- > Data.IntMap.null empty == True -- > Data.IntMap.null (singleton 1 'a') == False - null :: IntMap a -> Bool -null Nil = True -null _ = False -{-# INLINE null #-} +null (IntMap Empty) = True +null _ = False -- | /O(n)/. Number of elements in the map. -- @@ -559,121 +153,166 @@ null _ = False -- > size (singleton 1 'a') == 1 -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 size :: IntMap a -> Int -size = go 0 - where - go !acc (Bin _ _ l r) = go (go acc l) r - go acc (Tip _ _) = 1 + acc - go acc Nil = acc +size (IntMap Empty) = 0 +size (IntMap (NonEmpty _ _ node)) = sizeNode node where + sizeNode :: Node t a -> Int + sizeNode Tip = 1 + sizeNode (Bin _ _ l r) = sizeNode l + sizeNode r -- | /O(min(n,W))/. Is the key a member of the map? -- -- > member 5 (fromList [(5,'a'), (3,'b')]) == True -- > member 1 (fromList [(5,'a'), (3,'b')]) == False - --- See Note: Local 'go' functions and capturing] member :: Key -> IntMap a -> Bool -member !k = go +member k = k `seq` start where - go (Bin p m l r) | nomatch k p m = False - | zero k m = go l - | otherwise = go r - go (Tip kx _) = k == kx - go Nil = False + start (IntMap Empty) = False + start (IntMap (NonEmpty min _ node)) + | k < min = False + | k == min = True + | otherwise = goL (xor min k) node + + goL !_ Tip = False + goL !xorCache (Bin max _ l r) + | k < max = if xorCache < xorCacheMax + then goL xorCache l + else goR xorCacheMax r + | k > max = False + | otherwise = True + where xorCacheMax = xor k max + + goR !_ Tip = False + goR !xorCache (Bin min _ l r) + | k > min = if xorCache < xorCacheMin + then goR xorCache r + else goL xorCacheMin l + | k < min = False + | otherwise = True + where xorCacheMin = xor min k -- | /O(min(n,W))/. Is the key not a member of the map? -- -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True - notMember :: Key -> IntMap a -> Bool -notMember k m = not $ member k m +notMember k = k `seq` start + where + start (IntMap Empty) = True + start (IntMap (NonEmpty min _ node)) + | k < min = True + | k == min = False + | otherwise = goL (xor min k) node + + goL !_ Tip = True + goL !xorCache (Bin max _ l r) + | k < max = if xorCache < xorCacheMax + then goL xorCache l + else goR xorCacheMax r + | k > max = True + | otherwise = False + where xorCacheMax = xor k max + + goR !_ Tip = True + goR !xorCache (Bin min _ l r) + | k > min = if xorCache < xorCacheMin + then goR xorCache r + else goL xorCacheMin l + | k < min = True + | otherwise = False + where xorCacheMin = xor min k -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'. - --- See Note: Local 'go' functions and capturing] lookup :: Key -> IntMap a -> Maybe a -lookup !k = go - where - go (Bin p m l r) | nomatch k p m = Nothing - | zero k m = go l - | otherwise = go r - go (Tip kx x) | k == kx = Just x - | otherwise = Nothing - go Nil = Nothing - - --- See Note: Local 'go' functions and capturing] -find :: Key -> IntMap a -> a -find !k = go +lookup k = k `seq` start where - go (Bin p m l r) | nomatch k p m = not_found - | zero k m = go l - | otherwise = go r - go (Tip kx x) | k == kx = x - | otherwise = not_found - go Nil = not_found - - not_found = error ("IntMap.!: key " ++ show k ++ " is not an element of the map") - --- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@ + start (IntMap Empty) = Nothing + start (IntMap (NonEmpty min minV node)) + | k < min = Nothing + | k == min = Just minV + | otherwise = goL (xor min k) node + + goL !_ Tip = Nothing + goL !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goL xorCache l + else goR xorCacheMax r + | k > max = Nothing + | otherwise = Just maxV + where xorCacheMax = xor k max + + goR !_ Tip = Nothing + goR !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goR xorCache r + else goL xorCacheMin l + | k < min = Nothing + | otherwise = Just minV + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. The expression @'findWithDefault' def k map@ -- returns the value at key @k@ or returns @def@ when the key is not an -- element of the map. -- -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' - --- See Note: Local 'go' functions and capturing] findWithDefault :: a -> Key -> IntMap a -> a -findWithDefault def !k = go +findWithDefault def k = k `seq` start where - go (Bin p m l r) | nomatch k p m = def - | zero k m = go l - | otherwise = go r - go (Tip kx x) | k == kx = x - | otherwise = def - go Nil = def + start (IntMap Empty) = def + start (IntMap (NonEmpty min minV node)) + | k < min = def + | k == min = minV + | otherwise = goL (xor min k) node + + goL !_ Tip = def + goL !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goL xorCache l + else goR xorCacheMax r + | k > max = def + | otherwise = maxV + where xorCacheMax = xor k max + + goR !_ Tip = def + goR !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goR xorCache r + else goL xorCacheMin l + | k < min = def + | otherwise = minV + where xorCacheMin = xor min k -- | /O(log n)/. Find largest key smaller than the given one and return the -- corresponding (key, value) pair. -- -- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing -- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') - --- See Note: Local 'go' functions and capturing. lookupLT :: Key -> IntMap a -> Maybe (Key, a) -lookupLT !k t = case t of - Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r - _ -> go Nil t +lookupLT k = k `seq` start where - go def (Bin p m l r) - | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r - | zero k m = go def l - | otherwise = go l r - go def (Tip ky y) - | k <= ky = unsafeFindMax def - | otherwise = Just (ky, y) - go def Nil = unsafeFindMax def + start (IntMap Empty) = Nothing + start (IntMap (NonEmpty min minV node)) + | min >= k = Nothing + | otherwise = Just (goL (xor min k) min minV node) + + goL !_ min minV Tip = (min, minV) + goL !xorCache min minV (Bin max maxV l r) + | max < k = (max, maxV) + | xorCache < xorCacheMax = goL xorCache min minV l + | otherwise = goR xorCacheMax r min minV l + where + xorCacheMax = xor k max --- | /O(log n)/. Find smallest key greater than the given one and return the --- corresponding (key, value) pair. --- --- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') --- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing + goR !_ Tip fMin fMinV fallback = getMax fMin fMinV fallback + goR !xorCache (Bin min minV l r) fMin fMinV fallback + | min >= k = getMax fMin fMinV fallback + | xorCache < xorCacheMin = goR xorCache r min minV l + | otherwise = goL xorCacheMin min minV l + where + xorCacheMin = xor min k --- See Note: Local 'go' functions and capturing. -lookupGT :: Key -> IntMap a -> Maybe (Key, a) -lookupGT !k t = case t of - Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r - _ -> go Nil t - where - go def (Bin p m l r) - | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def - | zero k m = go r l - | otherwise = go def r - go def (Tip ky y) - | k >= ky = unsafeFindMin def - | otherwise = Just (ky, y) - go def Nil = unsafeFindMin def + getMax min minV Tip = (min, minV) + getMax _ _ (Bin max maxV _ _) = (max, maxV) -- | /O(log n)/. Find largest key smaller or equal to the given one and return -- the corresponding (key, value) pair. @@ -681,21 +320,67 @@ lookupGT !k t = case t of -- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing -- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') -- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') - --- See Note: Local 'go' functions and capturing. lookupLE :: Key -> IntMap a -> Maybe (Key, a) -lookupLE !k t = case t of - Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r - _ -> go Nil t +lookupLE k = k `seq` start + where + start (IntMap Empty) = Nothing + start (IntMap (NonEmpty min minV node)) + | min > k = Nothing + | otherwise = Just (goL (xor min k) min minV node) + + goL !_ min minV Tip = (min, minV) + goL !xorCache min minV (Bin max maxV l r) + | max <= k = (max, maxV) + | xorCache < xorCacheMax = goL xorCache min minV l + | otherwise = goR xorCacheMax r min minV l + where + xorCacheMax = xor k max + + goR !_ Tip fMin fMinV fallback = getMax fMin fMinV fallback + goR !xorCache (Bin min minV l r) fMin fMinV fallback + | min > k = getMax fMin fMinV fallback + | xorCache < xorCacheMin = goR xorCache r min minV l + | otherwise = goL xorCacheMin min minV l + where + xorCacheMin = xor min k + + getMax min minV Tip = (min, minV) + getMax _ _ (Bin max maxV _ _) = (max, maxV) + +-- | /O(log n)/. Find smallest key greater than the given one and return the +-- corresponding (key, value) pair. +-- +-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') +-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing +lookupGT :: Key -> IntMap a -> Maybe (Key, a) +lookupGT k = k `seq` start where - go def (Bin p m l r) - | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r - | zero k m = go def l - | otherwise = go l r - go def (Tip ky y) - | k < ky = unsafeFindMax def - | otherwise = Just (ky, y) - go def Nil = unsafeFindMax def + start (IntMap Empty) = Nothing + start (IntMap (NonEmpty min minV Tip)) + | min <= k = Nothing + | otherwise = Just (min, minV) + start (IntMap (NonEmpty min minV (Bin max maxV l r))) + | max <= k = Nothing + | otherwise = Just (goR (xor k max) max maxV (Bin min minV l r)) + + goL !_ Tip fMax fMaxV fallback = getMin fMax fMaxV fallback + goL !xorCache (Bin max maxV l r) fMax fMaxV fallback + | max <= k = getMin fMax fMaxV fallback + | xorCache < xorCacheMax = goL xorCache l max maxV r + | otherwise = goR xorCacheMax max maxV r + where + xorCacheMax = xor k max + + goR !_ max maxV Tip = (max, maxV) + goR !xorCache max maxV (Bin min minV l r) + | min > k = (min, minV) + | xorCache < xorCacheMin = goR xorCache max maxV r + | otherwise = goL xorCacheMin l max maxV r + where + xorCacheMin = xor min k + + getMin max maxV Tip = (max, maxV) + getMin _ _ (Bin min minV _ _) = (min, minV) -- | /O(log n)/. Find smallest key greater or equal to the given one and return -- the corresponding (key, value) pair. @@ -703,1904 +388,795 @@ lookupLE !k t = case t of -- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') -- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') -- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing - --- See Note: Local 'go' functions and capturing. lookupGE :: Key -> IntMap a -> Maybe (Key, a) -lookupGE !k t = case t of - Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r - _ -> go Nil t - where - go def (Bin p m l r) - | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def - | zero k m = go r l - | otherwise = go def r - go def (Tip ky y) - | k > ky = unsafeFindMin def - | otherwise = Just (ky, y) - go def Nil = unsafeFindMin def - - --- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is --- given, it has m > 0. -unsafeFindMin :: IntMap a -> Maybe (Key, a) -unsafeFindMin Nil = Nothing -unsafeFindMin (Tip ky y) = Just (ky, y) -unsafeFindMin (Bin _ _ l _) = unsafeFindMin l - --- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is --- given, it has m > 0. -unsafeFindMax :: IntMap a -> Maybe (Key, a) -unsafeFindMax Nil = Nothing -unsafeFindMax (Tip ky y) = Just (ky, y) -unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r - -{-------------------------------------------------------------------- - Disjoint ---------------------------------------------------------------------} --- | /O(n+m)/. Check whether the key sets of two maps are disjoint --- (i.e. their 'intersection' is empty). --- --- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True --- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False --- > disjoint (fromList []) (fromList []) == True --- --- > disjoint a b == null (intersection a b) --- --- @since 0.6.2.1 -disjoint :: IntMap a -> IntMap b -> Bool -disjoint Nil _ = True -disjoint _ Nil = True -disjoint (Tip kx _) ys = notMember kx ys -disjoint xs (Tip ky _) = notMember ky xs -disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) - | shorter m1 m2 = disjoint1 - | shorter m2 m1 = disjoint2 - | p1 == p2 = disjoint l1 l2 && disjoint r1 r2 - | otherwise = True +lookupGE k = k `seq` start where - disjoint1 | nomatch p2 p1 m1 = True - | zero p2 m1 = disjoint l1 t2 - | otherwise = disjoint r1 t2 - disjoint2 | nomatch p1 p2 m2 = True - | zero p1 m2 = disjoint t1 l2 - | otherwise = disjoint t1 r2 - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} + start (IntMap Empty) = Nothing + start (IntMap (NonEmpty min minV Tip)) + | min < k = Nothing + | otherwise = Just (min, minV) + start (IntMap (NonEmpty min minV (Bin max maxV l r))) + | max < k = Nothing + | otherwise = Just (goR (xor k max) max maxV (Bin min minV l r)) + + goL !_ Tip fMax fMaxV fallback = getMin fMax fMaxV fallback + goL !xorCache (Bin max maxV l r) fMax fMaxV fallback + | max < k = getMin fMax fMaxV fallback + | xorCache < xorCacheMax = goL xorCache l max maxV r + | otherwise = goR xorCacheMax max maxV r + where + xorCacheMax = xor k max + + goR !_ max maxV Tip = (max, maxV) + goR !xorCache max maxV (Bin min minV l r) + | min >= k = (min, minV) + | xorCache < xorCacheMin = goR xorCache max maxV r + | otherwise = goL xorCacheMin l max maxV r + where + xorCacheMin = xor min k + + getMin max maxV Tip = (max, maxV) + getMin _ _ (Bin min minV _ _) = (min, minV) + -- | /O(1)/. The empty map. -- -- > empty == fromList [] -- > size empty == 0 - empty :: IntMap a -empty - = Nil -{-# INLINE empty #-} - --- | /O(1)/. A map of one element. --- --- > singleton 1 'a' == fromList [(1, 'a')] --- > size (singleton 1 'a') == 1 - -singleton :: Key -> a -> IntMap a -singleton k x - = Tip k x -{-# INLINE singleton #-} - -{-------------------------------------------------------------------- - Insert ---------------------------------------------------------------------} --- | /O(min(n,W))/. Insert a new key\/value pair in the map. --- If the key is already present in the map, the associated value is --- replaced with the supplied value, i.e. 'insert' is equivalent to --- @'insertWith' 'const'@. --- --- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] --- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] --- > insert 5 'x' empty == singleton 5 'x' - -insert :: Key -> a -> IntMap a -> IntMap a -insert !k x t@(Bin p m l r) - | nomatch k p m = link k (Tip k x) p t - | zero k m = Bin p m (insert k x l) r - | otherwise = Bin p m l (insert k x r) -insert k x t@(Tip ky _) - | k==ky = Tip k x - | otherwise = link k (Tip k x) ky t -insert k x Nil = Tip k x - --- right-biased insertion, used by 'union' --- | /O(min(n,W))/. Insert with a combining function. --- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert @f new_value old_value@. --- --- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] --- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] --- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" - -insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith f k x t - = insertWithKey (\_ x' y' -> f x' y') k x t - --- | /O(min(n,W))/. Insert with a combining function. --- @'insertWithKey' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert @f key new_value old_value@. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] --- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] --- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" - -insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWithKey f !k x t@(Bin p m l r) - | nomatch k p m = link k (Tip k x) p t - | zero k m = Bin p m (insertWithKey f k x l) r - | otherwise = Bin p m l (insertWithKey f k x r) -insertWithKey f k x t@(Tip ky y) - | k == ky = Tip k (f k x y) - | otherwise = link k (Tip k x) ky t -insertWithKey _ k x Nil = Tip k x - --- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) --- is a pair where the first element is equal to (@'lookup' k map@) --- and the second element equal to (@'insertWithKey' f k x map@). --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) --- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) --- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") --- --- This is how to define @insertLookup@ using @insertLookupWithKey@: --- --- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t --- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) --- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) - -insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) -insertLookupWithKey f !k x t@(Bin p m l r) - | nomatch k p m = (Nothing,link k (Tip k x) p t) - | zero k m = let (found,l') = insertLookupWithKey f k x l - in (found,Bin p m l' r) - | otherwise = let (found,r') = insertLookupWithKey f k x r - in (found,Bin p m l r') -insertLookupWithKey f k x t@(Tip ky y) - | k == ky = (Just y,Tip k (f k x y)) - | otherwise = (Nothing,link k (Tip k x) ky t) -insertLookupWithKey _ k x Nil = (Nothing,Tip k x) - - -{-------------------------------------------------------------------- - Deletion ---------------------------------------------------------------------} --- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not --- a member of the map, the original map is returned. --- --- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" --- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > delete 5 empty == empty +empty = IntMap Empty +-- | /O(min(n,W))/. Delete a key and its value from the map. +-- When the key is not a member of the map, the original map is returned. delete :: Key -> IntMap a -> IntMap a -delete !k t@(Bin p m l r) - | nomatch k p m = t - | zero k m = binCheckLeft p m (delete k l) r - | otherwise = binCheckRight p m l (delete k r) -delete k t@(Tip ky _) - | k == ky = Nil - | otherwise = t -delete _k Nil = Nil - --- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. --- --- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] --- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > adjust ("new " ++) 7 empty == empty - -adjust :: (a -> a) -> Key -> IntMap a -> IntMap a -adjust f k m - = adjustWithKey (\_ x -> f x) k m - --- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. --- --- > let f key x = (show key) ++ ":new " ++ x --- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] --- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > adjustWithKey f 7 empty == empty - -adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a -adjustWithKey f !k t@(Bin p m l r) - | nomatch k p m = t - | zero k m = Bin p m (adjustWithKey f k l) r - | otherwise = Bin p m l (adjustWithKey f k r) -adjustWithKey f k t@(Tip ky y) - | k == ky = Tip ky (f k y) - | otherwise = t -adjustWithKey _ _ Nil = Nil - - --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] --- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a -update f - = updateWithKey (\_ x -> f x) - --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] --- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a -updateWithKey f !k t@(Bin p m l r) - | nomatch k p m = t - | zero k m = binCheckLeft p m (updateWithKey f k l) r - | otherwise = binCheckRight p m l (updateWithKey f k r) -updateWithKey f k t@(Tip ky y) - | k == ky = case (f k y) of - Just y' -> Tip ky y' - Nothing -> Nil - | otherwise = t -updateWithKey _ _ Nil = Nil - --- | /O(min(n,W))/. Lookup and update. --- The function returns original value, if it is updated. --- This is different behavior than 'Data.Map.updateLookupWithKey'. --- Returns the original key value if the map entry is deleted. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) --- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) --- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") - -updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a) -updateLookupWithKey f !k t@(Bin p m l r) - | nomatch k p m = (Nothing,t) - | zero k m = let !(found,l') = updateLookupWithKey f k l - in (found,binCheckLeft p m l' r) - | otherwise = let !(found,r') = updateLookupWithKey f k r - in (found,binCheckRight p m l r') -updateLookupWithKey f k t@(Tip ky y) - | k==ky = case (f k y) of - Just y' -> (Just y,Tip ky y') - Nothing -> (Just y,Nil) - | otherwise = (Nothing,t) -updateLookupWithKey _ _ Nil = (Nothing,Nil) - - - --- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. --- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. --- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. -alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a -alter f !k t@(Bin p m l r) - | nomatch k p m = case f Nothing of - Nothing -> t - Just x -> link k (Tip k x) p t - | zero k m = binCheckLeft p m (alter f k l) r - | otherwise = binCheckRight p m l (alter f k r) -alter f k t@(Tip ky y) - | k==ky = case f (Just y) of - Just x -> Tip ky x - Nothing -> Nil - | otherwise = case f Nothing of - Just x -> link k (Tip k x) ky t - Nothing -> Tip ky y -alter f k Nil = case f Nothing of - Just x -> Tip k x - Nothing -> Nil - --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at --- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, --- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f --- ('lookup' k m)@. --- --- Example: --- --- @ --- interactiveAlter :: Int -> IntMap String -> IO (IntMap String) --- interactiveAlter k m = alterF f k m where --- f Nothing = do --- putStrLn $ show k ++ --- " was not found in the map. Would you like to add it?" --- getUserResponse1 :: IO (Maybe String) --- f (Just old) = do --- putStrLn $ "The key is currently bound to " ++ show old ++ --- ". Would you like to change or delete it?" --- getUserResponse2 :: IO (Maybe String) --- @ --- --- 'alterF' is the most general operation for working with an individual --- key that may or may not be in a given map. --- --- Note: 'alterF' is a flipped version of the @at@ combinator from --- @Control.Lens.At@. --- --- @since 0.5.8 - -alterF :: Functor f - => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a) --- This implementation was stolen from 'Control.Lens.At'. -alterF f k m = (<$> f mv) $ \fres -> - case fres of - Nothing -> maybe m (const (delete k m)) mv - Just v' -> insert k v' m - where mv = lookup k m - -{-------------------------------------------------------------------- - Union ---------------------------------------------------------------------} --- | The union of a list of maps. --- --- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] --- > == fromList [(3, "b"), (5, "a"), (7, "C")] --- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] --- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] - -unions :: Foldable f => f (IntMap a) -> IntMap a -unions xs - = Foldable.foldl' union empty xs - --- | The union of a list of maps, with a combining operation. --- --- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] --- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] - -unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a -unionsWith f ts - = Foldable.foldl' (unionWith f) empty ts +delete k = k `seq` start + where + start (IntMap Empty) = IntMap Empty + start m@(IntMap (NonEmpty min _ Tip)) + | k == min = IntMap Empty + | otherwise = m + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) + | k < min = m + | k == min = let DR min' minV' root' = deleteMinL max maxV l r in IntMap (NonEmpty min' minV' root') + | otherwise = IntMap (NonEmpty min minV (deleteL k (xor min k) root)) + +-- TODO: Does a strict pair work? My guess is not, as GHC was already +-- unboxing the tuple, but it would be simpler to use one of those. +-- | Without this specialized type (I was just using a tuple), GHC's +-- CPR correctly unboxed the tuple, but it couldn't unbox the returned +-- Key, leading to lots of inefficiency (3x slower than stock Data.IntMap) +data DeleteResult t a = DR {-# UNPACK #-} !Key a !(Node t a) -- | /O(n+m)/. The (left-biased) union of two maps. -- It prefers the first map when duplicate keys are encountered, -- i.e. (@'union' == 'unionWith' 'const'@). -- -- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")] - union :: IntMap a -> IntMap a -> IntMap a -union m1 m2 - = mergeWithKey' Bin const id id m1 m2 - --- | /O(n+m)/. The union with a combining function. --- --- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] - -unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWith f m1 m2 - = unionWithKey (\_ x y -> f x y) m1 m2 +union = start + where + start (IntMap Empty) m2 = m2 + start m1 (IntMap Empty) = m1 + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 minV2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) + | otherwise = IntMap (NonEmpty min1 minV1 (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + + -- TODO: Should I bind 'minV1' in a closure? It never changes. + -- TODO: Should I cache @xor min1 min2@? + goL1 minV1 min1 Tip !_ Tip = Bin min1 minV1 Tip Tip + goL1 minV1 min1 Tip min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1 minV1 min1 n1 min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min1 min2 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> Bin max1 maxV1 l2 (goRFused max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 + EQ | max2 < min1 -> disjoint + | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 + where + disjoint = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) + + -- TODO: Should I bind 'minV2' in a closure? It never changes. + -- TODO: Should I cache @xor min1 min2@? + goL2 minV2 !_ Tip min2 Tip = Bin min2 minV2 Tip Tip + goL2 minV2 min1 Tip min2 n2 = insertMinL (xor min1 min2) min2 minV2 n2 + goL2 minV2 min1 n1 min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 + EQ | max1 < min2 -> disjoint + | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> Bin max1 maxV1 l1 (goRFused max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 + where + disjoint = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) + + -- TODO: Should I bind 'min' in a closure? It never changes. + -- TODO: Should I use an xor cache here? + -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same + -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' + goLFused !_ Tip n2 = n2 + goLFused !_ n1 Tip = n1 + goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 + EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 maxV1 (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 + + -- TODO: Should I bind 'maxV1' in a closure? It never changes. + -- TODO: Should I cache @xor max1 max2@? + goR1 maxV1 max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip + goR1 maxV1 max1 Tip max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 + goR1 maxV1 max1 n1 max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | otherwise -> Bin min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 + EQ | max1 < min2 -> disjoint + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) + where + disjoint = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 + + -- TODO: Should I bind 'minV2' in a closure? It never changes. + -- TODO: Should I cache @xor min1 min2@? + goR2 maxV2 !_ Tip max2 Tip = Bin max2 maxV2 Tip Tip + goR2 maxV2 max1 Tip max2 n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 + goR2 maxV2 max1 n1 max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) + EQ | max2 < min1 -> disjoint + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | otherwise -> Bin min1 minV1 (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 + where + disjoint = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 + + -- TODO: Should I bind 'max' in a closure? It never changes. + -- TODO: Should I use an xor cache here? + -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same + -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' + goRFused !_ Tip n2 = n2 + goRFused !_ n1 Tip = n1 + goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> Bin min2 minV2 l2 (goRFused max n1 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) + | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT -> Bin min1 minV1 l1 (goRFused max r1 n2) + + goInsertL1 k v !_ _ Tip = Bin k v Tip Tip + goInsertL1 k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goInsertL1 k v xorCache min l) r + else Bin max maxV l (goInsertR1 k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max v l r + where xorCacheMax = xor k max + + goInsertR1 k v !_ _ Tip = Bin k v Tip Tip + goInsertR1 k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goInsertR1 k v xorCache max r) + else Bin min minV (goInsertL1 k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min v l r + where xorCacheMin = xor min k + + goInsertL2 k v !_ _ Tip = Bin k v Tip Tip + goInsertL2 k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goInsertL2 k v xorCache min l) r + else Bin max maxV l (goInsertR2 k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max maxV l r + where xorCacheMax = xor k max + + goInsertR2 k v !_ _ Tip = Bin k v Tip Tip + goInsertR2 k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goInsertR2 k v xorCache max r) + else Bin min minV (goInsertL2 k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min minV l r + where xorCacheMin = xor min k --- | /O(n+m)/. The union with a combining function. +-- | The union of a list of maps. -- --- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value --- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] - -unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWithKey f m1 m2 - = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2 +-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] +-- > == fromList [(3, "b"), (5, "a"), (7, "C")] +-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] +-- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] +unions :: [IntMap a] -> IntMap a +unions = Data.Foldable.foldl' union empty -{-------------------------------------------------------------------- - Difference ---------------------------------------------------------------------} -- | /O(n+m)/. Difference between two maps (based on keys). -- -- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b" - difference :: IntMap a -> IntMap b -> IntMap a -difference m1 m2 - = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2 - --- | /O(n+m)/. Difference with a combining function. --- --- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing --- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) --- > == singleton 3 "b:B" - -differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWith f m1 m2 - = differenceWithKey (\_ x y -> f x y) m1 m2 - --- | /O(n+m)/. Difference with a combining function. When two equal keys are --- encountered, the combining function is applied to the key and both values. --- If it returns 'Nothing', the element is discarded (proper set difference). --- If it returns (@'Just' y@), the element is updated with a new value @y@. --- --- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing --- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) --- > == singleton 3 "3:b|B" - -differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWithKey f m1 m2 - = mergeWithKey f id (const Nil) m1 m2 - +difference = start + where + start (IntMap Empty) !_ = IntMap Empty + start !m (IntMap Empty) = m + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 _ root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + | otherwise = IntMap (goLFused min1 root1 root2) + + goL1 minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 + EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) + | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) + GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) + + goL2 !_ Tip !_ !_ = Tip + goL2 min1 n1 min2 Tip = deleteL min2 (xor min1 min2) n1 + goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = n1 + goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goL2 min1 n1 min2 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> goL2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + | otherwise -> case goRFused max1 r1 r2 of + Empty -> goL2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of + Empty -> l1 + NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' + | otherwise -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of + Empty -> l1 + NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' + + goLFused min = loop + where + loop Tip !_ = Empty + loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of + DR min' minV' n' -> NonEmpty min' minV' n' + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) + | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) + + goR1 maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) + | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) + GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) + + goR2 !_ Tip !_ !_ = Tip + goR2 max1 n1 max2 Tip = deleteR max2 (xor max1 max2) n1 + goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = n1 + goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goR2 max1 n1 max2 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> goR2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + | otherwise -> case goLFused min1 l1 l2 of + Empty -> goR2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 + | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of + Empty -> r1 + NonEmpty min' minV' l' -> Bin min' minV' l' r1 + | otherwise -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of + Empty -> r1 + NonEmpty min' minV' l' -> Bin min' minV' l' r1 + + goRFused max = loop + where + loop Tip !_ = Empty + loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of + DR max' maxV' n' -> NonEmpty max' maxV' n' + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) + | otherwise -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) + + goLookupL k v !_ Tip = NonEmpty k v Tip + goLookupL k v !xorCache (Bin max _ l r) + | k < max = if xorCache < xorCacheMax + then goLookupL k v xorCache l + else goLookupR k v xorCacheMax r + | k > max = NonEmpty k v Tip + | otherwise = Empty + where xorCacheMax = xor k max + + goLookupR k v !_ Tip = NonEmpty k v Tip + goLookupR k v !xorCache (Bin min _ l r) + | k > min = if xorCache < xorCacheMin + then goLookupR k v xorCache r + else goLookupL k v xorCacheMin l + | k < min = NonEmpty k v Tip + | otherwise = Empty + where xorCacheMin = xor min k + + dummyV = error "impossible" --- TODO(wrengr): re-verify that asymptotic bound --- | /O(n+m)/. Remove all the keys in a given set from a map. --- --- @ --- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.notMember`` s) m --- @ --- --- @since 0.5.8 -withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a -withoutKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2) - | shorter m1 m2 = difference1 - | shorter m2 m1 = difference2 - | p1 == p2 = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2) - | otherwise = t1 - where - difference1 - | nomatch p2 p1 m1 = t1 - | zero p2 m1 = binCheckLeft p1 m1 (withoutKeys l1 t2) r1 - | otherwise = binCheckRight p1 m1 l1 (withoutKeys r1 t2) - difference2 - | nomatch p1 p2 m2 = t1 - | zero p1 m2 = withoutKeys t1 l2 - | otherwise = withoutKeys t1 r2 -withoutKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) = - let minbit = bitmapOf p1 - lt_minbit = minbit - 1 - maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1))) - gt_maxbit = (-maxbit) `xor` maxbit - -- TODO(wrengr): should we manually inline/unroll 'updatePrefix' - -- and 'withoutBM' here, in order to avoid redundant case analyses? - in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit) -withoutKeys t1@(Bin _ _ _ _) IntSet.Nil = t1 -withoutKeys t1@(Tip k1 _) t2 - | k1 `IntSet.member` t2 = Nil - | otherwise = t1 -withoutKeys Nil _ = Nil - - -updatePrefix - :: IntSetPrefix -> IntMap a -> (IntMap a -> IntMap a) -> IntMap a -updatePrefix !kp t@(Bin p m l r) f - | m .&. IntSet.suffixBitMask /= 0 = - if p .&. IntSet.prefixBitMask == kp then f t else t - | nomatch kp p m = t - | zero kp m = binCheckLeft p m (updatePrefix kp l f) r - | otherwise = binCheckRight p m l (updatePrefix kp r f) -updatePrefix kp t@(Tip kx _) f - | kx .&. IntSet.prefixBitMask == kp = f t - | otherwise = t -updatePrefix _ Nil _ = Nil - - -withoutBM :: IntSetBitMap -> IntMap a -> IntMap a -withoutBM 0 t = t -withoutBM bm (Bin p m l r) = - let leftBits = bitmapOf (p .|. m) - 1 - bmL = bm .&. leftBits - bmR = bm `xor` bmL -- = (bm .&. complement leftBits) - in bin p m (withoutBM bmL l) (withoutBM bmR r) -withoutBM bm t@(Tip k _) - -- TODO(wrengr): need we manually inline 'IntSet.Member' here? - | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = Nil - | otherwise = t -withoutBM _ Nil = Nil - - -{-------------------------------------------------------------------- - Intersection ---------------------------------------------------------------------} -- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys). -- -- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a" - intersection :: IntMap a -> IntMap b -> IntMap a -intersection m1 m2 - = mergeWithKey' bin const (const Nil) (const Nil) m1 m2 - +intersection = start + where + start (IntMap Empty) !_ = IntMap Empty + start !_ (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 _ root2)) + | min1 < min2 = IntMap (goL2 min1 root1 min2 root2) + | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + | otherwise = IntMap (NonEmpty min1 minV1 (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + + -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. + + goL1 _ !_ !_ !_ Tip = Empty + goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 + goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ goR2 max1 (Bin min1 minV1 l1 r1) max2 r2 + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2)) + GT -> goL1 minV1 min1 l1 min2 n2 + + goL2 !_ Tip !_ !_ = Empty + goL2 min1 n1 min2 Tip = goLookupL2 min2 (xor min1 min2) n1 + goL2 _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty + goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goL2 min1 n1 min2 l2 + EQ | max1 > max2 -> binL (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL2 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2)) + GT | xor min1 min2 < xor min2 max1 -> goL2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> r2lMap $ goR2 max1 r1 max2 (Bin min2 dummyV l2 r2) + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 r1 (Bin min2 dummyV l2 r2)) + + goLFused min = loop + where + loop Tip !_ = Tip + loop !_ Tip = Tip + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> case goR2 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | otherwise -> Bin max1 maxV1 (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> loop l1 n2 + + goR1 _ !_ !_ !_ Tip = Empty + goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 + goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> binR (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') + GT -> goR1 maxV1 max1 r1 max2 n2 + + goR2 !_ Tip !_ !_ = Empty + goR2 max1 n1 max2 Tip = goLookupR2 max2 (xor max1 max2) n1 + goR2 _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty + goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goR2 max1 n1 max2 r2 + EQ | min1 < min2 -> binR (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | otherwise -> case goR2 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') + GT | xor min1 max2 > xor max2 max1 -> goR2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> l2rMap $ goL2 min1 l1 min2 (Bin max2 dummyV l2 r2) + | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 l1 (Bin max2 dummyV l2 r2)) + + goRFused max = loop + where + loop Tip !_ = Tip + loop !_ Tip = Tip + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> case goL2 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (loop r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> loop r1 n2 + + goLookupL1 !_ _ !_ Tip = Empty + goLookupL1 k v !xorCache (Bin max _ l r) + | k < max = if xorCache < xorCacheMax + then goLookupL1 k v xorCache l + else goLookupR1 k v xorCacheMax r + | k > max = Empty + | otherwise = NonEmpty k v Tip + where xorCacheMax = xor k max + + goLookupR1 !_ _ !_ Tip = Empty + goLookupR1 k v !xorCache (Bin min _ l r) + | k > min = if xorCache < xorCacheMin + then goLookupR1 k v xorCache r + else goLookupL1 k v xorCacheMin l + | k < min = Empty + | otherwise = NonEmpty k v Tip + where xorCacheMin = xor min k + + goLookupL2 !_ !_ Tip = Empty + goLookupL2 k !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL2 k xorCache l + else goLookupR2 k xorCacheMax r + | k > max = Empty + | otherwise = NonEmpty k maxV Tip + where xorCacheMax = xor k max + + goLookupR2 !_ !_ Tip = Empty + goLookupR2 k !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR2 k xorCache r + else goLookupL2 k xorCacheMin l + | k < min = Empty + | otherwise = NonEmpty k minV Tip + where xorCacheMin = xor min k + + dummyV = error "impossible" --- TODO(wrengr): re-verify that asymptotic bound --- | /O(n+m)/. The restriction of a map to the keys in a set. --- --- @ --- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.member`` s) m --- @ +-- | /O(n)/. Fold the values in the map using the given right-associative +-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. -- --- @since 0.5.8 -restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a -restrictKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2) - | shorter m1 m2 = intersection1 - | shorter m2 m1 = intersection2 - | p1 == p2 = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2) - | otherwise = Nil - where - intersection1 - | nomatch p2 p1 m1 = Nil - | zero p2 m1 = restrictKeys l1 t2 - | otherwise = restrictKeys r1 t2 - intersection2 - | nomatch p1 p2 m2 = Nil - | zero p1 m2 = restrictKeys t1 l2 - | otherwise = restrictKeys t1 r2 -restrictKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) = - let minbit = bitmapOf p1 - ge_minbit = complement (minbit - 1) - maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1))) - le_maxbit = maxbit .|. (maxbit - 1) - -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix' - -- and 'restrictBM' here, in order to avoid redundant case analyses? - in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1) -restrictKeys (Bin _ _ _ _) IntSet.Nil = Nil -restrictKeys t1@(Tip k1 _) t2 - | k1 `IntSet.member` t2 = t1 - | otherwise = Nil -restrictKeys Nil _ = Nil - - --- | /O(min(n,W))/. Restrict to the sub-map with all keys matching --- a key prefix. -lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a -lookupPrefix !kp t@(Bin p m l r) - | m .&. IntSet.suffixBitMask /= 0 = - if p .&. IntSet.prefixBitMask == kp then t else Nil - | nomatch kp p m = Nil - | zero kp m = lookupPrefix kp l - | otherwise = lookupPrefix kp r -lookupPrefix kp t@(Tip kx _) - | (kx .&. IntSet.prefixBitMask) == kp = t - | otherwise = Nil -lookupPrefix _ Nil = Nil - - -restrictBM :: IntSetBitMap -> IntMap a -> IntMap a -restrictBM 0 _ = Nil -restrictBM bm (Bin p m l r) = - let leftBits = bitmapOf (p .|. m) - 1 - bmL = bm .&. leftBits - bmR = bm `xor` bmL -- = (bm .&. complement leftBits) - in bin p m (restrictBM bmL l) (restrictBM bmR r) -restrictBM bm t@(Tip k _) - -- TODO(wrengr): need we manually inline 'IntSet.Member' here? - | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = t - | otherwise = Nil -restrictBM _ Nil = Nil - - --- | /O(n+m)/. The intersection with a combining function. +-- For example, -- --- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" - -intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWith f m1 m2 - = intersectionWithKey (\_ x y -> f x y) m1 m2 - --- | /O(n+m)/. The intersection with a combining function. +-- > elems map = foldr (:) [] map -- --- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar --- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" +-- > let f a len = len + (length a) +-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 +foldr :: (a -> b -> b) -> b -> IntMap a -> b +foldr f z = start + where + start (IntMap Empty) = z + start (IntMap (NonEmpty _ minV root)) = f minV (goL root z) -intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey f m1 m2 - = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2 + goL Tip acc = acc + goL (Bin _ maxV l r) acc = goL l (goR r (f maxV acc)) -{-------------------------------------------------------------------- - MergeWithKey ---------------------------------------------------------------------} + goR Tip acc = acc + goR (Bin _ minV l r) acc = f minV (goL l (goR r acc)) --- | /O(n+m)/. A high-performance universal combining function. Using --- 'mergeWithKey', all combining functions can be defined without any loss of --- efficiency (with exception of 'union', 'difference' and 'intersection', --- where sharing of some nodes is lost with 'mergeWithKey'). --- --- Please make sure you know what is going on when using 'mergeWithKey', --- otherwise you can be surprised by unexpected code growth or even --- corruption of the data structure. --- --- When 'mergeWithKey' is given three arguments, it is inlined to the call --- site. You should therefore use 'mergeWithKey' only to define your custom --- combining functions. For example, you could define 'unionWithKey', --- 'differenceWithKey' and 'intersectionWithKey' as --- --- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 --- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 --- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 --- --- When calling @'mergeWithKey' combine only1 only2@, a function combining two --- 'IntMap's is created, such that --- --- * if a key is present in both maps, it is passed with both corresponding --- values to the @combine@ function. Depending on the result, the key is either --- present in the result with specified value, or is left out; --- --- * a nonempty subtree present only in the first map is passed to @only1@ and --- the output is added to the result; --- --- * a nonempty subtree present only in the second map is passed to @only2@ and --- the output is added to the result. +-- | /O(n)/. Fold the values in the map using the given left-associative +-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. -- --- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. --- The values can be modified arbitrarily. Most common variants of @only1@ and --- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or --- @'filterWithKey' f@ could be used for any @f@. - -mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) - -> IntMap a -> IntMap b -> IntMap c -mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2 - where -- We use the lambda form to avoid non-exhaustive pattern matches warning. - combine = \(Tip k1 x1) (Tip _k2 x2) -> - case f k1 x1 x2 of - Nothing -> Nil - Just x -> Tip k1 x - {-# INLINE combine #-} -{-# INLINE mergeWithKey #-} - --- Slightly more general version of mergeWithKey. It differs in the following: +-- For example, -- --- * the combining function operates on maps instead of keys and values. The --- reason is to enable sharing in union, difference and intersection. +-- > elems = reverse . foldl (flip (:)) [] -- --- * mergeWithKey' is given an equivalent of bin. The reason is that in union*, --- Bin constructor can be used, because we know both subtrees are nonempty. - -mergeWithKey' :: (Prefix -> Mask -> IntMap c -> IntMap c -> IntMap c) - -> (IntMap a -> IntMap b -> IntMap c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) - -> IntMap a -> IntMap b -> IntMap c -mergeWithKey' bin' f g1 g2 = go +-- > let f len a = len + (length a) +-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 +foldl :: (a -> b -> a) -> a -> IntMap b -> a +foldl f z = start where - go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) - | shorter m1 m2 = merge1 - | shorter m2 m1 = merge2 - | p1 == p2 = bin' p1 m1 (go l1 l2) (go r1 r2) - | otherwise = maybe_link p1 (g1 t1) p2 (g2 t2) - where - merge1 | nomatch p2 p1 m1 = maybe_link p1 (g1 t1) p2 (g2 t2) - | zero p2 m1 = bin' p1 m1 (go l1 t2) (g1 r1) - | otherwise = bin' p1 m1 (g1 l1) (go r1 t2) - merge2 | nomatch p1 p2 m2 = maybe_link p1 (g1 t1) p2 (g2 t2) - | zero p1 m2 = bin' p2 m2 (go t1 l2) (g2 r2) - | otherwise = bin' p2 m2 (g2 l2) (go t1 r2) - - go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1' - where - merge0 t2 k2 t1@(Bin p1 m1 l1 r1) - | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2) - | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1) - | otherwise = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1) - merge0 t2 k2 t1@(Tip k1 _) - | k1 == k2 = f t1 t2 - | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2) - merge0 t2 _ Nil = g2 t2 - - go t1@(Bin _ _ _ _) Nil = g1 t1 - - go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2' - where - merge0 t1 k1 t2@(Bin p2 m2 l2 r2) - | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2) - | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2) - | otherwise = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2) - merge0 t1 k1 t2@(Tip k2 _) - | k1 == k2 = f t1 t2 - | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2) - merge0 t1 _ Nil = g1 t1 - - go Nil t2 = g2 t2 - - maybe_link _ Nil _ t2 = t2 - maybe_link _ t1 _ Nil = t1 - maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2 - {-# INLINE maybe_link #-} -{-# INLINE mergeWithKey' #-} - - -{-------------------------------------------------------------------- - mergeA ---------------------------------------------------------------------} - --- | A tactic for dealing with keys present in one map but not the --- other in 'merge' or 'mergeA'. --- --- A tactic of type @WhenMissing f k x z@ is an abstract representation --- of a function of type @Key -> x -> f (Maybe z)@. --- --- @since 0.5.9 - -data WhenMissing f x y = WhenMissing - { missingSubtree :: IntMap x -> f (IntMap y) - , missingKey :: Key -> x -> f (Maybe y)} + start (IntMap Empty) = z + start (IntMap (NonEmpty _ minV root)) = goL (f z minV) root --- | @since 0.5.9 -instance (Applicative f, Monad f) => Functor (WhenMissing f x) where - fmap = mapWhenMissing - {-# INLINE fmap #-} + goL acc Tip = acc + goL acc (Bin _ maxV l r) = f (goR (goL acc l) r) maxV + goR acc Tip = acc + goR acc (Bin _ minV l r) = goR (goL (f acc minV) l) r --- | @since 0.5.9 -instance (Applicative f, Monad f) => Category.Category (WhenMissing f) - where - id = preserveMissing - f . g = - traverseMaybeMissing $ \ k x -> do - y <- missingKey g k x - case y of - Nothing -> pure Nothing - Just q -> missingKey f k q - {-# INLINE id #-} - {-# INLINE (.) #-} - - --- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@. --- --- @since 0.5.9 -instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where - pure x = mapMissing (\ _ _ -> x) - f <*> g = - traverseMaybeMissing $ \k x -> do - res1 <- missingKey f k x - case res1 of - Nothing -> pure Nothing - Just r -> (pure $!) . fmap r =<< missingKey g k x - {-# INLINE pure #-} - {-# INLINE (<*>) #-} - - --- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@. +-- | /O(n)/. Fold the keys and values in the map using the given right-associative +-- binary operator, such that +-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. -- --- @since 0.5.9 -instance (Applicative f, Monad f) => Monad (WhenMissing f x) where -#if !MIN_VERSION_base(4,8,0) - return = pure -#endif - m >>= f = - traverseMaybeMissing $ \k x -> do - res1 <- missingKey m k x - case res1 of - Nothing -> pure Nothing - Just r -> missingKey (f r) k x - {-# INLINE (>>=) #-} - - --- | Map covariantly over a @'WhenMissing' f x@. +-- For example, -- --- @since 0.5.9 -mapWhenMissing - :: (Applicative f, Monad f) - => (a -> b) - -> WhenMissing f x a - -> WhenMissing f x b -mapWhenMissing f t = WhenMissing - { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m' - , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) } -{-# INLINE mapWhenMissing #-} - - --- | Map covariantly over a @'WhenMissing' f x@, using only a --- 'Functor f' constraint. -mapGentlyWhenMissing - :: Functor f - => (a -> b) - -> WhenMissing f x a - -> WhenMissing f x b -mapGentlyWhenMissing f t = WhenMissing - { missingSubtree = \m -> fmap f <$> missingSubtree t m - , missingKey = \k x -> fmap f <$> missingKey t k x } -{-# INLINE mapGentlyWhenMissing #-} - - --- | Map covariantly over a @'WhenMatched' f k x@, using only a --- 'Functor f' constraint. -mapGentlyWhenMatched - :: Functor f - => (a -> b) - -> WhenMatched f x y a - -> WhenMatched f x y b -mapGentlyWhenMatched f t = - zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y -{-# INLINE mapGentlyWhenMatched #-} - - --- | Map contravariantly over a @'WhenMissing' f _ x@. +-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map -- --- @since 0.5.9 -lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x -lmapWhenMissing f t = WhenMissing - { missingSubtree = \m -> missingSubtree t (fmap f m) - , missingKey = \k x -> missingKey t k (f x) } -{-# INLINE lmapWhenMissing #-} - +-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" +foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldrWithKey f z = start + where + start (IntMap Empty) = z + start (IntMap (NonEmpty min minV root)) = f min minV (goL root z) --- | Map contravariantly over a @'WhenMatched' f _ y z@. --- --- @since 0.5.9 -contramapFirstWhenMatched - :: (b -> a) - -> WhenMatched f a y z - -> WhenMatched f b y z -contramapFirstWhenMatched f t = - WhenMatched $ \k x y -> runWhenMatched t k (f x) y -{-# INLINE contramapFirstWhenMatched #-} + goL Tip acc = acc + goL (Bin max maxV l r) acc = goL l (goR r (f max maxV acc)) + goR Tip acc = acc + goR (Bin min minV l r) acc = f min minV (goL l (goR r acc)) --- | Map contravariantly over a @'WhenMatched' f x _ z@. +-- | /O(n)/. Fold the keys and values in the map using the given left-associative +-- binary operator, such that +-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. -- --- @since 0.5.9 -contramapSecondWhenMatched - :: (b -> a) - -> WhenMatched f x a z - -> WhenMatched f x b z -contramapSecondWhenMatched f t = - WhenMatched $ \k x y -> runWhenMatched t k x (f y) -{-# INLINE contramapSecondWhenMatched #-} - - -#if !MIN_VERSION_base(4,8,0) -newtype Identity a = Identity {runIdentity :: a} +-- For example, +-- +-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) [] +-- +-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)" +foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a +foldlWithKey f z = start + where + start (IntMap Empty) = z + start (IntMap (NonEmpty min minV root)) = goL (f z min minV) root -instance Functor Identity where - fmap f (Identity x) = Identity (f x) + goL acc Tip = acc + goL acc (Bin max maxV l r) = f (goR (goL acc l) r) max maxV -instance Applicative Identity where - pure = Identity - Identity f <*> Identity x = Identity (f x) -#endif + goR acc Tip = acc + goR acc (Bin min minV l r) = goR (goL (f acc min minV) l) r --- | A tactic for dealing with keys present in one map but not the --- other in 'merge'. +-- | /O(n)/. Fold the keys and values in the map using the given monoid, such that -- --- A tactic of type @SimpleWhenMissing x z@ is an abstract --- representation of a function of type @Key -> x -> Maybe z@. +-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@ -- --- @since 0.5.9 -type SimpleWhenMissing = WhenMissing Identity +-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids. +foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m +foldMapWithKey f = start + where + start (IntMap Empty) = mempty + start (IntMap (NonEmpty min minV root)) = f min minV `mappend` goL root + goL Tip = mempty + goL (Bin max maxV l r) = goL l `mappend` goR r `mappend` f max maxV --- | A tactic for dealing with keys present in both maps in 'merge' --- or 'mergeA'. --- --- A tactic of type @WhenMatched f x y z@ is an abstract representation --- of a function of type @Key -> x -> y -> f (Maybe z)@. --- --- @since 0.5.9 -newtype WhenMatched f x y z = WhenMatched - { matchedKey :: Key -> x -> y -> f (Maybe z) } + goR Tip = mempty + goR (Bin min minV l r) = f min minV `mappend` goL l `mappend` goR r +-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldr' :: (a -> b -> b) -> b -> IntMap a -> b +foldr' f z = start + where + start (IntMap Empty) = z + start (IntMap (NonEmpty _ minV root)) = f minV $! goL root $! z --- | Along with zipWithMaybeAMatched, witnesses the isomorphism --- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@. --- --- @since 0.5.9 -runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z) -runWhenMatched = matchedKey -{-# INLINE runWhenMatched #-} + goL Tip acc = acc + goL (Bin _ maxV l r) acc = goL l $! goR r $! f maxV $! acc + goR Tip acc = acc + goR (Bin _ minV l r) acc = f minV $! goL l $! goR r $! acc --- | Along with traverseMaybeMissing, witnesses the isomorphism --- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@. --- --- @since 0.5.9 -runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y) -runWhenMissing = missingKey -{-# INLINE runWhenMissing #-} +-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldl' :: (a -> b -> a) -> a -> IntMap b -> a +foldl' f z = start + where + start (IntMap Empty) = z + start (IntMap (NonEmpty _ minV root)) = s goL (s f z minV) root + goL acc Tip = acc + goL acc (Bin _ maxV l r) = s f (s goR (s goL acc l) r) maxV --- | @since 0.5.9 -instance Functor f => Functor (WhenMatched f x y) where - fmap = mapWhenMatched - {-# INLINE fmap #-} + goR acc Tip = acc + goR acc (Bin _ minV l r) = s goR (s goL (s f acc minV) l) r + s = ($!) --- | @since 0.5.9 -instance (Monad f, Applicative f) => Category.Category (WhenMatched f x) +-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldrWithKey' f z = start where - id = zipWithMatched (\_ _ y -> y) - f . g = - zipWithMaybeAMatched $ \k x y -> do - res <- runWhenMatched g k x y - case res of - Nothing -> pure Nothing - Just r -> runWhenMatched f k x r - {-# INLINE id #-} - {-# INLINE (.) #-} - - --- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@ --- --- @since 0.5.9 -instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where - pure x = zipWithMatched (\_ _ _ -> x) - fs <*> xs = - zipWithMaybeAMatched $ \k x y -> do - res <- runWhenMatched fs k x y - case res of - Nothing -> pure Nothing - Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y - {-# INLINE pure #-} - {-# INLINE (<*>) #-} - - --- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@ --- --- @since 0.5.9 -instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where -#if !MIN_VERSION_base(4,8,0) - return = pure -#endif - m >>= f = - zipWithMaybeAMatched $ \k x y -> do - res <- runWhenMatched m k x y - case res of - Nothing -> pure Nothing - Just r -> runWhenMatched (f r) k x y - {-# INLINE (>>=) #-} - - --- | Map covariantly over a @'WhenMatched' f x y@. --- --- @since 0.5.9 -mapWhenMatched - :: Functor f - => (a -> b) - -> WhenMatched f x y a - -> WhenMatched f x y b -mapWhenMatched f (WhenMatched g) = - WhenMatched $ \k x y -> fmap (fmap f) (g k x y) -{-# INLINE mapWhenMatched #-} - - --- | A tactic for dealing with keys present in both maps in 'merge'. --- --- A tactic of type @SimpleWhenMatched x y z@ is an abstract --- representation of a function of type @Key -> x -> y -> Maybe z@. --- --- @since 0.5.9 -type SimpleWhenMatched = WhenMatched Identity - - --- | When a key is found in both maps, apply a function to the key --- and values and use the result in the merged map. --- --- > zipWithMatched --- > :: (Key -> x -> y -> z) --- > -> SimpleWhenMatched x y z --- --- @since 0.5.9 -zipWithMatched - :: Applicative f - => (Key -> x -> y -> z) - -> WhenMatched f x y z -zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y -{-# INLINE zipWithMatched #-} - - --- | When a key is found in both maps, apply a function to the key --- and values to produce an action and use its result in the merged --- map. --- --- @since 0.5.9 -zipWithAMatched - :: Applicative f - => (Key -> x -> y -> f z) - -> WhenMatched f x y z -zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y -{-# INLINE zipWithAMatched #-} - - --- | When a key is found in both maps, apply a function to the key --- and values and maybe use the result in the merged map. --- --- > zipWithMaybeMatched --- > :: (Key -> x -> y -> Maybe z) --- > -> SimpleWhenMatched x y z --- --- @since 0.5.9 -zipWithMaybeMatched - :: Applicative f - => (Key -> x -> y -> Maybe z) - -> WhenMatched f x y z -zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y -{-# INLINE zipWithMaybeMatched #-} - - --- | When a key is found in both maps, apply a function to the key --- and values, perform the resulting action, and maybe use the --- result in the merged map. --- --- This is the fundamental 'WhenMatched' tactic. --- --- @since 0.5.9 -zipWithMaybeAMatched - :: (Key -> x -> y -> f (Maybe z)) - -> WhenMatched f x y z -zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y -{-# INLINE zipWithMaybeAMatched #-} - - --- | Drop all the entries whose keys are missing from the other --- map. --- --- > dropMissing :: SimpleWhenMissing x y --- --- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing) --- --- but @dropMissing@ is much faster. --- --- @since 0.5.9 -dropMissing :: Applicative f => WhenMissing f x y -dropMissing = WhenMissing - { missingSubtree = const (pure Nil) - , missingKey = \_ _ -> pure Nothing } -{-# INLINE dropMissing #-} - - --- | Preserve, unchanged, the entries whose keys are missing from --- the other map. --- --- > preserveMissing :: SimpleWhenMissing x x --- --- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x) --- --- but @preserveMissing@ is much faster. --- --- @since 0.5.9 -preserveMissing :: Applicative f => WhenMissing f x x -preserveMissing = WhenMissing - { missingSubtree = pure - , missingKey = \_ v -> pure (Just v) } -{-# INLINE preserveMissing #-} - - --- | Map over the entries whose keys are missing from the other map. --- --- > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y --- --- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) --- --- but @mapMissing@ is somewhat faster. --- --- @since 0.5.9 -mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y -mapMissing f = WhenMissing - { missingSubtree = \m -> pure $! mapWithKey f m - , missingKey = \k x -> pure $ Just (f k x) } -{-# INLINE mapMissing #-} - - --- | Map over the entries whose keys are missing from the other --- map, optionally removing some. This is the most powerful --- 'SimpleWhenMissing' tactic, but others are usually more efficient. --- --- > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y --- --- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x)) --- --- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' --- operations. --- --- @since 0.5.9 -mapMaybeMissing - :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y -mapMaybeMissing f = WhenMissing - { missingSubtree = \m -> pure $! mapMaybeWithKey f m - , missingKey = \k x -> pure $! f k x } -{-# INLINE mapMaybeMissing #-} - - --- | Filter the entries whose keys are missing from the other map. --- --- > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x --- --- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x --- --- but this should be a little faster. --- --- @since 0.5.9 -filterMissing - :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x -filterMissing f = WhenMissing - { missingSubtree = \m -> pure $! filterWithKey f m - , missingKey = \k x -> pure $! if f k x then Just x else Nothing } -{-# INLINE filterMissing #-} - - --- | Filter the entries whose keys are missing from the other map --- using some 'Applicative' action. --- --- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $ --- > \k x -> (\b -> guard b *> Just x) <$> f k x --- --- but this should be a little faster. --- --- @since 0.5.9 -filterAMissing - :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x -filterAMissing f = WhenMissing - { missingSubtree = \m -> filterWithKeyA f m - , missingKey = \k x -> bool Nothing (Just x) <$> f k x } -{-# INLINE filterAMissing #-} - - --- | /O(n)/. Filter keys and values using an 'Applicative' predicate. -filterWithKeyA - :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a) -filterWithKeyA _ Nil = pure Nil -filterWithKeyA f t@(Tip k x) = (\b -> if b then t else Nil) <$> f k x -filterWithKeyA f (Bin p m l r) - | m < 0 = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l) - | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r) - --- | This wasn't in Data.Bool until 4.7.0, so we define it here -bool :: a -> a -> Bool -> a -bool f _ False = f -bool _ t True = t - - --- | Traverse over the entries whose keys are missing from the other --- map. --- --- @since 0.5.9 -traverseMissing - :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y -traverseMissing f = WhenMissing - { missingSubtree = traverseWithKey f - , missingKey = \k x -> Just <$> f k x } -{-# INLINE traverseMissing #-} - - --- | Traverse over the entries whose keys are missing from the other --- map, optionally producing values to put in the result. This is --- the most powerful 'WhenMissing' tactic, but others are usually --- more efficient. --- --- @since 0.5.9 -traverseMaybeMissing - :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y -traverseMaybeMissing f = WhenMissing - { missingSubtree = traverseMaybeWithKey f - , missingKey = f } -{-# INLINE traverseMaybeMissing #-} - - --- | /O(n)/. Traverse keys\/values and collect the 'Just' results. -traverseMaybeWithKey - :: Applicative f => (Key -> a -> f (Maybe b)) -> IntMap a -> f (IntMap b) -traverseMaybeWithKey f = go - where - go Nil = pure Nil - go (Tip k x) = maybe Nil (Tip k) <$> f k x - go (Bin p m l r) - | m < 0 = liftA2 (flip (bin p m)) (go r) (go l) - | otherwise = liftA2 (bin p m) (go l) (go r) - - --- | Merge two maps. --- --- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic --- and two maps. It uses the tactics to merge the maps. Its behavior --- is best understood via its fundamental tactics, 'mapMaybeMissing' --- and 'zipWithMaybeMatched'. --- --- Consider --- --- @ --- merge (mapMaybeMissing g1) --- (mapMaybeMissing g2) --- (zipWithMaybeMatched f) --- m1 m2 --- @ --- --- Take, for example, --- --- @ --- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')] --- m2 = [(1, "one"), (2, "two"), (4, "three")] --- @ --- --- 'merge' will first \"align\" these maps by key: --- --- @ --- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')] --- m2 = [(1, "one"), (2, "two"), (4, "three")] --- @ --- --- It will then pass the individual entries and pairs of entries --- to @g1@, @g2@, or @f@ as appropriate: --- --- @ --- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"] --- @ --- --- This produces a 'Maybe' for each key: --- --- @ --- keys = 0 1 2 3 4 --- results = [Nothing, Just True, Just False, Nothing, Just True] --- @ --- --- Finally, the @Just@ results are collected into a map: --- --- @ --- return value = [(1, True), (2, False), (4, True)] --- @ --- --- The other tactics below are optimizations or simplifications of --- 'mapMaybeMissing' for special cases. Most importantly, --- --- * 'dropMissing' drops all the keys. --- * 'preserveMissing' leaves all the entries alone. --- --- When 'merge' is given three arguments, it is inlined at the call --- site. To prevent excessive inlining, you should typically use --- 'merge' to define your custom combining functions. --- --- --- Examples: --- --- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f) --- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f) --- prop> differenceWith f = merge diffPreserve diffDrop f --- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing) --- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g) --- --- @since 0.5.9 -merge - :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@ - -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@ - -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@ - -> IntMap a -- ^ Map @m1@ - -> IntMap b -- ^ Map @m2@ - -> IntMap c -merge g1 g2 f m1 m2 = - runIdentity $ mergeA g1 g2 f m1 m2 -{-# INLINE merge #-} - - --- | An applicative version of 'merge'. --- --- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched' --- tactic and two maps. It uses the tactics to merge the maps. --- Its behavior is best understood via its fundamental tactics, --- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'. --- --- Consider --- --- @ --- mergeA (traverseMaybeMissing g1) --- (traverseMaybeMissing g2) --- (zipWithMaybeAMatched f) --- m1 m2 --- @ --- --- Take, for example, --- --- @ --- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')] --- m2 = [(1, "one"), (2, "two"), (4, "three")] --- @ --- --- 'mergeA' will first \"align\" these maps by key: --- --- @ --- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')] --- m2 = [(1, "one"), (2, "two"), (4, "three")] --- @ --- --- It will then pass the individual entries and pairs of entries --- to @g1@, @g2@, or @f@ as appropriate: --- --- @ --- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"] --- @ --- --- Next, it will perform the actions in the @actions@ list in order from --- left to right. --- --- @ --- keys = 0 1 2 3 4 --- results = [Nothing, Just True, Just False, Nothing, Just True] --- @ --- --- Finally, the @Just@ results are collected into a map: --- --- @ --- return value = [(1, True), (2, False), (4, True)] --- @ --- --- The other tactics below are optimizations or simplifications of --- 'traverseMaybeMissing' for special cases. Most importantly, --- --- * 'dropMissing' drops all the keys. --- * 'preserveMissing' leaves all the entries alone. --- * 'mapMaybeMissing' does not use the 'Applicative' context. --- --- When 'mergeA' is given three arguments, it is inlined at the call --- site. To prevent excessive inlining, you should generally only use --- 'mergeA' to define custom combining functions. --- --- @since 0.5.9 -mergeA - :: (Applicative f) - => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@ - -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@ - -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@ - -> IntMap a -- ^ Map @m1@ - -> IntMap b -- ^ Map @m2@ - -> f (IntMap c) -mergeA - WhenMissing{missingSubtree = g1t, missingKey = g1k} - WhenMissing{missingSubtree = g2t, missingKey = g2k} - WhenMatched{matchedKey = f} - = go - where - go t1 Nil = g1t t1 - go Nil t2 = g2t t2 - - -- This case is already covered below. - -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2 - - go (Tip k1 x1) t2' = merge2 t2' - where - merge2 t2@(Bin p2 m2 l2 r2) - | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2) - | zero k1 m2 = binA p2 m2 (merge2 l2) (g2t r2) - | otherwise = binA p2 m2 (g2t l2) (merge2 r2) - merge2 (Tip k2 x2) = mergeTips k1 x1 k2 x2 - merge2 Nil = subsingletonBy g1k k1 x1 - - go t1' (Tip k2 x2) = merge1 t1' - where - merge1 t1@(Bin p1 m1 l1 r1) - | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2) - | zero k2 m1 = binA p1 m1 (merge1 l1) (g1t r1) - | otherwise = binA p1 m1 (g1t l1) (merge1 r1) - merge1 (Tip k1 x1) = mergeTips k1 x1 k2 x2 - merge1 Nil = subsingletonBy g2k k2 x2 - - go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) - | shorter m1 m2 = merge1 - | shorter m2 m1 = merge2 - | p1 == p2 = binA p1 m1 (go l1 l2) (go r1 r2) - | otherwise = linkA p1 (g1t t1) p2 (g2t t2) - where - merge1 | nomatch p2 p1 m1 = linkA p1 (g1t t1) p2 (g2t t2) - | zero p2 m1 = binA p1 m1 (go l1 t2) (g1t r1) - | otherwise = binA p1 m1 (g1t l1) (go r1 t2) - merge2 | nomatch p1 p2 m2 = linkA p1 (g1t t1) p2 (g2t t2) - | zero p1 m2 = binA p2 m2 (go t1 l2) (g2t r2) - | otherwise = binA p2 m2 (g2t l2) (go t1 r2) - - subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x - {-# INLINE subsingletonBy #-} - - mergeTips k1 x1 k2 x2 - | k1 == k2 = maybe Nil (Tip k1) <$> f k1 x1 x2 - | k1 < k2 = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2) - {- - = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2 - -} - | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1) - {-# INLINE mergeTips #-} - - subdoubleton _ _ Nothing Nothing = Nil - subdoubleton _ k2 Nothing (Just y2) = Tip k2 y2 - subdoubleton k1 _ (Just y1) Nothing = Tip k1 y1 - subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2) - {-# INLINE subdoubleton #-} - - -- | A variant of 'link_' which makes sure to execute side-effects - -- in the right order. - linkA - :: Applicative f - => Prefix -> f (IntMap a) - -> Prefix -> f (IntMap a) - -> f (IntMap a) - linkA p1 t1 p2 t2 - | zero p1 m = binA p m t1 t2 - | otherwise = binA p m t2 t1 - where - m = branchMask p1 p2 - p = mask p1 m - {-# INLINE linkA #-} - - -- A variant of 'bin' that ensures that effects for negative keys are executed - -- first. - binA - :: Applicative f - => Prefix - -> Mask - -> f (IntMap a) - -> f (IntMap a) - -> f (IntMap a) - binA p m a b - | m < 0 = liftA2 (flip (bin p m)) b a - | otherwise = liftA2 (bin p m) a b - {-# INLINE binA #-} -{-# INLINE mergeA #-} - - -{-------------------------------------------------------------------- - Min\/Max ---------------------------------------------------------------------} - --- | /O(min(n,W))/. Update the value at the minimal key. --- --- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] --- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a -updateMinWithKey f t = - case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r) - _ -> go f t - where - go f' (Bin p m l r) = binCheckLeft p m (go f' l) r - go f' (Tip k y) = case f' k y of - Just y' -> Tip k y' - Nothing -> Nil - go _ Nil = error "updateMinWithKey Nil" - --- | /O(min(n,W))/. Update the value at the maximal key. --- --- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] --- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" - -updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a -updateMaxWithKey f t = - case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r - _ -> go f t - where - go f' (Bin p m l r) = binCheckRight p m l (go f' r) - go f' (Tip k y) = case f' k y of - Just y' -> Tip k y' - Nothing -> Nil - go _ Nil = error "updateMaxWithKey Nil" + start (IntMap Empty) = z + start (IntMap (NonEmpty min minV root)) = f min minV $! goL root $! z + goL Tip acc = acc + goL (Bin max maxV l r) acc = goL l $! goR r $! f max maxV $! acc -data View a = View {-# UNPACK #-} !Key a !(IntMap a) + goR Tip acc = acc + goR (Bin min minV l r) acc = f min minV $! goL l $! goR r $! acc --- | /O(min(n,W))/. Retrieves the maximal (key,value) pair of the map, and --- the map stripped of that element, or 'Nothing' if passed an empty map. --- --- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b") --- > maxViewWithKey empty == Nothing - -maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) -maxViewWithKey t = case t of - Nil -> Nothing - _ -> Just $ case maxViewWithKeySure t of - View k v t' -> ((k, v), t') -{-# INLINE maxViewWithKey #-} - -maxViewWithKeySure :: IntMap a -> View a -maxViewWithKeySure t = - case t of - Nil -> error "maxViewWithKeySure Nil" - Bin p m l r | m < 0 -> - case go l of View k a l' -> View k a (binCheckLeft p m l' r) - _ -> go t +-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a +foldlWithKey' f z = start where - go (Bin p m l r) = - case go r of View k a r' -> View k a (binCheckRight p m l r') - go (Tip k y) = View k y Nil - go Nil = error "maxViewWithKey_go Nil" --- See note on NOINLINE at minViewWithKeySure -{-# NOINLINE maxViewWithKeySure #-} + start (IntMap Empty) = z + start (IntMap (NonEmpty min minV root)) = s goL (s f z min minV) root --- | /O(min(n,W))/. Retrieves the minimal (key,value) pair of the map, and --- the map stripped of that element, or 'Nothing' if passed an empty map. --- --- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") --- > minViewWithKey empty == Nothing - -minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) -minViewWithKey t = - case t of - Nil -> Nothing - _ -> Just $ case minViewWithKeySure t of - View k v t' -> ((k, v), t') --- We inline this to give GHC the best possible chance of --- getting rid of the Maybe, pair, and Int constructors, as --- well as a thunk under the Just. That is, we really want to --- be certain this inlines! -{-# INLINE minViewWithKey #-} - -minViewWithKeySure :: IntMap a -> View a -minViewWithKeySure t = - case t of - Nil -> error "minViewWithKeySure Nil" - Bin p m l r | m < 0 -> - case go r of - View k a r' -> View k a (binCheckRight p m l r') - _ -> go t - where - go (Bin p m l r) = - case go l of View k a l' -> View k a (binCheckLeft p m l' r) - go (Tip k y) = View k y Nil - go Nil = error "minViewWithKey_go Nil" --- There's never anything significant to be gained by inlining --- this. Sufficiently recent GHC versions will inline the wrapper --- anyway, which should be good enough. -{-# NOINLINE minViewWithKeySure #-} - --- | /O(min(n,W))/. Update the value at the maximal key. --- --- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] --- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" + goL acc Tip = acc + goL acc (Bin max maxV l r) = s f (s goR (s goL acc l) r) max maxV -updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMax f = updateMaxWithKey (const f) + goR acc Tip = acc + goR acc (Bin min minV l r) = s goR (s goL (s f acc min minV) l) r --- | /O(min(n,W))/. Update the value at the minimal key. --- --- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] --- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" + s = ($!) -updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMin f = updateMinWithKey (const f) +-- TODO: make the conversion functions good producers --- | /O(min(n,W))/. Retrieves the maximal key of the map, and the map --- stripped of that element, or 'Nothing' if passed an empty map. -maxView :: IntMap a -> Maybe (a, IntMap a) -maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t) - --- | /O(min(n,W))/. Retrieves the minimal key of the map, and the map --- stripped of that element, or 'Nothing' if passed an empty map. -minView :: IntMap a -> Maybe (a, IntMap a) -minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t) - --- | /O(min(n,W))/. Delete and find the maximal element. --- This function throws an error if the map is empty. Use 'maxViewWithKey' --- if the map may be empty. -deleteFindMax :: IntMap a -> ((Key, a), IntMap a) -deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey - --- | /O(min(n,W))/. Delete and find the minimal element. --- This function throws an error if the map is empty. Use 'minViewWithKey' --- if the map may be empty. -deleteFindMin :: IntMap a -> ((Key, a), IntMap a) -deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey - --- | /O(min(n,W))/. The minimal key of the map. Returns 'Nothing' if the map is empty. -lookupMin :: IntMap a -> Maybe (Key, a) -lookupMin Nil = Nothing -lookupMin (Tip k v) = Just (k,v) -lookupMin (Bin _ m l r) - | m < 0 = go r - | otherwise = go l - where go (Tip k v) = Just (k,v) - go (Bin _ _ l' _) = go l' - go Nil = Nothing - --- | /O(min(n,W))/. The minimal key of the map. Calls 'error' if the map is empty. --- Use 'minViewWithKey' if the map may be empty. -findMin :: IntMap a -> (Key, a) -findMin t - | Just r <- lookupMin t = r - | otherwise = error "findMin: empty map has no minimal element" - --- | /O(min(n,W))/. The maximal key of the map. Returns 'Nothing' if the map is empty. -lookupMax :: IntMap a -> Maybe (Key, a) -lookupMax Nil = Nothing -lookupMax (Tip k v) = Just (k,v) -lookupMax (Bin _ m l r) - | m < 0 = go l - | otherwise = go r - where go (Tip k v) = Just (k,v) - go (Bin _ _ _ r') = go r' - go Nil = Nothing - --- | /O(min(n,W))/. The maximal key of the map. Calls 'error' if the map is empty. --- Use 'maxViewWithKey' if the map may be empty. -findMax :: IntMap a -> (Key, a) -findMax t - | Just r <- lookupMax t = r - | otherwise = error "findMax: empty map has no maximal element" - --- | /O(min(n,W))/. Delete the minimal key. Returns an empty map if the map is empty. --- --- Note that this is a change of behaviour for consistency with 'Data.Map.Map' – --- versions prior to 0.5 threw an error if the 'IntMap' was already empty. -deleteMin :: IntMap a -> IntMap a -deleteMin = maybe Nil snd . minView - --- | /O(min(n,W))/. Delete the maximal key. Returns an empty map if the map is empty. +-- | /O(n)/. +-- Return all elements of the map in the ascending order of their keys. +-- Subject to list fusion. -- --- Note that this is a change of behaviour for consistency with 'Data.Map.Map' – --- versions prior to 0.5 threw an error if the 'IntMap' was already empty. -deleteMax :: IntMap a -> IntMap a -deleteMax = maybe Nil snd . maxView - - -{-------------------------------------------------------------------- - Submap ---------------------------------------------------------------------} --- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). --- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). -isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool -isProperSubmapOf m1 m2 - = isProperSubmapOfBy (==) m1 m2 - -{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). - The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when - @keys m1@ and @keys m2@ are not equal, - all keys in @m1@ are in @m2@, and when @f@ returns 'True' when - applied to their respective values. For example, the following - expressions are all 'True': - - > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - - But the following are all 'False': - - > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) - > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) - > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) --} -isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool -isProperSubmapOfBy predicate t1 t2 - = case submapCmp predicate t1 t2 of - LT -> True - _ -> False - -submapCmp :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Ordering -submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) - | shorter m1 m2 = GT - | shorter m2 m1 = submapCmpLt - | p1 == p2 = submapCmpEq - | otherwise = GT -- disjoint - where - submapCmpLt | nomatch p1 p2 m2 = GT - | zero p1 m2 = submapCmp predicate t1 l2 - | otherwise = submapCmp predicate t1 r2 - submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of - (GT,_ ) -> GT - (_ ,GT) -> GT - (EQ,EQ) -> EQ - _ -> LT - -submapCmp _ (Bin _ _ _ _) _ = GT -submapCmp predicate (Tip kx x) (Tip ky y) - | (kx == ky) && predicate x y = EQ - | otherwise = GT -- disjoint -submapCmp predicate (Tip k x) t - = case lookup k t of - Just y | predicate x y -> LT - _ -> GT -- disjoint -submapCmp _ Nil Nil = EQ -submapCmp _ Nil _ = LT - --- | /O(n+m)/. Is this a submap? --- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). -isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool -isSubmapOf m1 m2 - = isSubmapOfBy (==) m1 m2 - -{- | /O(n+m)/. - The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if - all keys in @m1@ are in @m2@, and when @f@ returns 'True' when - applied to their respective values. For example, the following - expressions are all 'True': - - > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) - - But the following are all 'False': +-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"] +-- > elems empty == [] +elems :: IntMap a -> [a] +elems = foldr (:) [] - > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)]) - > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) - > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) --} -isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool -isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) - | shorter m1 m2 = False - | shorter m2 m1 = match p1 p2 m2 && - if zero p1 m2 - then isSubmapOfBy predicate t1 l2 - else isSubmapOfBy predicate t1 r2 - | otherwise = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2 -isSubmapOfBy _ (Bin _ _ _ _) _ = False -isSubmapOfBy predicate (Tip k x) t = case lookup k t of - Just y -> predicate x y - Nothing -> False -isSubmapOfBy _ Nil _ = True - -{-------------------------------------------------------------------- - Mapping ---------------------------------------------------------------------} --- | /O(n)/. Map a function over all values in the map. +-- | /O(n)/. Return all keys of the map in ascending order. Subject to list +-- fusion. -- --- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] +-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] +-- > keys empty == [] +keys :: IntMap a -> [Key] +keys = foldrWithKey (\k _ l -> k : l) [] -map :: (a -> b) -> IntMap a -> IntMap b -map f = go - where - go (Bin p m l r) = Bin p m (go l) (go r) - go (Tip k x) = Tip k (f x) - go Nil = Nil - -#ifdef __GLASGOW_HASKELL__ -{-# NOINLINE [1] map #-} -{-# RULES -"map/map" forall f g xs . map f (map g xs) = map (f . g) xs - #-} -#endif -#if __GLASGOW_HASKELL__ >= 709 --- Safe coercions were introduced in 7.8, but did not play well with RULES yet. -{-# RULES -"map/coerce" map coerce = coerce - #-} -#endif - --- | /O(n)/. Map a function over all values in the map. +-- | /O(n)/. An alias for 'toAscList'. Returns all key\/value pairs in the +-- map in ascending key order. Subject to list fusion. -- --- > let f key x = (show key) ++ ":" ++ x --- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] - -mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b -mapWithKey f t - = case t of - Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r) - Tip k x -> Tip k (f k x) - Nil -> Nil - -#ifdef __GLASGOW_HASKELL__ -{-# NOINLINE [1] mapWithKey #-} -{-# RULES -"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) = - mapWithKey (\k a -> f k (g k a)) xs -"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) = - mapWithKey (\k a -> f k (g a)) xs -"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) = - mapWithKey (\k a -> f (g k a)) xs - #-} -#endif +-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] +-- > assocs empty == [] +assocs :: IntMap a -> [(Key, a)] +assocs = toAscList --- | /O(n)/. --- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ --- That is, behaves exactly like a regular 'traverse' except that the traversing --- function also has access to the key associated with a value. --- --- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) --- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing -traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b) -traverseWithKey f = go - where - go Nil = pure Nil - go (Tip k v) = Tip k <$> f k v - go (Bin p m l r) - | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l) - | otherwise = liftA2 (Bin p m) (go l) (go r) -{-# INLINE traverseWithKey #-} - --- | /O(n)/. The function @'mapAccum'@ threads an accumulating --- argument through the map in ascending order of keys. +-- | /O(n*min(n,W))/. The set of all keys of the map. -- --- > let f a b = (a ++ b, b ++ "X") --- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) +-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5] +-- > keysSet empty == Data.IntSet.empty +keysSet :: IntMap a -> Data.IntSet.IntSet +keysSet = Data.IntSet.fromDistinctAscList . keys -mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) -mapAccum f = mapAccumWithKey (\a' _ x -> f a' x) +-- | /O(n)/. Convert the map to a list of key\/value pairs. +toList :: IntMap a -> [(Key, a)] +toList = toAscList --- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") --- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) - -mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) -mapAccumWithKey f a t - = mapAccumL f a t - --- | /O(n)/. The function @'mapAccumL'@ threads an accumulating --- argument through the map in ascending order of keys. -mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) -mapAccumL f a t - = case t of - Bin p m l r - | m < 0 -> - let (a1,r') = mapAccumL f a r - (a2,l') = mapAccumL f a1 l - in (a2,Bin p m l' r') - | otherwise -> - let (a1,l') = mapAccumL f a l - (a2,r') = mapAccumL f a1 r - in (a2,Bin p m l' r') - Tip k x -> let (a',x') = f a k x in (a',Tip k x') - Nil -> (a,Nil) - --- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating --- argument through the map in descending order of keys. -mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) -mapAccumRWithKey f a t - = case t of - Bin p m l r - | m < 0 -> - let (a1,l') = mapAccumRWithKey f a l - (a2,r') = mapAccumRWithKey f a1 r - in (a2,Bin p m l' r') - | otherwise -> - let (a1,r') = mapAccumRWithKey f a r - (a2,l') = mapAccumRWithKey f a1 l - in (a2,Bin p m l' r') - Tip k x -> let (a',x') = f a k x in (a',Tip k x') - Nil -> (a,Nil) - --- | /O(n*min(n,W))/. --- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the value at the greatest of the --- original keys is retained. +-- | /O(n)/. Convert the map to a list of key\/value pairs where the +-- keys are in ascending order. Subject to list fusion. -- --- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] --- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" --- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" - -mapKeys :: (Key->Key) -> IntMap a -> IntMap a -mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) [] +-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] +toAscList :: IntMap a -> [(Key, a)] +toAscList = foldrWithKey (\k v l -> (k, v) : l) [] --- | /O(n*min(n,W))/. --- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the associated values will be --- combined using @c@. --- --- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" --- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" - -mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a -mapKeysWith c f - = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] - --- | /O(n*min(n,W))/. --- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ --- is strictly monotonic. --- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. --- /The precondition is not checked./ --- Semi-formally, we have: --- --- > and [x < y ==> f x < f y | x <- ls, y <- ls] --- > ==> mapKeysMonotonic f s == mapKeys f s --- > where ls = keys s --- --- This means that @f@ maps distinct original keys to distinct resulting keys. --- This function has slightly better performance than 'mapKeys'. +-- | /O(n)/. Convert the map to a list of key\/value pairs where the keys +-- are in descending order. Subject to list fusion. -- --- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] - -mapKeysMonotonic :: (Key->Key) -> IntMap a -> IntMap a -mapKeysMonotonic f - = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) [] +-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")] +toDescList :: IntMap a -> [(Key, a)] +toDescList = foldlWithKey (\l k v -> (k, v) : l) [] -{-------------------------------------------------------------------- - Filter ---------------------------------------------------------------------} -- | /O(n)/. Filter all values that satisfy some predicate. -- -- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty -- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty - filter :: (a -> Bool) -> IntMap a -> IntMap a -filter p m - = filterWithKey (\_ x -> p x) m +filter p = filterWithKey (const p) -- | /O(n)/. Filter all keys\/values that satisfy some predicate. -- -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a -filterWithKey predicate = go - where - go Nil = Nil - go t@(Tip k x) = if predicate k x then t else Nil - go (Bin p m l r) = bin p m (go l) (go r) +filterWithKey p = start + where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) + | p min minV = IntMap (NonEmpty min minV (goL root)) + | otherwise = IntMap (goDeleteL root) + + goL Tip = Tip + goL (Bin max maxV l r) + | p max maxV = Bin max maxV (goL l) (goR r) + | otherwise = case goDeleteR r of + Empty -> goL l + NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' + + goR Tip = Tip + goR (Bin min minV l r) + | p min minV = Bin min minV (goL l) (goR r) + | otherwise = case goDeleteL l of + Empty -> goR r + NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) + + goDeleteL Tip = Empty + goDeleteL (Bin max maxV l r) + | p max maxV = case goDeleteL l of + Empty -> case goR r of + Tip -> NonEmpty max maxV Tip + Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) + NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV l' (goR r)) + | otherwise = binL (goDeleteL l) (goDeleteR r) + + goDeleteR Tip = Empty + goDeleteR (Bin min minV l r) + | p min minV = case goDeleteR r of + Empty -> case goL l of + Tip -> NonEmpty min minV Tip + Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) + NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV (goL l) r') + | otherwise = binR (goDeleteL l) (goDeleteR r) + +-- | /O(n+m)/. The restriction of a map to the keys in a set. +-- +-- @ +-- m `restrictKeys` s = 'filterWithKey' (\k _ -> k `'IntSet.member'` s) m +-- @ +-- +-- @since 0.5.8 +restrictKeys :: IntMap a -> Data.IntSet.IntSet -> IntMap a +restrictKeys m s = filterWithKey (\k _ -> Data.IntSet.member k s) m + +-- | Remove all the keys in a given set from a map. +-- +-- @ +-- m `withoutKeys` s = 'filterWithKey' (\k _ -> k `'IntSet.notMember'` s) m +-- @ +-- +-- @since 0.5.8 +withoutKeys :: IntMap a -> Data.IntSet.IntSet -> IntMap a +withoutKeys m s = filterWithKey (\k _ -> Data.IntSet.notMember k s) m -- | /O(n)/. Partition the map according to some predicate. The first -- map contains all elements that satisfy the predicate, the second all @@ -2609,10 +1185,8 @@ filterWithKey predicate = go -- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") -- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) -- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) - -partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a) -partition p m - = partitionWithKey (\_ x -> p x) m +partition :: (a -> Bool) -> IntMap a -> (IntMap a, IntMap a) +partition p = partitionWithKey (const p) -- | /O(n)/. Partition the map according to some predicate. The first -- map contains all elements that satisfy the predicate, the second all @@ -2621,76 +1195,77 @@ partition p m -- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b") -- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) - -partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a) -partitionWithKey predicate0 t0 = toPair $ go predicate0 t0 - where - go predicate t = - case t of - Bin p m l r -> - let (l1 :*: l2) = go predicate l - (r1 :*: r2) = go predicate r - in bin p m l1 r1 :*: bin p m l2 r2 - Tip k x - | predicate k x -> (t :*: Nil) - | otherwise -> (Nil :*: t) - Nil -> (Nil :*: Nil) - --- | /O(n)/. Map values and collect the 'Just' results. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" - -mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b -mapMaybe f = mapMaybeWithKey (\_ x -> f x) - --- | /O(n)/. Map keys\/values and collect the 'Just' results. --- --- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing --- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" - -mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b -mapMaybeWithKey f (Bin p m l r) - = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r) -mapMaybeWithKey f (Tip k x) = case f k x of - Just y -> Tip k y - Nothing -> Nil -mapMaybeWithKey _ Nil = Nil - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. --- --- > let f a = if a < "c" then Left a else Right a --- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) --- > --- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) - -mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) -mapEither f m - = mapEitherWithKey (\_ x -> f x) m - --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. --- --- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) --- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) --- > --- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) - -mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) -mapEitherWithKey f0 t0 = toPair $ go f0 t0 +partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a, IntMap a) +partitionWithKey p = start where - go f (Bin p m l r) = - bin p m l1 r1 :*: bin p m l2 r2 - where - (l1 :*: l2) = go f l - (r1 :*: r2) = go f r - go f (Tip k x) = case f k x of - Left y -> (Tip k y :*: Nil) - Right z -> (Nil :*: Tip k z) - go _ Nil = (Nil :*: Nil) + start (IntMap Empty) = (IntMap Empty, IntMap Empty) + start (IntMap (NonEmpty min minV root)) + | p min minV = let SP t f = goTrueL root + in (IntMap (NonEmpty min minV t), IntMap f) + | otherwise = let SP t f = goFalseL root + in (IntMap t, IntMap (NonEmpty min minV f)) + + goTrueL Tip = SP Tip Empty + goTrueL (Bin max maxV l r) + | p max maxV = let SP tl fl = goTrueL l + SP tr fr = goTrueR r + in SP (Bin max maxV tl tr) (binL fl fr) + | otherwise = let SP tl fl = goTrueL l + SP tr fr = goFalseR r + t = case tr of + Empty -> tl + NonEmpty max' maxV' r' -> Bin max' maxV' tl r' + f = case fl of + Empty -> r2lMap $ NonEmpty max maxV fr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' fr) + in SP t f + + goTrueR Tip = SP Tip Empty + goTrueR (Bin min minV l r) + | p min minV = let SP tl fl = goTrueL l + SP tr fr = goTrueR r + in SP (Bin min minV tl tr) (binR fl fr) + | otherwise = let SP tl fl = goFalseL l + SP tr fr = goTrueR r + t = case tl of + Empty -> tr + NonEmpty min' minV' l' -> Bin min' minV' l' tr + f = case fr of + Empty -> l2rMap $ NonEmpty min minV fl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV fl r') + in SP t f + + goFalseL Tip = SP Empty Tip + goFalseL (Bin max maxV l r) + | p max maxV = let SP tl fl = goFalseL l + SP tr fr = goTrueR r + t = case tl of + Empty -> r2lMap $ NonEmpty max maxV tr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' tr) + f = case fr of + Empty -> fl + NonEmpty max' maxV' r' -> Bin max' maxV' fl r' + in SP t f + | otherwise = let SP tl fl = goFalseL l + SP tr fr = goFalseR r + in SP (binL tl tr) (Bin max maxV fl fr) + + goFalseR Tip = SP Empty Tip + goFalseR (Bin min minV l r) + | p min minV = let SP tl fl = goTrueL l + SP tr fr = goFalseR r + t = case tr of + Empty -> l2rMap $ NonEmpty min minV tl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV tl r') + f = case fl of + Empty -> fr + NonEmpty min' minV' l' -> Bin min' minV' l' fr + in SP t f + | otherwise = let SP tl fl = goFalseL l + SP tr fr = goFalseR r + in SP (binR tl tr) (Bin min minV fl fr) + +data SP a b = SP !a !b -- | /O(min(n,W))/. The expression (@'split' k map@) is a pair @(map1,map2)@ -- where all keys in @map1@ are lower than @k@ and all keys in @@ -2701,35 +1276,9 @@ mapEitherWithKey f0 t0 = toPair $ go f0 t0 -- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a") -- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty) -- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty) - split :: Key -> IntMap a -> (IntMap a, IntMap a) -split k t = - case t of - Bin _ m l r - | m < 0 -> - if k >= 0 -- handle negative numbers. - then - case go k l of - (lt :*: gt) -> - let !lt' = union r lt - in (lt', gt) - else - case go k r of - (lt :*: gt) -> - let !gt' = union gt l - in (lt, gt') - _ -> case go k t of - (lt :*: gt) -> (lt, gt) - where - go k' t'@(Bin p m l r) - | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t' - | zero k' m = case go k' l of (lt :*: gt) -> lt :*: union gt r - | otherwise = case go k' r of (lt :*: gt) -> union l lt :*: gt - go k' t'@(Tip ky _) - | k' > ky = (t' :*: Nil) - | k' < ky = (Nil :*: t') - | otherwise = (Nil :*: Nil) - go _ Nil = (Nil :*: Nil) +split k m = case splitLookup k m of + (lt, _, gt) -> (lt, gt) data SplitLookup a = SplitLookup !(IntMap a) !(Maybe a) !(IntMap a) @@ -2750,800 +1299,529 @@ mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt) -- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a") -- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty) -- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty) - splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a) -splitLookup k t = - case - case t of - Bin _ m l r - | m < 0 -> - if k >= 0 -- handle negative numbers. - then mapLT (union r) (go k l) - else mapGT (`union` l) (go k r) - _ -> go k t - of SplitLookup lt fnd gt -> (lt, fnd, gt) - where - go k' t'@(Bin p m l r) - | nomatch k' p m = - if k' > p - then SplitLookup t' Nothing Nil - else SplitLookup Nil Nothing t' - | zero k' m = mapGT (`union` r) (go k' l) - | otherwise = mapLT (union l) (go k' r) - go k' t'@(Tip ky y) - | k' > ky = SplitLookup t' Nothing Nil - | k' < ky = SplitLookup Nil Nothing t' - | otherwise = SplitLookup Nil (Just y) Nil - go _ Nil = SplitLookup Nil Nothing Nil - -{-------------------------------------------------------------------- - Fold ---------------------------------------------------------------------} --- | /O(n)/. Fold the values in the map using the given right-associative --- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. --- --- For example, --- --- > elems map = foldr (:) [] map --- --- > let f a len = len + (length a) --- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 -foldr :: (a -> b -> b) -> b -> IntMap a -> b -foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only. - case t of - Bin _ m l r - | m < 0 -> go (go z l) r -- put negative numbers before - | otherwise -> go (go z r) l - _ -> go z t - where - go z' Nil = z' - go z' (Tip _ x) = f x z' - go z' (Bin _ _ l r) = go (go z' r) l -{-# INLINE foldr #-} - --- | /O(n)/. A strict version of 'foldr'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldr' :: (a -> b -> b) -> b -> IntMap a -> b -foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only. - case t of - Bin _ m l r - | m < 0 -> go (go z l) r -- put negative numbers before - | otherwise -> go (go z r) l - _ -> go z t - where - go !z' Nil = z' - go z' (Tip _ x) = f x z' - go z' (Bin _ _ l r) = go (go z' r) l -{-# INLINE foldr' #-} - --- | /O(n)/. Fold the values in the map using the given left-associative --- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. --- --- For example, --- --- > elems = reverse . foldl (flip (:)) [] --- --- > let f len a = len + (length a) --- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 -foldl :: (a -> b -> a) -> a -> IntMap b -> a -foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only. - case t of - Bin _ m l r - | m < 0 -> go (go z r) l -- put negative numbers before - | otherwise -> go (go z l) r - _ -> go z t - where - go z' Nil = z' - go z' (Tip _ x) = f z' x - go z' (Bin _ _ l r) = go (go z' l) r -{-# INLINE foldl #-} - --- | /O(n)/. A strict version of 'foldl'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldl' :: (a -> b -> a) -> a -> IntMap b -> a -foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only. - case t of - Bin _ m l r - | m < 0 -> go (go z r) l -- put negative numbers before - | otherwise -> go (go z l) r - _ -> go z t - where - go !z' Nil = z' - go z' (Tip _ x) = f z' x - go z' (Bin _ _ l r) = go (go z' l) r -{-# INLINE foldl' #-} - --- | /O(n)/. Fold the keys and values in the map using the given right-associative --- binary operator, such that --- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. --- --- For example, --- --- > keys map = foldrWithKey (\k x ks -> k:ks) [] map --- --- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" --- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" -foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b -foldrWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only. - case t of - Bin _ m l r - | m < 0 -> go (go z l) r -- put negative numbers before - | otherwise -> go (go z r) l - _ -> go z t - where - go z' Nil = z' - go z' (Tip kx x) = f kx x z' - go z' (Bin _ _ l r) = go (go z' r) l -{-# INLINE foldrWithKey #-} - --- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b -foldrWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only. - case t of - Bin _ m l r - | m < 0 -> go (go z l) r -- put negative numbers before - | otherwise -> go (go z r) l - _ -> go z t - where - go !z' Nil = z' - go z' (Tip kx x) = f kx x z' - go z' (Bin _ _ l r) = go (go z' r) l -{-# INLINE foldrWithKey' #-} - --- | /O(n)/. Fold the keys and values in the map using the given left-associative --- binary operator, such that --- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. --- --- For example, --- --- > keys = reverse . foldlWithKey (\ks k x -> k:ks) [] --- --- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" --- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)" -foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a -foldlWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only. - case t of - Bin _ m l r - | m < 0 -> go (go z r) l -- put negative numbers before - | otherwise -> go (go z l) r - _ -> go z t - where - go z' Nil = z' - go z' (Tip kx x) = f z' kx x - go z' (Bin _ _ l r) = go (go z' l) r -{-# INLINE foldlWithKey #-} - --- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a -foldlWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only. - case t of - Bin _ m l r - | m < 0 -> go (go z r) l -- put negative numbers before - | otherwise -> go (go z l) r - _ -> go z t +splitLookup k = k `seq` start where - go !z' Nil = z' - go z' (Tip kx x) = f z' kx x - go z' (Bin _ _ l r) = go (go z' l) r -{-# INLINE foldlWithKey' #-} - --- | /O(n)/. Fold the keys and values in the map using the given monoid, such that + start (IntMap Empty) = (IntMap Empty, Nothing, IntMap Empty) + start m@(IntMap (NonEmpty min minV root)) + | k > min = case root of + Tip -> (m, Nothing, IntMap Empty) + Bin max maxV l r | k < max -> let (DR glb glbV lt, eq, DR lub lubV gt) = go (xor min k) min minV (xor k max) max maxV l r + in (IntMap (r2lMap (NonEmpty glb glbV lt)), eq, IntMap (NonEmpty lub lubV gt)) + | k > max -> (m, Nothing, IntMap Empty) + | otherwise -> let DR max' maxV' root' = deleteMaxR min minV l r + in (IntMap (r2lMap (NonEmpty max' maxV' root')), Just maxV, IntMap Empty) + + | k < min = (IntMap Empty, Nothing, m) + | otherwise = case root of + Tip -> (IntMap Empty, Just minV, IntMap Empty) + Bin max maxV l r -> let DR min' minV' root' = deleteMinL max maxV l r + in (IntMap Empty, Just minV, IntMap (NonEmpty min' minV' root')) + + go xorCacheMin min minV xorCacheMax max maxV l r + | xorCacheMin < xorCacheMax = case l of + Tip -> (DR min minV Tip, Nothing, r2lDR (DR max maxV r)) + Bin maxI maxVI lI rI + | k < maxI -> let (lt, eq, DR minI minVI gt) = go xorCacheMin min minV (xor k maxI) maxI maxVI lI rI + in (lt, eq, DR minI minVI (Bin max maxV gt r)) + | k > maxI -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) + | otherwise -> (deleteMaxR min minV lI rI, Just maxVI, r2lDR (DR max maxV r)) + | otherwise = case r of + Tip -> (l2rDR (DR min minV l), Nothing, DR max maxV Tip) + Bin minI minVI lI rI + | k > minI -> let (DR maxI maxVI lt, eq, gt) = go (xor minI k) minI minVI xorCacheMax max maxV lI rI + in (DR maxI maxVI (Bin min minV l lt), eq, gt) + | k < minI -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) + | otherwise -> (l2rDR (DR min minV l), Just minVI, deleteMinL max maxV lI rI) + +-- | /O(1)/. Decompose a map into pieces based on the structure of the underlying +-- tree. This function is useful for consuming a map in parallel. -- --- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@ +-- No guarantee is made as to the sizes of the pieces; an internal, but +-- deterministic process determines this. However, it is guaranteed that the +-- pieces returned will be in ascending order (all elements in the first submap +-- less than all elements in the second, and so on). -- --- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids. +-- Examples: -- --- @since 0.5.4 -foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m -foldMapWithKey f = go - where - go Nil = mempty - go (Tip kx x) = f kx x - go (Bin _ m l r) - | m < 0 = go r `mappend` go l - | otherwise = go l `mappend` go r -{-# INLINE foldMapWithKey #-} - -{-------------------------------------------------------------------- - List variations ---------------------------------------------------------------------} --- | /O(n)/. --- Return all elements of the map in the ascending order of their keys. --- Subject to list fusion. +-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) == +-- > [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]] -- --- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"] --- > elems empty == [] - -elems :: IntMap a -> [a] -elems = foldr (:) [] - --- | /O(n)/. Return all keys of the map in ascending order. Subject to list --- fusion. +-- > splitRoot empty == [] -- --- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] --- > keys empty == [] - -keys :: IntMap a -> [Key] -keys = foldrWithKey (\k _ ks -> k : ks) [] +-- Note that the current implementation does not return more than two submaps, +-- but you should not depend on this behaviour because it can change in the +-- future without notice. +{-# INLINE splitRoot #-} +splitRoot :: IntMap a -> [IntMap a] +splitRoot (IntMap Empty) = [] +splitRoot m@(IntMap (NonEmpty _ _ Tip)) = [m] +splitRoot (IntMap (NonEmpty min minV (Bin max maxV l r))) = [IntMap (NonEmpty min minV l), IntMap (r2lMap (NonEmpty max maxV r))] --- | /O(n)/. An alias for 'toAscList'. Returns all key\/value pairs in the --- map in ascending key order. Subject to list fusion. --- --- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] --- > assocs empty == [] +-- | /O(n+m)/. Is this a submap? +-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). +isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool +isSubmapOf = isSubmapOfBy (==) -assocs :: IntMap a -> [(Key,a)] -assocs = toAscList +{- | /O(n+m)/. + The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if + all keys in @m1@ are in @m2@, and when @f@ returns 'True' when + applied to their respective values. For example, the following + expressions are all 'True': --- | /O(n*min(n,W))/. The set of all keys of the map. --- --- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5] --- > keysSet empty == Data.IntSet.empty + > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) -keysSet :: IntMap a -> IntSet.IntSet -keysSet Nil = IntSet.Nil -keysSet (Tip kx _) = IntSet.singleton kx -keysSet (Bin p m l r) - | m .&. IntSet.suffixBitMask == 0 = IntSet.Bin p m (keysSet l) (keysSet r) - | otherwise = IntSet.Tip (p .&. IntSet.prefixBitMask) (computeBm (computeBm 0 l) r) - where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r' - computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx - computeBm _ Nil = error "Data.IntSet.keysSet: Nil" - --- | /O(n)/. Build a map from a set of keys and a function which for each key --- computes its value. --- --- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] --- > fromSet undefined Data.IntSet.empty == empty + But the following are all 'False': -fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a -fromSet _ IntSet.Nil = Nil -fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r) -fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) + > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)]) + > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) + > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) +-} +isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool +isSubmapOfBy p = start where - -- This is slightly complicated, as we to convert the dense - -- representation of IntSet into tree representation of IntMap. - -- - -- We are given a nonzero bit mask 'bmask' of 'bits' bits with - -- prefix 'prefix'. We split bmask into halves corresponding - -- to left and right subtree. If they are both nonempty, we - -- create a Bin node, otherwise exactly one of them is nonempty - -- and we construct the IntMap from that half. - buildTree g !prefix !bmask bits = case bits of - 0 -> Tip prefix (g prefix) - _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of - bits2 - | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 -> - buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2 - | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 -> - buildTree g prefix bmask bits2 - | otherwise -> - Bin prefix bits2 - (buildTree g prefix bmask bits2) - (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) - -{-------------------------------------------------------------------- - Lists ---------------------------------------------------------------------} -#if __GLASGOW_HASKELL__ >= 708 --- | @since 0.5.6.2 -instance GHCExts.IsList (IntMap a) where - type Item (IntMap a) = (Key,a) - fromList = fromList - toList = toList -#endif - --- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list --- fusion. --- --- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] --- > toList empty == [] + start (IntMap Empty) !_ = True + start !_ (IntMap Empty) = False + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = False + | min1 > min2 = goL minV1 min1 root1 min2 root2 + | otherwise = p minV1 minV2 && goLFused min1 root1 root2 + + goL minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL _ _ _ _ Tip = False + goL minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 (Bin max2 maxV2 l2 r2) + | max1 > max2 = False + | max1 < max2 = case xor min1 max1 `ltMSB` xor min2 max2 of + True | xor min2 min1 < xor min1 max2 -> goL minV1 min1 n1 min2 l2 -- LT + | otherwise -> goR maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ + | otherwise = p maxV1 maxV2 && case xor min1 max1 `ltMSB` xor min2 max1 of + True -> goRFused max1 (Bin min1 minV1 l1 r1) r2 -- LT + False -> goL minV1 min1 l1 min2 l2 && goRFused max1 r1 r2 -- EQ + + goLFused _ Tip _ = True + goLFused _ _ Tip = False + goLFused min n1@(Bin max1 maxV1 l1 r1) (Bin max2 maxV2 l2 r2) + | max1 > max2 = False + | max1 < max2 = case xor min max1 `ltMSB` xor min max2 of + True -> goLFused min n1 l2 + False -> goLFused min l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ + | otherwise = p maxV1 maxV2 && goLFused min l1 l2 && goRFused max1 r1 r2 + + goR maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR _ _ _ _ Tip = False + goR maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 (Bin min2 minV2 l2 r2) + | min1 < min2 = False + | min1 > min2 = case xor min1 max1 `ltMSB` xor min2 max2 of + True | xor min2 max1 > xor max1 max2 -> goR maxV1 max1 n1 max2 r2 -- LT + | otherwise -> goL minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ + | otherwise = p minV1 minV2 && case xor min1 max1 `ltMSB` xor min2 max1 of + True -> goLFused min1 (Bin max1 maxV1 l1 r1) l2 -- LT + False -> goLFused min1 l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ + + goRFused _ Tip _ = True + goRFused _ _ Tip = False + goRFused max n1@(Bin min1 minV1 l1 r1) (Bin min2 minV2 l2 r2) + | min1 < min2 = False + | min1 > min2 = case xor min1 max `ltMSB` xor min2 max of + True -> goRFused max n1 r2 + False -> goL minV1 min1 l1 min2 l2 && goRFused max r1 r2 -- EQ + | otherwise = p minV1 minV2 && goLFused min1 l1 l2 && goRFused max r1 r2 + + goLookupL _ _ !_ Tip = False + goLookupL k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL k v xorCache l + else goLookupR k v xorCacheMax r + | k > max = False + | otherwise = p v maxV + where xorCacheMax = xor k max + + goLookupR _ _ !_ Tip = False + goLookupR k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR k v xorCache r + else goLookupL k v xorCacheMin l + | k < min = False + | otherwise = p v minV + where xorCacheMin = xor min k -toList :: IntMap a -> [(Key,a)] -toList = toAscList +-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). +isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool +isProperSubmapOf = isProperSubmapOfBy (==) --- | /O(n)/. Convert the map to a list of key\/value pairs where the --- keys are in ascending order. Subject to list fusion. --- --- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] +{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when +@m1@ and @m2@ are not equal, +all keys in @m1@ are in @m2@, and when @f@ returns 'True' when +applied to their respective values. For example, the following +expressions are all 'True': -toAscList :: IntMap a -> [(Key,a)] -toAscList = foldrWithKey (\k x xs -> (k,x):xs) [] +> isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) +> isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) --- | /O(n)/. Convert the map to a list of key\/value pairs where the keys --- are in descending order. Subject to list fusion. --- --- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")] +But the following are all 'False': -toDescList :: IntMap a -> [(Key,a)] -toDescList = foldlWithKey (\xs k x -> (k,x):xs) [] - --- List fusion for the list generating functions. -#if __GLASGOW_HASKELL__ --- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion. --- They are important to convert unfused methods back, see mapFB in prelude. -foldrFB :: (Key -> a -> b -> b) -> b -> IntMap a -> b -foldrFB = foldrWithKey -{-# INLINE[0] foldrFB #-} -foldlFB :: (a -> Key -> b -> a) -> a -> IntMap b -> a -foldlFB = foldlWithKey -{-# INLINE[0] foldlFB #-} - --- Inline assocs and toList, so that we need to fuse only toAscList. -{-# INLINE assocs #-} -{-# INLINE toList #-} - --- The fusion is enabled up to phase 2 included. If it does not succeed, --- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to --- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were --- used in a list fusion, otherwise it would go away in phase 1), and let compiler --- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to --- inline it before phase 0, otherwise the fusion rules would not fire at all. -{-# NOINLINE[0] elems #-} -{-# NOINLINE[0] keys #-} -{-# NOINLINE[0] toAscList #-} -{-# NOINLINE[0] toDescList #-} -{-# RULES "IntMap.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-} -{-# RULES "IntMap.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-} -{-# RULES "IntMap.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-} -{-# RULES "IntMap.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-} -{-# RULES "IntMap.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-} -{-# RULES "IntMap.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-} -{-# RULES "IntMap.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-} -{-# RULES "IntMap.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-} -#endif - - --- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. --- --- > fromList [] == empty --- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] --- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] +> isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) +> isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) +> isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) +-} +isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool +isProperSubmapOfBy p m1 m2 = submapCmp p m1 m2 == LT -fromList :: [(Key,a)] -> IntMap a -fromList xs - = Foldable.foldl' ins empty xs +submapCmp :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Ordering +submapCmp p = start where - ins t (k,x) = insert k x t - --- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. --- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] --- > fromListWith (++) [] == empty - -fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a -fromListWith f xs - = fromListWithKey (\_ x y -> f x y) xs - --- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] --- > fromListWithKey f [] == empty + start (IntMap Empty) (IntMap Empty) = EQ + start (IntMap Empty) !_ = LT + start !_ (IntMap Empty) = GT + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = GT + | min1 > min2 = fromBool $ goL minV1 min1 root1 min2 root2 + | p minV1 minV2 = goLFused min1 root1 root2 + | otherwise = GT + + goL minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL _ _ _ _ Tip = False + goL minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 (Bin max2 maxV2 l2 r2) + | max1 > max2 = False + | max1 < max2 = case xor min1 max1 `ltMSB` xor min2 max2 of + True | xor min2 min1 < xor min1 max2 -> goL minV1 min1 n1 min2 l2 -- LT + | otherwise -> goR maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ + | otherwise = p maxV1 maxV2 && case xor min1 max1 `ltMSB` xor min2 max1 of + True -> goRFusedBool max1 (Bin min1 minV1 l1 r1) r2 -- LT + False -> goL minV1 min1 l1 min2 l2 && goRFusedBool max1 r1 r2 -- EQ + + goLFused _ Tip Tip = EQ + goLFused _ Tip _ = LT + goLFused _ _ Tip = GT + goLFused min n1@(Bin max1 maxV1 l1 r1) (Bin max2 maxV2 l2 r2) + | max1 > max2 = GT + | max1 < max2 = fromBool $ case xor min max1 `ltMSB` xor min max2 of + True -> goLFusedBool min n1 l2 + False -> goLFusedBool min l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ + | p maxV1 maxV2 = goLFused min l1 l2 `combine` goRFused max1 r1 r2 + | otherwise = GT + + goLFusedBool _ Tip _ = True + goLFusedBool _ _ Tip = False + goLFusedBool min n1@(Bin max1 maxV1 l1 r1) (Bin max2 maxV2 l2 r2) + | max1 > max2 = False + | max1 < max2 = case xor min max1 `ltMSB` xor min max2 of + True -> goLFusedBool min n1 l2 + False -> goLFusedBool min l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ + | otherwise = p maxV1 maxV2 && goLFusedBool min l1 l2 && goRFusedBool max1 r1 r2 + + goR maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR _ _ _ _ Tip = False + goR maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 (Bin min2 minV2 l2 r2) + | min1 < min2 = False + | min1 > min2 = case xor min1 max1 `ltMSB` xor min2 max2 of + True | xor min2 max1 > xor max1 max2 -> goR maxV1 max1 n1 max2 r2 -- LT + | otherwise -> goL minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ + | otherwise = p minV1 minV2 && case xor min1 max1 `ltMSB` xor min2 max1 of + True -> goLFusedBool min1 (Bin max1 maxV1 l1 r1) l2 -- LT + False -> goLFusedBool min1 l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ + + goRFused _ Tip Tip = EQ + goRFused _ Tip _ = LT + goRFused _ _ Tip = GT + goRFused max n1@(Bin min1 minV1 l1 r1) (Bin min2 minV2 l2 r2) + | min1 < min2 = GT + | min1 > min2 = fromBool $ case xor min1 max `ltMSB` xor min2 max of + True -> goRFusedBool max n1 r2 + False -> goL minV1 min1 l1 min2 l2 && goRFusedBool max r1 r2 -- EQ + | p minV1 minV2 = goLFused min1 l1 l2 `combine` goRFused max r1 r2 + | otherwise = GT + + goRFusedBool _ Tip _ = True + goRFusedBool _ _ Tip = False + goRFusedBool max n1@(Bin min1 minV1 l1 r1) (Bin min2 minV2 l2 r2) + | min1 < min2 = False + | min1 > min2 = case xor min1 max `ltMSB` xor min2 max of + True -> goRFusedBool max n1 r2 + False -> goL minV1 min1 l1 min2 l2 && goRFusedBool max r1 r2 -- EQ + | otherwise = p minV1 minV2 && goLFusedBool min1 l1 l2 && goRFusedBool max r1 r2 + + goLookupL _ _ !_ Tip = False + goLookupL k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL k v xorCache l + else goLookupR k v xorCacheMax r + | k > max = False + | otherwise = p v maxV + where xorCacheMax = xor k max + + goLookupR _ _ !_ Tip = False + goLookupR k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR k v xorCache r + else goLookupL k v xorCacheMin l + | k < min = False + | otherwise = p v minV + where xorCacheMin = xor min k + + fromBool True = LT + fromBool False = GT + + combine GT _ = GT + combine _ GT = GT + combine EQ EQ = EQ + combine _ _ = LT + +-- | /O(1)/. The minimal key of the map. +findMin :: IntMap a -> (Key, a) +findMin (IntMap Empty) = error "findMin: empty map has no minimal element" +findMin (IntMap (NonEmpty min minV _)) = (min, minV) -fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromListWithKey f xs - = Foldable.foldl' ins empty xs - where - ins t (k,x) = insertWithKey f k x t +-- | /O(1)/. The maximal key of the map. +findMax :: IntMap a -> (Key, a) +findMax (IntMap Empty) = error "findMin: empty map has no minimal element" +findMax (IntMap (NonEmpty min minV root)) = case root of + Tip -> (min, minV) + Bin max maxV _ _ -> (max, maxV) --- | /O(n)/. Build a map from a list of key\/value pairs where --- the keys are in ascending order. +-- | /O(min(n,W))/. Delete the minimal key. Returns an empty map if the map is empty. -- --- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] --- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] - -fromAscList :: [(Key,a)] -> IntMap a -fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) -{-# NOINLINE fromAscList #-} +-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' – +-- versions prior to 0.5 threw an error if the 'IntMap' was already empty. +deleteMin :: IntMap a -> IntMap a +deleteMin (IntMap Empty) = IntMap Empty +deleteMin m = delete (fst (findMin m)) m --- | /O(n)/. Build a map from a list of key\/value pairs where --- the keys are in ascending order, with a combining function on equal keys. --- /The precondition (input list is ascending) is not checked./ +-- | /O(min(n,W))/. Delete the maximal key. Returns an empty map if the map is empty. -- --- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] - -fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) -{-# NOINLINE fromAscListWith #-} +-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' – +-- versions prior to 0.5 threw an error if the 'IntMap' was already empty. +deleteMax :: IntMap a -> IntMap a +deleteMax (IntMap Empty) = IntMap Empty +deleteMax m = delete (fst (findMax m)) m --- | /O(n)/. Build a map from a list of key\/value pairs where --- the keys are in ascending order, with a combining function on equal keys. --- /The precondition (input list is ascending) is not checked./ --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] +-- | /O(min(n,W))/. Delete and find the minimal element. +deleteFindMin :: IntMap a -> ((Key, a), IntMap a) +deleteFindMin m = let (k, a) = findMin m + in ((k, a), delete k m) -fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWithKey f = fromMonoListWithKey Nondistinct f -{-# NOINLINE fromAscListWithKey #-} +-- | /O(min(n,W))/. Delete and find the maximal element. +deleteFindMax :: IntMap a -> ((Key, a), IntMap a) +deleteFindMax m = let (k, a) = findMax m + in ((k, a), delete k m) --- | /O(n)/. Build a map from a list of key\/value pairs where --- the keys are in ascending order and all distinct. --- /The precondition (input list is strictly ascending) is not checked./ --- --- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +-- | /O(min(n,W))/. Retrieves the minimal key of the map, and the map +-- stripped of that element, or 'Nothing' if passed an empty map. +minView :: IntMap a -> Maybe (a, IntMap a) +minView (IntMap Empty) = Nothing +minView m = let (k, a) = findMin m + in Just (a, delete k m) -fromDistinctAscList :: [(Key,a)] -> IntMap a -fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) -{-# NOINLINE fromDistinctAscList #-} +-- | /O(min(n,W))/. Retrieves the maximal key of the map, and the map +-- stripped of that element, or 'Nothing' if passed an empty map. +maxView :: IntMap a -> Maybe (a, IntMap a) +maxView (IntMap Empty) = Nothing +maxView m = let (k, a) = findMax m + in Just (a, delete k m) --- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys --- and a combining function. +-- | /O(min(n,W))/. Retrieves the minimal (key,value) pair of the map, and +-- the map stripped of that element, or 'Nothing' if passed an empty map. -- --- The precise conditions under which this function works are subtle: --- For any branch mask, keys with the same prefix w.r.t. the branch --- mask must occur consecutively in the list. - -fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromMonoListWithKey distinct f = go - where - go [] = Nil - go ((kx,vx) : zs1) = addAll' kx vx zs1 - - -- `addAll'` collects all keys equal to `kx` into a single value, - -- and then proceeds with `addAll`. - addAll' !kx vx [] - = Tip kx vx - addAll' !kx vx ((ky,vy) : zs) - | Nondistinct <- distinct, kx == ky - = let v = f kx vy vx in addAll' ky v zs - -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs) - | m <- branchMask kx ky - , Inserted ty zs' <- addMany' m ky vy zs - = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx vx)) zs' - - -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` - -- `addAll` consumes the rest of the list, adding to the tree `tx` - addAll !kx !tx [] - = tx - addAll !kx !tx ((ky,vy) : zs) - | m <- branchMask kx ky - , Inserted ty zs' <- addMany' m ky vy zs - = addAll kx (linkWithMask m ky ty {-kx-} tx) zs' - - -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. - addMany' !m !kx vx [] - = Inserted (Tip kx vx) [] - addMany' !m !kx vx zs0@((ky,vy) : zs) - | Nondistinct <- distinct, kx == ky - = let v = f kx vy vx in addMany' m ky v zs - -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs) - | mask kx m /= mask ky m - = Inserted (Tip kx vx) zs0 - | mxy <- branchMask kx ky - , Inserted ty zs' <- addMany' mxy ky vy zs - = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs' - - -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. - addMany !m !kx tx [] - = Inserted tx [] - addMany !m !kx tx zs0@((ky,vy) : zs) - | mask kx m /= mask ky m - = Inserted tx zs0 - | mxy <- branchMask kx ky - , Inserted ty zs' <- addMany' mxy ky vy zs - = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs' -{-# INLINE fromMonoListWithKey #-} - -data Inserted a = Inserted !(IntMap a) ![(Key,a)] - -data Distinct = Distinct | Nondistinct - -{-------------------------------------------------------------------- - Eq ---------------------------------------------------------------------} -instance Eq a => Eq (IntMap a) where - t1 == t2 = equal t1 t2 - t1 /= t2 = nequal t1 t2 - -equal :: Eq a => IntMap a -> IntMap a -> Bool -equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) - = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) -equal (Tip kx x) (Tip ky y) - = (kx == ky) && (x==y) -equal Nil Nil = True -equal _ _ = False - -nequal :: Eq a => IntMap a -> IntMap a -> Bool -nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) - = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) -nequal (Tip kx x) (Tip ky y) - = (kx /= ky) || (x/=y) -nequal Nil Nil = False -nequal _ _ = True - -#if MIN_VERSION_base(4,9,0) --- | @since 0.5.9 -instance Eq1 IntMap where - liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) - = (m1 == m2) && (p1 == p2) && (liftEq eq l1 l2) && (liftEq eq r1 r2) - liftEq eq (Tip kx x) (Tip ky y) - = (kx == ky) && (eq x y) - liftEq _eq Nil Nil = True - liftEq _eq _ _ = False -#endif - -{-------------------------------------------------------------------- - Ord ---------------------------------------------------------------------} - -instance Ord a => Ord (IntMap a) where - compare m1 m2 = compare (toList m1) (toList m2) - -#if MIN_VERSION_base(4,9,0) --- | @since 0.5.9 -instance Ord1 IntMap where - liftCompare cmp m n = - liftCompare (liftCompare cmp) (toList m) (toList n) -#endif - -{-------------------------------------------------------------------- - Functor ---------------------------------------------------------------------} - -instance Functor IntMap where - fmap = map - -#ifdef __GLASGOW_HASKELL__ - a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r) - a <$ Tip k _ = Tip k a - _ <$ Nil = Nil -#endif - -{-------------------------------------------------------------------- - Show ---------------------------------------------------------------------} +-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") +-- > minViewWithKey empty == Nothing +minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) +minViewWithKey (IntMap Empty) = Nothing +minViewWithKey m = let (k, a) = findMin m + in Just ((k, a), delete k m) -instance Show a => Show (IntMap a) where - showsPrec d m = showParen (d > 10) $ - showString "fromList " . shows (toList m) - -#if MIN_VERSION_base(4,9,0) --- | @since 0.5.9 -instance Show1 IntMap where - liftShowsPrec sp sl d m = - showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m) - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl -#endif - -{-------------------------------------------------------------------- - Read ---------------------------------------------------------------------} -instance (Read e) => Read (IntMap e) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- readPrec - return (fromList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromList",s) <- lex r - (xs,t) <- reads s - return (fromList xs,t) -#endif - -#if MIN_VERSION_base(4,9,0) --- | @since 0.5.9 -instance Read1 IntMap where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl -#endif - -{-------------------------------------------------------------------- - Typeable ---------------------------------------------------------------------} - -INSTANCE_TYPEABLE1(IntMap) - -{-------------------------------------------------------------------- - Helpers ---------------------------------------------------------------------} -{-------------------------------------------------------------------- - Link ---------------------------------------------------------------------} -link :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a -link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2 -{-# INLINE link #-} - --- `linkWithMask` is useful when the `branchMask` has already been computed -linkWithMask :: Mask -> Prefix -> IntMap a -> IntMap a -> IntMap a -linkWithMask m p1 t1 {-p2-} t2 - | zero p1 m = Bin p m t1 t2 - | otherwise = Bin p m t2 t1 - where - p = mask p1 m -{-# INLINE linkWithMask #-} - -{-------------------------------------------------------------------- - @bin@ assures that we never have empty trees within a tree. ---------------------------------------------------------------------} -bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a -bin _ _ l Nil = l -bin _ _ Nil r = r -bin p m l r = Bin p m l r -{-# INLINE bin #-} - --- binCheckLeft only checks that the left subtree is non-empty -binCheckLeft :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a -binCheckLeft _ _ Nil r = r -binCheckLeft p m l r = Bin p m l r -{-# INLINE binCheckLeft #-} - --- binCheckRight only checks that the right subtree is non-empty -binCheckRight :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a -binCheckRight _ _ l Nil = l -binCheckRight p m l r = Bin p m l r -{-# INLINE binCheckRight #-} - -{-------------------------------------------------------------------- - Endian independent bit twiddling ---------------------------------------------------------------------} - --- | Should this key follow the left subtree of a 'Bin' with switching --- bit @m@? N.B., the answer is only valid when @match i p m@ is true. -zero :: Key -> Mask -> Bool -zero i m - = (natFromInt i) .&. (natFromInt m) == 0 -{-# INLINE zero #-} - -nomatch,match :: Key -> Prefix -> Mask -> Bool - --- | Does the key @i@ differ from the prefix @p@ before getting to --- the switching bit @m@? -nomatch i p m - = (mask i m) /= p -{-# INLINE nomatch #-} - --- | Does the key @i@ match the prefix @p@ (up to but not including --- bit @m@)? -match i p m - = (mask i m) == p -{-# INLINE match #-} - - --- | The prefix of key @i@ up to (but not including) the switching --- bit @m@. -mask :: Key -> Mask -> Prefix -mask i m - = maskW (natFromInt i) (natFromInt m) -{-# INLINE mask #-} - - -{-------------------------------------------------------------------- - Big endian operations ---------------------------------------------------------------------} - --- | The prefix of key @i@ up to (but not including) the switching --- bit @m@. -maskW :: Nat -> Nat -> Prefix -maskW i m - = intFromNat (i .&. ((-m) `xor` m)) -{-# INLINE maskW #-} - --- | Does the left switching bit specify a shorter prefix? -shorter :: Mask -> Mask -> Bool -shorter m1 m2 - = (natFromInt m1) > (natFromInt m2) -{-# INLINE shorter #-} - --- | The first switching bit where the two prefixes disagree. -branchMask :: Prefix -> Prefix -> Mask -branchMask p1 p2 - = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) -{-# INLINE branchMask #-} - -{-------------------------------------------------------------------- - Utilities ---------------------------------------------------------------------} - --- | /O(1)/. Decompose a map into pieces based on the structure --- of the underlying tree. This function is useful for consuming a --- map in parallel. --- --- No guarantee is made as to the sizes of the pieces; an internal, but --- deterministic process determines this. However, it is guaranteed that the --- pieces returned will be in ascending order (all elements in the first submap --- less than all elements in the second, and so on). --- --- Examples: --- --- > splitRoot (fromList (zip [1..6::Int] ['a'..])) == --- > [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]] --- --- > splitRoot empty == [] +-- | /O(min(n,W))/. Retrieves the maximal (key,value) pair of the map, and +-- the map stripped of that element, or 'Nothing' if passed an empty map. -- --- Note that the current implementation does not return more than two submaps, --- but you should not depend on this behaviour because it can change in the --- future without notice. -splitRoot :: IntMap a -> [IntMap a] -splitRoot orig = - case orig of - Nil -> [] - x@(Tip _ _) -> [x] - Bin _ m l r | m < 0 -> [r, l] - | otherwise -> [l, r] -{-# INLINE splitRoot #-} - +-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b") +-- > maxViewWithKey empty == Nothing +maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) +maxViewWithKey (IntMap Empty) = Nothing +maxViewWithKey m = let (k, a) = findMax m + in Just ((k, a), delete k m) -{-------------------------------------------------------------------- - Debugging ---------------------------------------------------------------------} +---------------------------- --- | /O(n)/. Show the tree that implements the map. The tree is shown --- in a compressed, hanging format. +-- | Show the tree that implements the map. showTree :: Show a => IntMap a -> String -showTree s - = showTreeWith True False s - +showTree = unlines . aux where + aux (IntMap Empty) = [] + aux (IntMap (NonEmpty min minV node)) = (show min ++ " " ++ show minV) : auxNode False node + auxNode :: Show a => Bool -> Node t a -> [String] + auxNode _ Tip = ["+-."] + auxNode lined (Bin bound val l r) = ["+--" ++ show bound ++ " " ++ show val, prefix : " |"] ++ fmap indent (auxNode True l) ++ [prefix : " |"] ++ fmap indent (auxNode False r) + where + prefix = if lined then '|' else ' ' + indent line = prefix : " " ++ line -{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows - the tree that implements the map. If @hang@ is - 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If - @wide@ is 'True', an extra wide version is shown. --} showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String -showTreeWith hang wide t - | hang = (showsTreeHang wide [] t) "" - | otherwise = (showsTree wide [] [] t) "" - -showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS -showsTree wide lbars rbars t = case t of - Bin p m l r -> - showsTree wide (withBar rbars) (withEmpty rbars) r . - showWide wide rbars . - showsBars lbars . showString (showBin p m) . showString "\n" . - showWide wide lbars . - showsTree wide (withEmpty lbars) (withBar lbars) l - Tip k x -> - showsBars lbars . - showString " " . shows k . showString ":=" . shows x . showString "\n" - Nil -> showsBars lbars . showString "|\n" - -showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS -showsTreeHang wide bars t = case t of - Bin p m l r -> - showsBars bars . showString (showBin p m) . showString "\n" . - showWide wide bars . - showsTreeHang wide (withBar bars) l . - showWide wide bars . - showsTreeHang wide (withEmpty bars) r - Tip k x -> - showsBars bars . - showString " " . shows k . showString ":=" . shows x . showString "\n" - Nil -> showsBars bars . showString "|\n" - -showBin :: Prefix -> Mask -> String -showBin _ _ - = "*" -- ++ show (p,m) - -showWide :: Bool -> [String] -> String -> String -showWide wide bars - | wide = showString (concat (reverse bars)) . showString "|\n" - | otherwise = id - -showsBars :: [String] -> ShowS -showsBars bars - = case bars of - [] -> id - _ -> showString (concat (reverse (tail bars))) . showString node - -node :: String -node = "+--" - -withBar, withEmpty :: [String] -> [String] -withBar bars = "| ":bars -withEmpty bars = " ":bars +showTreeWith _ _ = showTree + +valid :: IntMap a -> Bool +valid = start + where + start (IntMap Empty) = True + start (IntMap (NonEmpty min _ root)) = allKeys (> min) root && goL min root + + goL _ Tip = True + goL min (Bin max _ l r) = + allKeys (< max) l + && allKeys (< max) r + && allKeys (\k -> xor min k < xor k max) l + && allKeys (\k -> xor min k > xor k max) r + && goL min l + && goR max r + + goR _ Tip = True + goR max (Bin min _ l r) = + allKeys (> min) l + && allKeys (> min) r + && allKeys (\k -> xor min k < xor k max) l + && allKeys (\k -> xor min k > xor k max) r + && goL min l + && goR max r + + allKeys :: (Key -> Bool) -> Node t a -> Bool + allKeys _ Tip = True + allKeys p (Bin b _ l r) = p b && allKeys p l && allKeys p r + +-- | /O(1)/. Returns whether the most significant bit of its first +-- argument is less significant than the most significant bit of its +-- second argument. +{-# INLINE ltMSB #-} +ltMSB :: Word -> Word -> Bool +ltMSB x y = x < y && x < Data.Bits.xor x y + +{-# INLINE compareMSB #-} +compareMSB :: Word -> Word -> Ordering +compareMSB x y = case compare x y of + LT | x < Data.Bits.xor x y -> LT + GT | y < Data.Bits.xor x y -> GT + _ -> EQ + +{-# INLINE binL #-} +binL :: IntMap_ L a -> IntMap_ R a -> IntMap_ L a +binL Empty r = r2lMap r +binL l Empty = l +binL (NonEmpty min minV l) (NonEmpty max maxV r) = NonEmpty min minV (Bin max maxV l r) + +{-# INLINE binR #-} +binR :: IntMap_ L a -> IntMap_ R a -> IntMap_ R a +binR Empty r = r +binR l Empty = l2rMap l +binR (NonEmpty min minV l) (NonEmpty max maxV r) = NonEmpty max maxV (Bin min minV l r) + +{-# INLINE l2rMap #-} +l2rMap :: IntMap_ L a -> IntMap_ R a +l2rMap Empty = Empty +l2rMap (NonEmpty min minV Tip) = NonEmpty min minV Tip +l2rMap (NonEmpty min minV (Bin max maxV l r)) = NonEmpty max maxV (Bin min minV l r) + +{-# INLINE r2lMap #-} +r2lMap :: IntMap_ R a -> IntMap_ L a +r2lMap Empty = Empty +r2lMap (NonEmpty max maxV Tip) = NonEmpty max maxV Tip +r2lMap (NonEmpty max maxV (Bin min minV l r)) = NonEmpty min minV (Bin max maxV l r) + +{-# INLINE l2rDR #-} +l2rDR :: DeleteResult L a -> DeleteResult R a +l2rDR (DR min minV Tip) = DR min minV Tip +l2rDR (DR min minV (Bin max maxV l r)) = DR max maxV (Bin min minV l r) + +{-# INLINE r2lDR #-} +r2lDR :: DeleteResult t a -> DeleteResult t' a +r2lDR (DR max maxV Tip) = DR max maxV Tip +r2lDR (DR max maxV (Bin min minV l r)) = DR min minV (Bin max maxV l r) + +-- | Insert a key/value pair to a left node where the key is smaller than +-- any present in that node. Requires the xor of the inserted key and the +-- key immediately prior to it (the minimum bound of the node). +insertMinL :: Word -> Key -> a -> Node L a -> Node L a +insertMinL !_ !min minV Tip = Bin min minV Tip Tip +insertMinL !xorCache !min minV (Bin max maxV l r) + | xor min max < xorCache = Bin max maxV Tip (Bin min minV l r) + | otherwise = Bin max maxV (insertMinL xorCache min minV l) r + +-- | Insert a key/value pair to a right node where the key is greater than +-- any present in that node. Requires the xor of the inserted key and the +-- key immediately following it (the maximum bound of the node). +insertMaxR :: Word -> Key -> a -> Node R a -> Node R a +insertMaxR !_ !max maxV Tip = Bin max maxV Tip Tip +insertMaxR !xorCache !max maxV (Bin min minV l r) + | xor min max < xorCache = Bin min minV (Bin max maxV l r) Tip + | otherwise = Bin min minV l (insertMaxR xorCache max maxV r) + +-- | Delete the minimum key/value pair from an unpacked left node, returning +-- a new left node in a DeleteResult. +deleteMinL :: Key -> a -> Node L a -> Node R a -> DeleteResult L a +deleteMinL !max maxV Tip Tip = DR max maxV Tip +deleteMinL !max maxV Tip (Bin min minV l r) = DR min minV (Bin max maxV l r) +deleteMinL !max maxV (Bin innerMax innerMaxV innerL innerR) r = + let DR min minV inner = deleteMinL innerMax innerMaxV innerL innerR + in DR min minV (Bin max maxV inner r) + +-- | Delete the maximum key/value pair from an unpacked right node, returning +-- a new right node in a DeleteResult. +deleteMaxR :: Key -> a -> Node L a -> Node R a -> DeleteResult R a +deleteMaxR !min minV Tip Tip = DR min minV Tip +deleteMaxR !min minV (Bin max maxV l r) Tip = DR max maxV (Bin min minV l r) +deleteMaxR !min minV l (Bin innerMin innerMinV innerL innerR) = + let DR max maxV inner = deleteMaxR innerMin innerMinV innerL innerR + in DR max maxV (Bin min minV l inner) + +-- | Combine two disjoint nodes into a new left node. This is not cheap. +extractBinL :: Node L a -> Node R a -> Node L a +extractBinL l Tip = l +extractBinL l (Bin min minV innerL innerR) = + let DR max maxV r = deleteMaxR min minV innerL innerR + in Bin max maxV l r + +-- | Combine two disjoint nodes into a new right node. This is not cheap. +extractBinR :: Node L a -> Node R a -> Node R a +extractBinR Tip r = r +extractBinR (Bin max maxV innerL innerR) r = + let DR min minV l = deleteMinL max maxV innerL innerR + in Bin min minV l r + +nodeToMapL :: Node L a -> IntMap_ L a +nodeToMapL Tip = Empty +nodeToMapL (Bin max maxV innerL innerR) = + let DR min minV l = deleteMinL max maxV innerL innerR + in NonEmpty min minV l + +nodeToMapR :: Node R a -> IntMap_ R a +nodeToMapR Tip = Empty +nodeToMapR (Bin min minV innerL innerR) = + let DR max maxV r = deleteMaxR min minV innerL innerR + in NonEmpty max maxV r + +-- | Delete a key from a left node. Takes the xor of the deleted key and +-- the minimum bound of that node. +deleteL :: Key -> Word -> Node L a -> Node L a +deleteL !_ !_ Tip = Tip +deleteL !k !xorCache n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (deleteL k xorCache l) r + else Bin max maxV l (deleteR k xorCacheMax r) + | k > max = n + | otherwise = extractBinL l r + where xorCacheMax = xor k max + +-- | Delete a key from a right node. Takes the xor of the deleted key and +-- the maximum bound of that node. +deleteR :: Key -> Word -> Node R a -> Node R a +deleteR !_ !_ Tip = Tip +deleteR !k !xorCache n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (deleteR k xorCache r) + else Bin min minV (deleteL k xorCacheMin l) r + | k < min = n + | otherwise = extractBinR l r + where xorCacheMin = xor min k diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 8d4ce8c82..51e2b768e 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1,15 +1,11 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif - -#include "containers.h" +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Lazy -- Copyright : (c) Daan Leijen 2002 -- (c) Andriy Palamarchuk 2008 +-- (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable @@ -50,29 +46,33 @@ -- -- == Implementation -- --- The implementation is based on /big-endian patricia trees/. This data --- structure performs especially well on binary operations like 'union' and --- 'intersection'. Additionally, benchmarks show that it is also (much) faster --- on insertions and deletions when compared to a generic size-balanced map --- implementation (see "Data.Map"). --- --- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", --- Workshop on ML, September 1998, pages 77-86, --- --- --- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve --- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), --- October 1968, pages 514-534. --- +-- Operation comments contain the operation time complexity in +-- the Big-O notation . +-- Many operations have a worst-case complexity of /O(min(n,W))/. +-- This means that the operation can become linear in the number of +-- elements with a maximum of /W/ -- the number of bits in an 'Int' +-- (32 or 64). ----------------------------------------------------------------------------- module Data.IntMap.Lazy ( -- * Map type -#if !defined(TESTING) - IntMap, Key -- instance Eq,Show -#else - IntMap(..), Key -- instance Eq,Show -#endif + IntMap, Key + + -- * Operators + , (!) + , (\\) + + -- * Query + , null + , size + , member + , notMember + , lookup + , findWithDefault + , lookupLT + , lookupGT + , lookupLE + , lookupGE -- * Construction , empty @@ -124,7 +124,6 @@ module Data.IntMap.Lazy ( , size -- * Combine - -- ** Union , union , unionWith @@ -143,15 +142,12 @@ module Data.IntMap.Lazy ( , intersectionWith , intersectionWithKey - -- ** Disjoint - , disjoint - - -- ** Universal combining function + -- ** Deprecated, unsafe general combining function , mergeWithKey -- * Traversal -- ** Map - , IM.map + , map , mapWithKey , traverseWithKey , mapAccum @@ -162,8 +158,8 @@ module Data.IntMap.Lazy ( , mapKeysMonotonic -- * Folds - , IM.foldr - , IM.foldl + , foldr + , foldl , foldrWithKey , foldlWithKey , foldMapWithKey @@ -183,30 +179,30 @@ module Data.IntMap.Lazy ( -- ** Lists , toList - -- ** Ordered lists + -- ** Ordered Lists , toAscList , toDescList -- * Filter - , IM.filter + , filter , filterWithKey , restrictKeys , withoutKeys , partition , partitionWithKey - , mapMaybe , mapMaybeWithKey , mapEither , mapEitherWithKey - , split , splitLookup , splitRoot -- * Submap - , isSubmapOf, isSubmapOfBy - , isProperSubmapOf, isProperSubmapOfBy + , isSubmapOf + , isSubmapOfBy + , isProperSubmapOf + , isProperSubmapOfBy -- * Min\/Max , lookupMin @@ -230,10 +226,1309 @@ module Data.IntMap.Lazy ( -- * Debugging , showTree , showTreeWith -#endif - ) where + , valid +) where -import Data.IntMap.Internal as IM hiding (showTree, showTreeWith) -#ifdef __GLASGOW_HASKELL__ -import Data.IntMap.Internal.DeprecatedDebug -#endif +import Data.IntMap.Internal +import qualified Data.IntMap.Merge.Lazy as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) + +import Control.Applicative (Applicative(..)) +import Data.Functor ((<$>)) + +import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) + +import qualified Data.List (foldl', map) +import qualified Data.IntSet (IntSet, toList) + +import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) + +-- | /O(1)/. A map of one element. +-- +-- > singleton 1 'a' == fromList [(1, 'a')] +-- > size (singleton 1 'a') == 1 +singleton :: Key -> a -> IntMap a +singleton k v = IntMap (NonEmpty k v Tip) + +-- | /O(min(n,W))/. Insert a new key\/value pair in the map. +-- If the key is already present in the map, the associated value is +-- replaced with the supplied value, i.e. 'insert' is equivalent to +-- @'insertWith' 'const'@. +-- +-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] +-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] +-- > insert 5 'x' empty == singleton 5 'x' +insert :: Key -> a -> IntMap a -> IntMap a +insert = start + where + start !k v (IntMap Empty) = IntMap (NonEmpty k v Tip) + start !k v (IntMap (NonEmpty min minV root)) + | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) + | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) + | otherwise = IntMap (NonEmpty k v root) + + goL !k v !_ !_ Tip = Bin k v Tip Tip + goL !k v !xorCache !min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL k v xorCache min l) r + else Bin max maxV l (goR k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max v l r + where xorCacheMax = xor k max + + goR !k v !_ !_ Tip = Bin k v Tip Tip + goR !k v !xorCache !max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR k v xorCache max r) + else Bin min minV (goL k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min v l r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. Insert with a combining function. +-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert @f new_value old_value@. +-- +-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] +-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWith combine = start + where + start !k v (IntMap Empty) = IntMap (NonEmpty k v Tip) + start !k v (IntMap (NonEmpty min minV root)) + | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) + | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) + | otherwise = IntMap (NonEmpty k (combine v minV) root) + + goL !k v !_ !_ Tip = Bin k v Tip Tip + goL !k v !xorCache !min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL k v xorCache min l) r + else Bin max maxV l (goR k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max (combine v maxV) l r + where xorCacheMax = xor k max + + goR !k v !_ !_ Tip = Bin k v Tip Tip + goR !k v !xorCache !max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR k v xorCache max r) + else Bin min minV (goL k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min (combine v minV) l r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. Insert with a combining function. +-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert @f key new_value old_value@. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] +-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" +insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithKey f k = insertWith (f k) k + +-- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) +-- is a pair where the first element is equal to (@'lookup' k map@) +-- and the second element equal to (@'insertWithKey' f k x map@). +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) +-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) +-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") +-- +-- This is how to define @insertLookup@ using @insertLookupWithKey@: +-- +-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t +-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) +-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) +insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) +insertLookupWithKey combine !k !v = toPair . start + where + start (IntMap Empty) = Nothing :*: IntMap (NonEmpty k v Tip) + start (IntMap (NonEmpty min minV root)) + | k > min = let mv :*: root' = goL (xor min k) min root + in mv :*: IntMap (NonEmpty min minV root') + | k < min = Nothing :*: IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) + | otherwise = Just minV :*: IntMap (NonEmpty k (combine k v minV) root) + + goL !_ _ Tip = Nothing :*: Bin k v Tip Tip + goL !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then let mv :*: l' = goL xorCache min l + in mv :*: Bin max maxV l' r + else let mv :*: r' = goR xorCacheMax max r + in mv :*: Bin max maxV l r' + | k > max = if xor min max < xorCacheMax + then Nothing :*: Bin k v (Bin max maxV l r) Tip + else Nothing :*: Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Just maxV :*: Bin max (combine k v maxV) l r + where xorCacheMax = xor k max + + goR !_ _ Tip = Nothing :*: Bin k v Tip Tip + goR !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then let mv :*: r' = goR xorCache max r + in mv :*: Bin min minV l r' + else let mv :*: l' = goL xorCacheMin min l + in mv :*: Bin min minV l' r + | k < min = if xor min max < xorCacheMin + then Nothing :*: Bin k v Tip (Bin min minV l r) + else Nothing :*: Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Just minV :*: Bin min (combine k v minV) l r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > adjust ("new " ++) 7 empty == empty +adjust :: (a -> a) -> Key -> IntMap a -> IntMap a +adjust f k = k `seq` start + where + start (IntMap Empty) = IntMap Empty + start m@(IntMap (NonEmpty min minV node)) + | k > min = IntMap (NonEmpty min minV (goL (xor min k) min node)) + | k < min = m + | otherwise = IntMap (NonEmpty min (f minV) node) + + goL !_ _ Tip = Tip + goL !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL xorCache min l) r + else Bin max maxV l (goR xorCacheMax max r) + | k > max = n + | otherwise = Bin max (f maxV) l r + where xorCacheMax = xor k max + + goR !_ _ Tip = Tip + goR !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR xorCache max r) + else Bin min minV (goL xorCacheMin min l) r + | k < min = n + | otherwise = Bin min (f minV) l r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > let f key x = (show key) ++ ":new " ++ x +-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > adjustWithKey f 7 empty == empty +adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a +adjustWithKey f k = adjust (f k) k + +-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a +update f k = k `seq` start + where + start (IntMap Empty) = IntMap Empty + start m@(IntMap (NonEmpty min minV Tip)) + | k == min = case f minV of + Nothing -> IntMap Empty + Just minV' -> IntMap (NonEmpty min minV' Tip) + | otherwise = m + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) + | k < min = m + | k == min = case f minV of + Nothing -> let DR min' minV' root' = deleteMinL max maxV l r + in IntMap (NonEmpty min' minV' root') + Just minV' -> IntMap (NonEmpty min minV' root) + | otherwise = IntMap (NonEmpty min minV (goL (xor min k) min root)) + + goL !_ _ Tip = Tip + goL !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL xorCache min l) r + else Bin max maxV l (goR xorCacheMax max r) + | k > max = n + | otherwise = case f maxV of + Nothing -> extractBinL l r + Just maxV' -> Bin max maxV' l r + where xorCacheMax = xor k max + + goR !_ _ Tip = Tip + goR !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR xorCache max r) + else Bin min minV (goL xorCacheMin min l) r + | k < min = n + | otherwise = case f minV of + Nothing -> extractBinR l r + Just minV' -> Bin min minV' l r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. The expression (@'updateWithKey' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a +updateWithKey f k = update (f k) k + +-- | /O(min(n,W))/. Lookup and update. +-- The function returns original value, if it is updated. +-- This is different behavior than 'Data.Map.updateLookupWithKey'. +-- Returns the original key value if the map entry is deleted. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) +-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) +-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") +updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) +updateLookupWithKey f k = k `seq` start + where + start (IntMap Empty) = (Nothing, IntMap Empty) + start m@(IntMap (NonEmpty min minV Tip)) + | k == min = case f min minV of + Nothing -> (Just minV, IntMap Empty) + Just minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) + | otherwise = (Nothing, m) + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) + | k < min = (Nothing, m) + | k == min = case f min minV of + Nothing -> let DR min' minV' root' = deleteMinL max maxV l r + in (Just minV, IntMap (NonEmpty min' minV' root')) + Just minV' -> (Just minV, IntMap (NonEmpty min minV' root)) + | otherwise = let (mv, root') = goL (xor min k) min root + in (mv, IntMap (NonEmpty min minV root')) + + goL !_ _ Tip = (Nothing, Tip) + goL !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then let (mv, l') = goL xorCache min l + in (mv, Bin max maxV l' r) + else let (mv, r') = goR xorCacheMax max r + in (mv, Bin max maxV l r') + | k > max = (Nothing, n) + | otherwise = case f max maxV of + Nothing -> (Just maxV, extractBinL l r) + Just maxV' -> (Just maxV, Bin max maxV' l r) + where xorCacheMax = xor k max + + goR !_ _ Tip = (Nothing, Tip) + goR !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then let (mv, r') = goR xorCache max r + in (mv, Bin min minV l r') + else let (mv, l') = goL xorCacheMin min l + in (mv, Bin min minV l' r) + | k < min = (Nothing, n) + | otherwise = case f min minV of + Nothing -> (Just minV, extractBinR l r) + Just minV' -> (Just minV, Bin min minV' l r) + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. +-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. +alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a +alter f k m = case lookup k m of + Nothing -> case f Nothing of + Nothing -> m + Just v -> insert k v m + Just v -> case f (Just v) of + Nothing -> delete k m + Just v' -> insert k v' m + +-- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at +-- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, +-- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f +-- ('lookup' k m)@. +-- +-- Example: +-- +-- @ +-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String) +-- interactiveAlter k m = alterF f k m where +-- f Nothing -> do +-- putStrLn $ show k ++ +-- " was not found in the map. Would you like to add it?" +-- getUserResponse1 :: IO (Maybe String) +-- f (Just old) -> do +-- putStrLn "The key is currently bound to " ++ show old ++ +-- ". Would you like to change or delete it?" +-- getUserresponse2 :: IO (Maybe String) +-- @ +-- +-- 'alterF' is the most general operation for working with an individual +-- key that may or may not be in a given map. +-- +-- Note: 'alterF' is a flipped version of the 'at' combinator from +-- 'Control.Lens.At'. +-- +-- @since 0.5.8 +alterF :: Functor f => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a) +alterF f k m = case lookup k m of + Nothing -> fmap (\ret -> case ret of + Nothing -> m + Just v -> insert k v m) (f Nothing) + Just v -> fmap (\ret -> case ret of + Nothing -> delete k m + Just v' -> insert k v' m) (f (Just v)) + +-- | /O(n+m)/. The union with a combining function. +-- +-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] +unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWith f = unionWithKey (const f) + +-- | /O(n+m)/. The union with a combining function. +-- +-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value +-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] +unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWithKey combine = start + where + start (IntMap Empty) m2 = m2 + start m1 (IntMap Empty) = m1 + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 minV2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) + | otherwise = IntMap (NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + + -- TODO: Should I bind 'minV1' in a closure? It never changes. + -- TODO: Should I cache @xor min1 min2@? + goL1 minV1 min1 Tip !_ Tip = Bin min1 minV1 Tip Tip + goL1 minV1 min1 Tip min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1 minV1 min1 n1 min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> Bin max1 (combine max1 maxV1 maxV2) l2 (goRFused max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 + EQ | max2 < min1 -> disjoint + | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 + where + disjoint = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) + + -- TODO: Should I bind 'minV2' in a closure? It never changes. + -- TODO: Should I cache @xor min1 min2@? + goL2 minV2 !_ Tip min2 Tip = Bin min2 minV2 Tip Tip + goL2 minV2 min1 Tip min2 n2 = insertMinL (xor min1 min2) min2 minV2 n2 + goL2 minV2 min1 n1 min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 + EQ | max1 < min2 -> disjoint + | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> Bin max1 (combine max1 maxV1 maxV2) l1 (goRFused max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 + where + disjoint = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) + + -- TODO: Should I bind 'min' in a closure? It never changes. + -- TODO: Should I use an xor cache here? + -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same + -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' + goLFused !_ Tip n2 = n2 + goLFused !_ n1 Tip = n1 + goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 + EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 + + -- TODO: Should I bind 'maxV1' in a closure? It never changes. + -- TODO: Should I cache @xor max1 max2@? + goR1 maxV1 max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip + goR1 maxV1 max1 Tip max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 + goR1 maxV1 max1 n1 max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 + EQ | max1 < min2 -> disjoint + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) + where + disjoint = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 + + -- TODO: Should I bind 'minV2' in a closure? It never changes. + -- TODO: Should I cache @xor min1 min2@? + goR2 maxV2 !_ Tip max2 Tip = Bin max2 maxV2 Tip Tip + goR2 maxV2 max1 Tip max2 n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 + goR2 maxV2 max1 n1 max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) + EQ | max2 < min1 -> disjoint + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 + where + disjoint = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 + + -- TODO: Should I bind 'max' in a closure? It never changes. + -- TODO: Should I use an xor cache here? + -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same + -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' + goRFused !_ Tip n2 = n2 + goRFused !_ n1 Tip = n1 + goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> Bin min2 minV2 l2 (goRFused max n1 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) + | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT -> Bin min1 minV1 l1 (goRFused max r1 n2) + + goInsertL1 k v !_ _ Tip = Bin k v Tip Tip + goInsertL1 k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goInsertL1 k v xorCache min l) r + else Bin max maxV l (goInsertR1 k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max (combine k v maxV) l r + where xorCacheMax = xor k max + + goInsertR1 k v !_ _ Tip = Bin k v Tip Tip + goInsertR1 k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goInsertR1 k v xorCache max r) + else Bin min minV (goInsertL1 k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min (combine k v minV) l r + where xorCacheMin = xor min k + + goInsertL2 k v !_ _ Tip = Bin k v Tip Tip + goInsertL2 k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goInsertL2 k v xorCache min l) r + else Bin max maxV l (goInsertR2 k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max (combine k maxV v) l r + where xorCacheMax = xor k max + + goInsertR2 k v !_ _ Tip = Bin k v Tip Tip + goInsertR2 k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goInsertR2 k v xorCache max r) + else Bin min minV (goInsertL2 k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min (combine k minV v) l r + where xorCacheMin = xor min k + +-- | The union of a list of maps, with a combining operation. +-- +-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] +-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] +unionsWith :: (a -> a -> a) -> [IntMap a] -> IntMap a +unionsWith f = Data.List.foldl' (unionWith f) empty + +-- | /O(n+m)/. Difference with a combining function. +-- +-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing +-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) +-- > == singleton 3 "b:B" +differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a +differenceWith f = differenceWithKey (const f) + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns 'Nothing', the element is discarded (proper set difference). +-- If it returns (@'Just' y@), the element is updated with a new value @y@. +-- +-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing +-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) +-- > == singleton 3 "3:b|B" +differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a +differenceWithKey combine = start + where + start (IntMap Empty) !_ = IntMap Empty + start !m (IntMap Empty) = m + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + | otherwise = case combine min1 minV1 minV2 of + Nothing -> IntMap (goLFused min1 root1 root2) + Just minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep min1 root1 root2)) + + goL1 minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 + Just maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) + | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) + Just maxV1' -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) + GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) + + goL2 !_ Tip !_ !_ = Tip + goL2 min1 n1 min2 Tip = deleteL min2 (xor min1 min2) n1 + goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = n1 + goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goL2 min1 n1 min2 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> goL2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> case goRFused max1 r1 r2 of + Empty -> goL2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + Just maxV1' -> Bin max1 maxV1' (goL2 min1 l1 min2 l2) (goRFusedKeep max1 r1 r2) + GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of + Empty -> l1 + NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of + Empty -> l1 + NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' + Just maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep max1 r1 (Bin min2 dummyV l2 r2)) + + goLFused min = loop + where + loop Tip !_ = Empty + loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of + DR min' minV' n' -> NonEmpty min' minV' n' + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) + | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + Just maxV1' -> binL (loop l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) + GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) + + goLFusedKeep min = loop + where + loop n1 Tip = n1 + loop Tip !_ = Tip + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (loop l1 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> case goRFused max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + Just maxV1' -> Bin max1 maxV1' (loop l1 l2) (goRFusedKeep max1 r1 r2) + GT -> Bin max1 maxV1 (loop l1 n2) r1 + + goR1 maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) + | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 + Just minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) + Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (goR1 maxV1 max1 r1 max2 r2) + GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) + + goR2 !_ Tip !_ !_ = Tip + goR2 max1 n1 max2 Tip = deleteR max2 (xor max1 max2) n1 + goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = n1 + goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goR2 max1 n1 max2 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> goR2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> case goLFused min1 l1 l2 of + Empty -> goR2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + Just minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (goR2 max1 r1 max2 r2) + GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 + | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of + Empty -> r1 + NonEmpty min' minV' l' -> Bin min' minV' l' r1 + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of + Empty -> r1 + NonEmpty min' minV' l' -> Bin min' minV' l' r1 + Just minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 (Bin max2 dummyV l2 r2)) r1 + + goRFused max = loop + where + loop Tip !_ = Empty + loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of + DR max' maxV' n' -> NonEmpty max' maxV' n' + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (loop r1 r2) + GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) + + goRFusedKeep max = loop + where + loop n1 Tip = n1 + loop Tip !_ = Tip + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (loop r1 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | otherwise -> case combine min1 minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + Nothing -> case goLFused min1 l1 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + Just minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (loop r1 r2) + GT -> Bin min1 minV1 l1 (loop r1 n2) + + goLookupL k v !_ Tip = NonEmpty k v Tip + goLookupL k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL k v xorCache l + else goLookupR k v xorCacheMax r + | k > max = NonEmpty k v Tip + | otherwise = case combine k v maxV of + Nothing -> Empty + Just v' -> NonEmpty k v' Tip + where xorCacheMax = xor k max + + goLookupR k v !_ Tip = NonEmpty k v Tip + goLookupR k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR k v xorCache r + else goLookupL k v xorCacheMin l + | k < min = NonEmpty k v Tip + | otherwise = case combine k v minV of + Nothing -> Empty + Just v' -> NonEmpty k v' Tip + where xorCacheMin = xor min k + + dummyV = error "impossible" + +-- | /O(n+m)/. The intersection with a combining function. +-- +-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" +intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c +intersectionWith f = intersectionWithKey (const f) + +-- | /O(n+m)/. The intersection with a combining function. +-- +-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar +-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" +intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c +intersectionWithKey combine = start + where + start (IntMap Empty) !_ = IntMap Empty + start !_ (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (goL2 minV2 min1 root1 min2 root2) + | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + | otherwise = IntMap (NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + + -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. + + goL1 _ !_ !_ !_ Tip = Empty + goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 + goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> r2lMap $ NonEmpty max1 (combine max1 maxV1 maxV2) (goRFused max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 (combine max1 maxV1 maxV2) (goRFused max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine max1 maxV1 maxV2) l' (goRFused max1 r1 r2)) + GT -> goL1 minV1 min1 l1 min2 n2 + + goL2 _ !_ Tip !_ !_ = Empty + goL2 minV2 min1 n1 min2 Tip = goLookupL2 min2 minV2 (xor min1 min2) n1 + goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty + goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goL2 minV2 min1 n1 min2 l2 + EQ | max1 > max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL2 minV2 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 (combine max1 maxV1 maxV2) (goRFused max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine max1 maxV1 maxV2) l' (goRFused max1 r1 r2)) + GT | xor min1 min2 < xor min2 max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> r2lMap $ goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 (combine max1 maxV1 maxV2) (goRFused max1 r1 (Bin min2 minV2 l2 r2)) + + goLFused min = loop + where + loop Tip !_ = Tip + loop !_ Tip = Tip + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> case goR2 maxV2 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> loop l1 n2 + + goR1 _ !_ !_ !_ Tip = Empty + goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 + goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> l2rMap $ NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) r') + GT -> goR1 maxV1 max1 r1 max2 n2 + + goR2 _ !_ Tip !_ !_ = Empty + goR2 maxV2 max1 n1 max2 Tip = goLookupR2 max2 maxV2 (xor max1 max2) n1 + goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty + goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goR2 maxV2 max1 n1 max2 r2 + EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> case goR2 maxV2 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) r') + GT | xor min1 max2 > xor max2 max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> l2rMap $ goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) + + goRFused max = loop + where + loop Tip !_ = Tip + loop !_ Tip = Tip + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> case goL2 minV2 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (loop r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> loop r1 n2 + + goLookupL1 !_ _ !_ Tip = Empty + goLookupL1 k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL1 k v xorCache l + else goLookupR1 k v xorCacheMax r + | k > max = Empty + | otherwise = NonEmpty k (combine k v maxV) Tip + where xorCacheMax = xor k max + + goLookupR1 !_ _ !_ Tip = Empty + goLookupR1 k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR1 k v xorCache r + else goLookupL1 k v xorCacheMin l + | k < min = Empty + | otherwise = NonEmpty k (combine k v minV) Tip + where xorCacheMin = xor min k + + goLookupL2 !_ _ !_ Tip = Empty + goLookupL2 k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL2 k v xorCache l + else goLookupR2 k v xorCacheMax r + | k > max = Empty + | otherwise = NonEmpty k (combine k maxV v) Tip + where xorCacheMax = xor k max + + goLookupR2 !_ _ !_ Tip = Empty + goLookupR2 k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR2 k v xorCache r + else goLookupL2 k v xorCacheMin l + | k < min = Empty + | otherwise = NonEmpty k (combine k minV v) Tip + where xorCacheMin = xor min k + +-- | /O(n+m)/. An unsafe general combining function. +-- +-- WARNING: This function can produce corrupt maps and its results +-- may depend on the internal structures of its inputs. Users should +-- prefer 'merge' or 'mergeA'. This function is also significantly slower +-- than 'merge'. +-- +-- When 'mergeWithKey' is given three arguments, it is inlined to the call +-- site. You should therefore use 'mergeWithKey' only to define custom +-- combining functions. For example, you could define 'unionWithKey', +-- 'differenceWithKey' and 'intersectionWithKey' as +-- +-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 +-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 +-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 +-- +-- When calling @'mergeWithKey' combine only1 only2@, a function combining two +-- 'IntMap's is created, such that +-- +-- * if a key is present in both maps, it is passed with both corresponding +-- values to the @combine@ function. Depending on the result, the key is either +-- present in the result with specified value, or is left out; +-- +-- * a nonempty subtree present only in the first map is passed to @only1@ and +-- the output is added to the result; +-- +-- * a nonempty subtree present only in the second map is passed to @only2@ and +-- the output is added to the result. +-- +-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. +-- The values can be modified arbitrarily. Most common variants of @only1@ and +-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@, +-- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@. +mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) -> IntMap a -> IntMap b -> IntMap c +mergeWithKey matched miss1 miss2 = Merge.merge (Merge.mapMaybeMissing (single miss1)) (Merge.mapMaybeMissing (single miss2)) (Merge.zipWithMaybeMatched matched) where + single miss k v = case miss (IntMap (NonEmpty k v Tip)) of + IntMap Empty -> Nothing + IntMap (NonEmpty _ v' _) -> Just v' + +-- | /O(n)/. Map a function over all values in the map. +-- +-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] +map :: (a -> b) -> IntMap a -> IntMap b +map = fmap + +-- | /O(n)/. Map a function over all values in the map. +-- +-- > let f key x = (show key) ++ ":" ++ x +-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] +mapWithKey :: forall a b. (Key -> a -> b) -> IntMap a -> IntMap b +mapWithKey f = start + where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f min minV) (go root)) + + go :: Node t a -> Node t b + go Tip = Tip + go (Bin k v l r) = Bin k (f k v) (go l) (go r) + + +-- | /O(n)/. +-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ +-- That is, behaves exactly like a regular 'traverse' except that the traversing +-- function also has access to the key associated with a value. +-- +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) +traverseWithKey f = start + where + start (IntMap Empty) = pure (IntMap Empty) + start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f min minV <*> goL root + + goL Tip = pure Tip + goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f max maxV + + goR Tip = pure Tip + goR (Bin min minV l r) = Bin min <$> f min minV <*> goL l <*> goR r + +-- | /O(n)/. The function @'mapAccum'@ threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a b = (a ++ b, b ++ "X") +-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) +mapAccum :: (a -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) +mapAccum f = mapAccumWithKey (\a _ x -> f a x) + +-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") +-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) +mapAccumWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) +mapAccumWithKey f = start + where + start a (IntMap Empty) = (a, IntMap Empty) + start a (IntMap (NonEmpty min minV root)) = + let (a', minV') = f a min minV + (a'', root') = goL root a' + in (a'', IntMap (NonEmpty min minV' root')) + + goL Tip a = (a, Tip) + goL (Bin max maxV l r) a = + let (a', l') = goL l a + (a'', r') = goR r a' + (a''', maxV') = f a'' max maxV + in (a''', Bin max maxV' l' r') + + goR Tip a = (a, Tip) + goR (Bin min minV l r) a = + let (a', minV') = f a min minV + (a'', l') = goL l a' + (a''', r') = goR r a'' + in (a''', Bin min minV' l' r') + +-- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating +-- argument through the map in descending order of keys. +mapAccumRWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) +mapAccumRWithKey f = start + where + start a (IntMap Empty) = (a, IntMap Empty) + start a (IntMap (NonEmpty min minV root)) = + let (a', root') = goL root a + (a'', minV') = f a' min minV + in (a'', IntMap (NonEmpty min minV' root')) + + goL Tip a = (a, Tip) + goL (Bin max maxV l r) a = + let (a', maxV') = f a max maxV + (a'', r') = goR r a' + (a''', l') = goL l a'' + in (a''', Bin max maxV' l' r') + + goR Tip a = (a, Tip) + goR (Bin min minV l r) a = + let (a', r') = goR r a + (a'', l') = goL l a' + (a''', minV') = f a'' min minV + in (a''', Bin min minV' l' r') + +-- | /O(n*min(n,W))/. +-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the value at the greatest of the +-- original keys is retained. +-- +-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] +-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" +-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" +mapKeys :: (Key -> Key) -> IntMap a -> IntMap a +mapKeys f = foldlWithKey' (\m k a -> insert (f k) a m) empty + +-- | /O(n*min(n,W))/. +-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the associated values will be +-- combined using @c@. +-- +-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" +-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" +mapKeysWith :: (a -> a -> a) -> (Key -> Key) -> IntMap a -> IntMap a +mapKeysWith combine f = foldlWithKey' (\m k a -> insertWith combine (f k) a m) empty + +-- | /O(n*min(n,W))/. +-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ +-- is strictly monotonic. +-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. +-- /The precondition is not checked./ +-- Semi-formally, we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s +-- > where ls = keys s +-- +-- This means that @f@ maps distinct original keys to distinct resulting keys. +-- This function has slightly better performance than 'mapKeys'. +-- +-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] +mapKeysMonotonic :: (Key -> Key) -> IntMap a -> IntMap a +mapKeysMonotonic = mapKeys + +-- | /O(n)/. Build a map from a set of keys and a function which for each key +-- computes its value. +-- +-- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] +-- > fromSet undefined Data.IntSet.empty == empty +fromSet :: (Key -> a) -> Data.IntSet.IntSet -> IntMap a +fromSet f = fromDistinctAscList . Data.List.map (\k -> (k, f k)) . Data.IntSet.toList + +-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. +fromList :: [(Key, a)] -> IntMap a +fromList = Data.List.foldl' (\t (k, a) -> insert k a t) empty + +-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- +-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] +-- > fromListWith (++) [] == empty +fromListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a +fromListWith f = Data.List.foldl' (\t (k, a) -> insertWith f k a t) empty + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] +-- > fromListWithKey f [] == empty +fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a +fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty + +-- TODO: Use the ordering + +-- | /O(n)/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order. +-- +-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] +fromAscList :: [(Key, a)] -> IntMap a +fromAscList = fromList + +-- | /O(n)/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order. +-- +-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] +fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a +fromAscListWith = fromListWith + +-- | /O(n)/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +-- /The precondition (input list is ascending) is not checked./ +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] +fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a +fromAscListWithKey = fromListWithKey + +-- | /O(n)/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order and all distinct. +-- /The precondition (input list is strictly ascending) is not checked./ +-- +-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +fromDistinctAscList :: [(Key, a)] -> IntMap a +fromDistinctAscList = fromList + +-- | /O(n)/. Map values and collect the 'Just' results. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" +mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b +mapMaybe f = mapMaybeWithKey (const f) + +-- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- +-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing +-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" +mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b +mapMaybeWithKey f = start + where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = case f min minV of + Just minV' -> IntMap (NonEmpty min minV' (goL root)) + Nothing -> IntMap (goDeleteL root) + + goL Tip = Tip + goL (Bin max maxV l r) = case f max maxV of + Just maxV' -> Bin max maxV' (goL l) (goR r) + Nothing -> case goDeleteR r of + Empty -> goL l + NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' + + goR Tip = Tip + goR (Bin min minV l r) = case f min minV of + Just minV' -> Bin min minV' (goL l) (goR r) + Nothing -> case goDeleteL l of + Empty -> goR r + NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) + + goDeleteL Tip = Empty + goDeleteL (Bin max maxV l r) = case f max maxV of + Just maxV' -> case goDeleteL l of + Empty -> case goR r of + Tip -> NonEmpty max maxV' Tip + Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) + NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR r)) + Nothing -> binL (goDeleteL l) (goDeleteR r) + + goDeleteR Tip = Empty + goDeleteR (Bin min minV l r) = case f min minV of + Just minV' -> case goDeleteR r of + Empty -> case goL l of + Tip -> NonEmpty min minV' Tip + Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) + NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL l) r') + Nothing -> binR (goDeleteL l) (goDeleteR r) + +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- +-- > let f a = if a < "c" then Left a else Right a +-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) +-- > +-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) +mapEither f = mapEitherWithKey (const f) + +-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +-- +-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) +-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) +-- > +-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) +mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) +mapEitherWithKey func = start + where + start (IntMap Empty) = (IntMap Empty, IntMap Empty) + start (IntMap (NonEmpty min minV root)) = case func min minV of + Left v -> let SP t f = goTrueL root + in (IntMap (NonEmpty min v t), IntMap f) + Right v -> let SP t f = goFalseL root + in (IntMap t, IntMap (NonEmpty min v f)) + + goTrueL Tip = SP Tip Empty + goTrueL (Bin max maxV l r) = case func max maxV of + Left v -> let SP tl fl = goTrueL l + SP tr fr = goTrueR r + in SP (Bin max v tl tr) (binL fl fr) + Right v -> let SP tl fl = goTrueL l + SP tr fr = goFalseR r + t = case tr of + Empty -> tl + NonEmpty max' maxV' r' -> Bin max' maxV' tl r' + f = case fl of + Empty -> r2lMap $ NonEmpty max v fr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' fr) + in SP t f + + goTrueR Tip = SP Tip Empty + goTrueR (Bin min minV l r) = case func min minV of + Left v -> let SP tl fl = goTrueL l + SP tr fr = goTrueR r + in SP (Bin min v tl tr) (binR fl fr) + Right v -> let SP tl fl = goFalseL l + SP tr fr = goTrueR r + t = case tl of + Empty -> tr + NonEmpty min' minV' l' -> Bin min' minV' l' tr + f = case fr of + Empty -> l2rMap $ NonEmpty min v fl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v fl r') + in SP t f + + goFalseL Tip = SP Empty Tip + goFalseL (Bin max maxV l r) = case func max maxV of + Left v -> let SP tl fl = goFalseL l + SP tr fr = goTrueR r + t = case tl of + Empty -> r2lMap $ NonEmpty max v tr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' tr) + f = case fr of + Empty -> fl + NonEmpty max' maxV' r' -> Bin max' maxV' fl r' + in SP t f + Right v -> let SP tl fl = goFalseL l + SP tr fr = goFalseR r + in SP (binL tl tr) (Bin max v fl fr) + + goFalseR Tip = SP Empty Tip + goFalseR (Bin min minV l r) = case func min minV of + Left v -> let SP tl fl = goTrueL l + SP tr fr = goFalseR r + t = case tr of + Empty -> l2rMap $ NonEmpty min v tl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v tl r') + f = case fl of + Empty -> fr + NonEmpty min' minV' l' -> Bin min' minV' l' fr + in SP t f + Right v -> let SP tl fl = goFalseL l + SP tr fr = goFalseR r + in SP (binR tl tr) (Bin min v fl fr) + +-- | /O(min(n,W))/. Update the value at the minimal key. +-- +-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] +-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a +updateMin _ (IntMap Empty) = IntMap Empty +updateMin f m = update f (fst (findMin m)) m + +-- | /O(min(n,W))/. Update the value at the maximal key. +-- +-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] +-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a +updateMax _ (IntMap Empty) = IntMap Empty +updateMax f m = update f (fst (findMax m)) m + +-- | /O(min(n,W))/. Update the value at the minimal key. +-- +-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] +-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a +updateMinWithKey _ (IntMap Empty) = IntMap Empty +updateMinWithKey f m = updateWithKey f (fst (findMin m)) m + +-- | /O(min(n,W))/. Update the value at the maximal key. +-- +-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] +-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a +updateMaxWithKey _ (IntMap Empty) = IntMap Empty +updateMaxWithKey f m = updateWithKey f (fst (findMax m)) m diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs new file mode 100644 index 000000000..30a1ab78c --- /dev/null +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -0,0 +1,595 @@ +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.IntMap.Merge.Internal +-- Copyright : (c) Jonathan S. 2016 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- This contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +-- +-- = Description +-- +-- This defines the data structures and core (hidden) manipulations +-- on representations. +----------------------------------------------------------------------------- + +module Data.IntMap.Merge.Internal where + +import Prelude hiding (min, max) +import Data.Functor.Identity (Identity, runIdentity) + +import Data.IntMap.Internal + +-- | A tactic for dealing with keys present in one map but not the other in +-- 'merge' or 'mergeA'. +-- +-- A tactic of type @ WhenMissing f a c @ is an abstract representation +-- of a function of type @ Key -> a -> f (Maybe c) @. +data WhenMissing f a b = WhenMissing { + missingSingle :: Key -> a -> Maybe b, + missingLeft :: Node L a -> Node L b, + missingRight :: Node R a -> Node R b, + missingAll :: IntMap a -> f (IntMap b) +} + +-- | A tactic for dealing with keys present in one map but not the other in +-- 'merge'. +-- +-- A tactic of type @ SimpleWhenMissing a c @ is an abstract representation +-- of a function of type @ Key -> a -> Maybe c @. +type SimpleWhenMissing = WhenMissing Identity + +-- | Drop all the entries whose keys are missing from the other +-- map. +-- +-- @ +-- dropMissing :: SimpleWhenMissing a b +-- @ +-- +-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing) +-- +-- but @dropMissing@ is much faster. +{-# INLINE dropMissing #-} +dropMissing :: Applicative f => WhenMissing f a b +dropMissing = WhenMissing (\_ _ -> Nothing) (const Tip) (const Tip) (const (pure (IntMap Empty))) + +-- | Preserve, unchanged, the entries whose keys are missing from +-- the other map. +-- +-- @ +-- preserveMissing :: SimpleWhenMissing a a +-- @ +-- +-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x) +-- +-- but @preserveMissing@ is much faster. +{-# INLINE preserveMissing #-} +preserveMissing :: Applicative f => WhenMissing f a a +preserveMissing = WhenMissing (\_ v -> Just v) id id pure + +-- | Filter the entries whose keys are missing from the other map. +-- +-- @ +-- filterMissing :: (Key -> x -> Bool) -> SimpleWhenMissing a a +-- @ +-- +-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x +-- +-- but this should be a little faster. +filterMissing :: Applicative f => (Key -> a -> Bool) -> WhenMissing f a a +filterMissing p = WhenMissing (\k v -> if p k v then Just v else Nothing) goLKeep goRKeep (pure . start) where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) + | p min minV = IntMap (NonEmpty min minV (goLKeep root)) + | otherwise = IntMap (goL root) + + goLKeep Tip = Tip + goLKeep (Bin max maxV l r) + | p max maxV = Bin max maxV (goLKeep l) (goRKeep r) + | otherwise = case goR r of + Empty -> goLKeep l + NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' + + goRKeep Tip = Tip + goRKeep (Bin min minV l r) + | p min minV = Bin min minV (goLKeep l) (goRKeep r) + | otherwise = case goL l of + Empty -> goRKeep r + NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) + + goL Tip = Empty + goL (Bin max maxV l r) + | p max maxV = case goL l of + Empty -> case goRKeep r of + Tip -> NonEmpty max maxV Tip + Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) + NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV l' (goRKeep r)) + | otherwise = binL (goL l) (goR r) + + goR Tip = Empty + goR (Bin min minV l r) + | p min minV = case goR r of + Empty -> case goLKeep l of + Tip -> NonEmpty min minV Tip + Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) + NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV (goLKeep l) r') + | otherwise = binR (goL l) (goR r) + +-- | A tactic for dealing with keys present in both +-- maps in 'merge' or 'mergeA'. +-- +-- A tactic of type @ WhenMatched f a b c @ is an abstract representation +-- of a function of type @ Key -> a -> b -> f (Maybe c) @. +newtype WhenMatched f a b c = WhenMatched { + matchedSingle :: Key -> a -> b -> f (Maybe c) +} + +-- | A tactic for dealing with keys present in both maps in 'merge'. +-- +-- A tactic of type @ SimpleWhenMatched a b c @ is an abstract representation +-- of a function of type @ Key -> a -> b -> Maybe c @. +type SimpleWhenMatched = WhenMatched Identity + +-- | Merge two maps. +-- +-- @merge@ takes two 'WhenMissing' tactics, a 'WhenMatched' +-- tactic and two maps. It uses the tactics to merge the maps. +-- Its behavior is best understood via its fundamental tactics, +-- 'mapMaybeMissing' and 'zipWithMaybeMatched'. +-- +-- Consider +-- +-- @ +-- merge (mapMaybeMissing g1) +-- (mapMaybeMissing g2) +-- (zipWithMaybeMatched f) +-- m1 m2 +-- @ +-- +-- Take, for example, +-- +-- @ +-- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')] +-- m2 = [(1, "one"), (2, "two"), (4, "three")] +-- @ +-- +-- @merge@ will first ''align'' these maps by key: +-- +-- @ +-- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')] +-- m2 = [(1, "one"), (2, "two"), (4, "three")] +-- @ +-- +-- It will then pass the individual entries and pairs of entries +-- to @g1@, @g2@, or @f@ as appropriate: +-- +-- @ +-- maybes = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"] +-- @ +-- +-- This produces a 'Maybe' for each key: +-- +-- @ +-- keys = 0 1 2 3 4 +-- results = [Nothing, Just True, Just False, Nothing, Just True] +-- @ +-- +-- Finally, the @Just@ results are collected into a map: +-- +-- @ +-- return value = [(1, True), (2, False), (4, True)] +-- @ +-- +-- The other tactics below are optimizations or simplifications of +-- 'mapMaybeMissing' for special cases. Most importantly, +-- +-- * 'dropMissing' drops all the keys. +-- * 'preserveMissing' leaves all the entries alone. +-- +-- When 'merge' is given three arguments, it is inlined at the call +-- site. To prevent excessive inlining, you should typically use 'merge' +-- to define your custom combining functions. +-- +-- +-- Examples: +-- +-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f) +-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f) +-- prop> differenceWith f = merge preserveMissing dropMissing f +-- prop> symmetricDifference = merge preserveMissing preserveMissing (zipWithMaybeMatched (\_ _ _ -> Nothing)) +-- prop> mapEachPiece f g h = merge (mapMissing f) (mapMissing g) (zipWithMatched h) +{-# INLINE merge #-} +merge :: SimpleWhenMissing a c -> SimpleWhenMissing b c -> SimpleWhenMatched a b c -> IntMap a -> IntMap b -> IntMap c +merge miss1 miss2 match = start where + start (IntMap Empty) (IntMap Empty) = IntMap Empty + start (IntMap Empty) !m2 = runIdentity (missingAll miss2 m2) + start !m1 (IntMap Empty) = runIdentity (missingAll miss1 m1) + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = case missingSingle miss1 min1 minV1 of + Nothing -> IntMap (goL2 minV2 min1 root1 min2 root2) + Just minV' -> IntMap (NonEmpty min1 minV' (goL2Keep minV2 min1 root1 min2 root2)) + | min1 > min2 = case missingSingle miss2 min2 minV2 of + Nothing -> IntMap (goL1 minV1 min1 root1 min2 root2) + Just minV' -> IntMap (NonEmpty min2 minV' (goL1Keep minV1 min1 root1 min2 root2)) + | otherwise = case runIdentity (matchedSingle match min1 minV1 minV2) of + Nothing -> IntMap (goLFused min1 root1 root2) + Just minV' -> IntMap (NonEmpty min1 minV' (goLFusedKeep min1 root1 root2)) + + -- Merge two left nodes and a minimum value for the first node into a new left node + -- Precondition: min1 > min2 + -- goL1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c + goL1Keep minV1 !min1 Tip !_ Tip = case missingSingle miss1 min1 minV1 of + Nothing -> Tip + Just minV' -> Bin min1 minV' Tip Tip + goL1Keep minV1 !min1 Tip !min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1Keep minV1 !min1 n1 !min2 Tip = case missingSingle miss1 min1 minV1 of + Nothing -> missingLeft miss1 n1 + Just minV' -> insertMinL (xor min1 min2) min1 minV' (missingLeft miss1 n1) + goL1Keep minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint + | xor min1 min2 < xor min1 max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missingRight miss2 r2) + | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + Nothing -> case goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + Nothing -> case goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + Nothing -> case goRFused max1 (Bin min1 minV1 l1 r1) r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) + where + {-# INLINE l' #-} + l' = missingLeft miss2 l2 + EQ | max2 < min1 -> disjoint + | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + Nothing -> case goR2 maxV2 max1 r1 max2 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) + | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + Nothing -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) + | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + Nothing -> case goRFused max1 r1 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) + where + {-# INLINE l' #-} + l' = goL1Keep minV1 min1 l1 min2 l2 + GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint + | otherwise -> binL1 max1 maxV1 (goL1Keep minV1 min1 l1 min2 n2) (missingRight miss1 r1) + where + disjoint = binL1 max1 maxV1 (missingLeft miss2 n2) (missingRight miss1 (Bin min1 minV1 l1 r1)) + + -- Merge two left nodes and a minimum value for the second node into a new left node + -- Precondition: min2 > min1 + -- goL2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c + goL2Keep minV2 !_ Tip !min2 Tip = case missingSingle miss2 min2 minV2 of + Nothing -> Tip + Just minV' -> Bin min2 minV' Tip Tip + goL2Keep minV2 !min1 Tip !min2 n2 = case missingSingle miss2 min2 minV2 of + Nothing -> missingLeft miss2 n2 + Just minV' -> insertMinL (xor min1 min2) min2 minV' (missingLeft miss2 n2) + goL2Keep minV2 !min1 n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2Keep minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint + | xor min1 min2 < xor min2 max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missingRight miss1 r1) + | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + Nothing -> case goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + Nothing -> case goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + Nothing -> case goRFused max1 r1 (Bin min2 minV2 l2 r2) of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 (Bin min2 minV2 l2 r2)) + where + {-# INLINE l' #-} + l' = missingLeft miss1 l1 + EQ | max1 < min2 -> disjoint + | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + Nothing -> case goR2 maxV2 max1 r1 max2 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) + | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + Nothing -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) + | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + Nothing -> case goRFused max1 r1 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) + where + {-# INLINE l' #-} + l' = goL2Keep minV2 min1 l1 min2 l2 + LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint + | otherwise -> binL2 max2 maxV2 (goL2Keep minV2 min1 n1 min2 l2) (missingRight miss2 r2) + where + disjoint = binL2 max2 maxV2 (missingLeft miss1 n1) (missingRight miss2 (Bin min2 minV2 l2 r2)) + +-- goLFusedKeep !_ Tip Tip = Tip + goLFusedKeep !_ Tip n2 = missingLeft miss2 n2 + goLFusedKeep !_ n1 Tip = missingLeft miss1 n1 + goLFusedKeep !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> binL2 max2 maxV2 (goLFusedKeep min n1 l2) (missingRight miss2 r2) + EQ | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + Nothing -> case goR2 maxV2 max1 r1 max2 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) + | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + Nothing -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) + | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + Nothing -> case goRFused max1 r1 r2 of + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) + where + {-# INLINE l' #-} + l' = goLFusedKeep min l1 l2 + GT -> binL1 max1 maxV1 (goLFusedKeep min l1 n2) (missingRight miss1 r1) + + -- Merge two right nodes and a maximum value for the first node into a new right node + -- Precondition: max1 < max2 + -- goR1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c + goR1Keep maxV1 !max1 Tip !_ Tip = case missingSingle miss1 max1 maxV1 of + Nothing -> Tip + Just maxV' -> Bin max1 maxV' Tip Tip + goR1Keep maxV1 !max1 Tip !max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 + goR1Keep maxV1 !max1 n1 !max2 Tip = case missingSingle miss1 max1 maxV1 of + Nothing -> missingRight miss1 n1 + Just maxV' -> insertMaxR (xor max1 max2) max1 maxV' (missingRight miss1 n1) + goR1Keep maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint + | xor min2 max1 > xor max1 max2 -> binR2 min2 minV2 (missingLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) + | min1 < min2 -> case missingSingle miss1 min1 minV1 of + Nothing -> case goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' + | min1 > min2 -> case missingSingle miss2 min2 minV2 of + Nothing -> case goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' + | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + Nothing -> case goLFused min1 (Bin max1 maxV1 l1 r1) l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) r' + where + {-# INLINE r' #-} + r' = missingRight miss2 r2 + EQ | max1 < min2 -> disjoint + | min1 < min2 -> case missingSingle miss1 min1 minV1 of + Nothing -> case goL2 minV2 min1 l1 min2 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' + | min1 > min2 -> case missingSingle miss2 min2 minV2 of + Nothing -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' + | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + Nothing -> case goLFused min1 l1 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' + where + {-# INLINE r' #-} + r' = goR1Keep maxV1 max1 r1 max2 r2 + GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint + | otherwise -> binR1 min1 minV1 (missingLeft miss1 l1) (goR1Keep maxV1 max1 r1 max2 n2) + where + disjoint = binR1 min1 minV1 (missingLeft miss1 (Bin max1 maxV1 l1 r1)) (missingRight miss2 n2) + + -- Merge two left nodes and a minimum value for the second node into a new left node + -- Precondition: max2 < max1 + -- goR2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c + goR2Keep maxV2 !_ Tip !max2 Tip = case missingSingle miss2 max2 maxV2 of + Nothing -> Tip + Just maxV' -> Bin max2 maxV' Tip Tip + goR2Keep maxV2 !max1 Tip !max2 n2 = case missingSingle miss2 max2 maxV2 of + Nothing -> missingRight miss2 n2 + Just maxV' -> insertMaxR (xor max1 max2) max2 maxV' (missingRight miss2 n2) + goR2Keep maxV2 !max1 n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2Keep maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint + | xor min1 max2 > xor max2 max1 -> binR1 min1 minV1 (missingLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) + | min1 < min2 -> case missingSingle miss1 min1 minV1 of + Nothing -> case goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' + | min1 > min2 -> case missingSingle miss2 min2 minV2 of + Nothing -> case goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' + | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + Nothing -> case goLFused min1 l1 (Bin max2 maxV2 l2 r2) of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 (Bin max2 maxV2 l2 r2)) r' + where + {-# INLINE r' #-} + r' = missingRight miss1 r1 + EQ | max2 < min1 -> disjoint + | min1 < min2 -> case missingSingle miss1 min1 minV1 of + Nothing -> case goL2 minV2 min1 l1 min2 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' + | min1 > min2 -> case missingSingle miss2 min2 minV2 of + Nothing -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' + | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + Nothing -> case goLFused min1 l1 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' + where + {-# INLINE r' #-} + r' = goR2Keep maxV2 max1 r1 max2 r2 + LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint + | otherwise -> binR2 min2 minV2 (missingLeft miss2 l2) (goR2Keep maxV2 max1 n1 max2 r2) + where + disjoint = binR2 min2 minV2 (missingLeft miss2 (Bin max2 maxV2 l2 r2)) (missingRight miss1 n1) + +-- goRFusedKeep !_ Tip Tip = Tip + goRFusedKeep !_ Tip n2 = missingRight miss2 n2 + goRFusedKeep !_ n1 Tip = missingRight miss1 n1 + goRFusedKeep !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> binR2 min2 minV2 (missingLeft miss2 l2) (goRFusedKeep max n1 r2) + EQ | min1 < min2 -> case missingSingle miss1 min1 minV1 of + Nothing -> case goL2 minV2 min1 l1 min2 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' + | min1 > min2 -> case missingSingle miss2 min2 minV2 of + Nothing -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' + | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + Nothing -> case goLFused min1 l1 l2 of + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' + where + {-# INLINE r' #-} + r' = goRFusedKeep max r1 r2 + GT -> binR1 min1 minV1 (missingLeft miss1 l1) (goRFusedKeep max r1 n2) + + goL1 minV1 !min1 !n1 !min2 !n2 = nodeToMapL (goL1Keep minV1 min1 n1 min2 n2) + goL2 minV2 !min1 !n1 !min2 !n2 = nodeToMapL (goL2Keep minV2 min1 n1 min2 n2) + goLFused !min !n1 !n2 = nodeToMapL (goLFusedKeep min n1 n2) + goR1 maxV1 !max1 !n1 !max2 !n2 = nodeToMapR (goR1Keep maxV1 max1 n1 max2 n2) + goR2 maxV2 !max1 !n1 !max2 !n2 = nodeToMapR (goR2Keep maxV2 max1 n1 max2 n2) + goRFused !max !n1 !n2 = nodeToMapR (goRFusedKeep max n1 n2) + + goInsertL1 !k v !_ _ Tip = case missingSingle miss1 k v of + Nothing -> Tip + Just v' -> Bin k v' Tip Tip + goInsertL1 !k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then binL2 max maxV (goInsertL1 k v xorCache min l) (missingRight miss2 r) + else binL2 max maxV (missingLeft miss2 l) (goInsertR1 k v xorCacheMax max r) + | k > max = case missingSingle miss1 k v of + Nothing -> missingLeft miss2 (Bin max maxV l r) + Just v' -> if xor min max < xorCacheMax + then Bin k v' (missingLeft miss2 (Bin max maxV l r)) Tip + else Bin k v' (missingLeft miss2 l) (missingRight miss2 (insertMaxR xorCacheMax max maxV r)) + | otherwise = case runIdentity (matchedSingle match max v maxV) of + Nothing -> extractBinL (missingLeft miss2 l) (missingRight miss2 r) -- TODO: do extractBin first? + Just maxV' -> Bin max maxV' (missingLeft miss2 l) (missingRight miss2 r) + where xorCacheMax = xor k max + + goInsertL2 !k v !_ _ Tip = case missingSingle miss2 k v of + Nothing -> Tip + Just v' -> Bin k v' Tip Tip + goInsertL2 !k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then binL1 max maxV (goInsertL2 k v xorCache min l) (missingRight miss1 r) + else binL1 max maxV (missingLeft miss1 l) (goInsertR2 k v xorCacheMax max r) + | k > max = case missingSingle miss2 k v of + Nothing -> missingLeft miss1 (Bin max maxV l r) + Just v' -> if xor min max < xorCacheMax + then Bin k v' (missingLeft miss1 (Bin max maxV l r)) Tip + else Bin k v' (missingLeft miss1 l) (missingRight miss1 (insertMaxR xorCacheMax max maxV r)) + | otherwise = case runIdentity (matchedSingle match max maxV v) of + Nothing -> extractBinL (missingLeft miss1 l) (missingRight miss1 r) -- TODO: do extractBin first? + Just maxV' -> Bin max maxV' (missingLeft miss1 l) (missingRight miss1 r) + where xorCacheMax = xor k max + + goInsertR1 k v !_ _ Tip = case missingSingle miss1 k v of + Nothing -> Tip + Just v' -> Bin k v' Tip Tip + goInsertR1 k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then binR2 min minV (missingLeft miss2 l) (goInsertR1 k v xorCache max r) + else binR2 min minV (goInsertL1 k v xorCacheMin min l) (missingRight miss2 r) + | k < min = case missingSingle miss1 k v of + Nothing -> missingRight miss2 (Bin min minV l r) + Just v' -> if xor min max < xorCacheMin + then Bin k v' Tip (missingRight miss2 (Bin min minV l r)) + else Bin k v' (missingLeft miss2 (insertMinL xorCacheMin min minV l)) (missingRight miss2 r) + | otherwise = case runIdentity (matchedSingle match min v minV) of + Nothing -> extractBinR (missingLeft miss2 l) (missingRight miss2 r) -- TODO: do extractBin first? + Just minV' -> Bin min minV' (missingLeft miss2 l) (missingRight miss2 r) + where xorCacheMin = xor k min + + goInsertR2 !k v !_ _ Tip = case missingSingle miss2 k v of + Nothing -> Tip + Just v' -> Bin k v' Tip Tip + goInsertR2 !k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then binR1 min minV (missingLeft miss1 l) (goInsertR2 k v xorCache max r) + else binR1 min minV (goInsertL2 k v xorCacheMin min l) (missingRight miss1 r) + | k < min = case missingSingle miss2 k v of + Nothing -> missingRight miss1 (Bin min minV l r) + Just v' -> if xor min max < xorCacheMin + then Bin k v' Tip (missingRight miss1 (Bin min minV l r)) + else Bin k v' (missingLeft miss1 (insertMinL xorCacheMin min minV l)) (missingRight miss1 r) + | otherwise = case runIdentity (matchedSingle match min minV v) of + Nothing -> extractBinR (missingLeft miss1 l) (missingRight miss1 r) -- TODO: do extractBin first? + Just minV' -> Bin min minV' (missingLeft miss1 l) (missingRight miss1 r) + where xorCacheMin = xor k min + + {-# INLINE binL1 #-} + binL1 k1 v1 l r = case missingSingle miss1 k1 v1 of + Nothing -> extractBinL l r + Just v' -> Bin k1 v' l r + + {-# INLINE binL2 #-} + binL2 k2 v2 l r = case missingSingle miss2 k2 v2 of + Nothing -> extractBinL l r + Just v' -> Bin k2 v' l r + + {-# INLINE binR1 #-} + binR1 k1 v1 l r = case missingSingle miss1 k1 v1 of + Nothing -> extractBinR l r + Just v' -> Bin k1 v' l r + + {-# INLINE binR2 #-} + binR2 k2 v2 l r = case missingSingle miss2 k2 v2 of + Nothing -> extractBinR l r + Just v' -> Bin k2 v' l r diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index c24d0e45f..8e5a1408b 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -1,104 +1,143 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#endif -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -#define USE_MAGIC_PROXY 1 -#endif - -#if USE_MAGIC_PROXY -{-# LANGUAGE MagicHash #-} -#endif - -#include "containers.h" +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Merge.Lazy --- Copyright : (c) wren romano 2016 +-- Copyright : (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org +-- Stability : provisional -- Portability : portable -- -- This module defines an API for writing functions that merge two -- maps. The key functions are 'merge' and 'mergeA'. --- Each of these can be used with several different \"merge tactics\". +-- Each of these can be used with several different "merge tactics". -- -- The 'merge' and 'mergeA' functions are shared by -- the lazy and strict modules. Only the choice of merge tactics --- determines strictness. If you use 'Data.Map.Merge.Strict.mapMissing' --- from "Data.Map.Merge.Strict" then the results will be forced before --- they are inserted. If you use 'Data.Map.Merge.Lazy.mapMissing' from +-- determines strictness. If you use 'Data.IntMap.Merge.Strict.mapMissing' +-- from "Data.IntMap.Merge.Strict" then the results will be forced before +-- they are inserted. If you use 'Data.IntMap.Merge.Lazy.mapMissing' from -- this module then they will not. -- -- == Efficiency note -- --- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for --- 'WhenMissing' tactics are included because they are valid. However, they are +-- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing' +-- tactics are included because they are valid. However, they are -- inefficient in many cases and should usually be avoided. The instances -- for 'WhenMatched' tactics should not pose any major efficiency problems. --- --- @since 0.5.9 module Data.IntMap.Merge.Lazy ( -- ** Simple merge tactic types - SimpleWhenMissing - , SimpleWhenMatched + WhenMissing + , WhenMatched -- ** General combining function , merge - -- *** @WhenMatched@ tactics + -- ** @WhenMatched@ tactics , zipWithMaybeMatched , zipWithMatched -- *** @WhenMissing@ tactics - , mapMaybeMissing , dropMissing , preserveMissing , mapMissing + , mapMaybeMissing , filterMissing +) where - -- ** Applicative merge tactic types - , WhenMissing - , WhenMatched +import Prelude hiding (min, max) - -- ** Applicative general combining function - , mergeA +import Data.IntMap.Internal +import Data.IntMap.Merge.Internal - -- *** @WhenMatched@ tactics - -- | The tactics described for 'merge' work for - -- 'mergeA' as well. Furthermore, the following - -- are available. - , zipWithMaybeAMatched - , zipWithAMatched +-- | Map over the entries whose keys are missing from the other map. +-- +-- @ +-- mapMissing :: (Key -> a -> b) -> SimpleWhenMissing a b +-- @ +-- +-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) +-- +-- but @mapMissing@ is somewhat faster. +mapMissing :: forall f a b. Applicative f => (Key -> a -> b) -> WhenMissing f a b +mapMissing f = WhenMissing (\k v -> Just (f k v)) go go (pure . start) where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f min minV) (go root)) - -- *** @WhenMissing@ tactics - -- | The tactics described for 'merge' work for - -- 'mergeA' as well. Furthermore, the following - -- are available. - , traverseMaybeMissing - , traverseMissing - , filterAMissing - - -- *** Covariant maps for tactics - , mapWhenMissing - , mapWhenMatched - - -- *** Contravariant maps for tactics - , lmapWhenMissing - , contramapFirstWhenMatched - , contramapSecondWhenMatched - - -- *** Miscellaneous tactic functions - , runWhenMatched - , runWhenMissing - ) where + go :: Node t a -> Node t b + go Tip = Tip + go (Bin k v l r) = Bin k (f k v) (go l) (go r) -import Data.IntMap.Internal +-- | Map over the entries whose keys are missing from the other map, +-- optionally removing some. This is the most powerful 'SimpleWhenMissing' +-- tactic, but others are usually more efficient. +-- +-- @ +-- mapMaybeMissing :: (Key -> a -> Maybe b) -> SimpleWhenMissing a b +-- @ +-- +-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x)) +-- +-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. +mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b +mapMaybeMissing f = WhenMissing f goLKeep goRKeep (pure . start) where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = case f min minV of + Just minV' -> IntMap (NonEmpty min minV' (goLKeep root)) + Nothing -> IntMap (goL root) + + goLKeep Tip = Tip + goLKeep (Bin max maxV l r) = case f max maxV of + Just maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) + Nothing -> case goR r of + Empty -> goLKeep l + NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' + + goRKeep Tip = Tip + goRKeep (Bin min minV l r) = case f min minV of + Just minV' -> Bin min minV' (goLKeep l) (goRKeep r) + Nothing -> case goL l of + Empty -> goRKeep r + NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) + + goL Tip = Empty + goL (Bin max maxV l r) = case f max maxV of + Just maxV' -> case goL l of + Empty -> case goRKeep r of + Tip -> NonEmpty max maxV' Tip + Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) + NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goRKeep r)) + Nothing -> binL (goL l) (goR r) + + goR Tip = Empty + goR (Bin min minV l r) = case f min minV of + Just minV' -> case goR r of + Empty -> case goLKeep l of + Tip -> NonEmpty min minV' Tip + Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) + NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goLKeep l) r') + Nothing -> binR (goL l) (goR r) + +-- | When a key is found in both maps, apply a function to the +-- key and values and maybe use the result in the merged map. +-- +-- @ +-- zipWithMaybeMatched :: (Key -> a -> b -> Maybe c) +-- -> SimpleWhenMatched a b c +-- @ +{-# INLINE zipWithMaybeMatched #-} +zipWithMaybeMatched :: Applicative f => (Key -> a -> b -> Maybe c) -> WhenMatched f a b c +zipWithMaybeMatched f = WhenMatched (\k a b -> pure (f k a b)) + +-- | When a key is found in both maps, apply a function to the +-- key and values and use the result in the merged map. +-- +-- @ +-- zipWithMatched :: (Key -> a -> b -> c) +-- -> SimpleWhenMatched a b c +-- @ +{-# INLINE zipWithMatched #-} +zipWithMatched :: Applicative f => (Key -> a -> b -> c) -> WhenMatched f a b c +zipWithMatched f = zipWithMaybeMatched (\k a b -> Just (f k a b)) diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index d21c4e1ca..8ad467896 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -1,233 +1,150 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#if __GLASGOW_HASKELL__ -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#endif -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -#define USE_MAGIC_PROXY 1 -#endif - -#if USE_MAGIC_PROXY -{-# LANGUAGE MagicHash #-} -#endif - -#include "containers.h" +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Merge.Strict --- Copyright : (c) wren romano 2016 +-- Copyright : (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org +-- Stability : provisional -- Portability : portable -- -- This module defines an API for writing functions that merge two -- maps. The key functions are 'merge' and 'mergeA'. --- Each of these can be used with several different \"merge tactics\". +-- Each of these can be used with several different "merge tactics". -- -- The 'merge' and 'mergeA' functions are shared by -- the lazy and strict modules. Only the choice of merge tactics --- determines strictness. If you use 'Data.Map.Merge.Strict.mapMissing' +-- determines strictness. If you use 'Data.IntMap.Merge.Strict.mapMissing' -- from this module then the results will be forced before they are --- inserted. If you use 'Data.Map.Merge.Lazy.mapMissing' from +-- inserted. If you use 'Data.IntMap.Merge.Lazy.mapMissing' from -- "Data.Map.Merge.Lazy" then they will not. -- -- == Efficiency note -- --- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for --- 'WhenMissing' tactics are included because they are valid. However, they are +-- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing' +-- tactics are included because they are valid. However, they are -- inefficient in many cases and should usually be avoided. The instances -- for 'WhenMatched' tactics should not pose any major efficiency problems. --- --- @since 0.5.9 module Data.IntMap.Merge.Strict ( -- ** Simple merge tactic types - SimpleWhenMissing - , SimpleWhenMatched + WhenMissing + , WhenMatched -- ** General combining function , merge - -- *** @WhenMatched@ tactics + -- ** @WhenMatched@ tactics , zipWithMaybeMatched , zipWithMatched -- *** @WhenMissing@ tactics - , mapMaybeMissing , dropMissing , preserveMissing , mapMissing + , mapMaybeMissing , filterMissing +) where - -- ** Applicative merge tactic types - , WhenMissing - , WhenMatched - - -- ** Applicative general combining function - , mergeA - - -- *** @WhenMatched@ tactics - -- | The tactics described for 'merge' work for - -- 'mergeA' as well. Furthermore, the following - -- are available. - , zipWithMaybeAMatched - , zipWithAMatched - - -- *** @WhenMissing@ tactics - -- | The tactics described for 'merge' work for - -- 'mergeA' as well. Furthermore, the following - -- are available. - , traverseMaybeMissing - , traverseMissing - , filterAMissing - - -- ** Covariant maps for tactics - , mapWhenMissing - , mapWhenMatched - - -- ** Miscellaneous functions on tactics - - , runWhenMatched - , runWhenMissing - ) where +import Prelude hiding (min, max) import Data.IntMap.Internal - ( SimpleWhenMissing - , SimpleWhenMatched - , merge - , dropMissing - , preserveMissing - , filterMissing - , WhenMissing (..) - , WhenMatched (..) - , mergeA - , filterAMissing - , runWhenMatched - , runWhenMissing - ) -import Data.IntMap.Strict.Internal -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative (..), (<$>)) -#endif -import Prelude hiding (filter, map, foldl, foldr) - --- | Map covariantly over a @'WhenMissing' f k x@. -mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f x a -> WhenMissing f x b -mapWhenMissing f q = WhenMissing - { missingSubtree = fmap (map f) . missingSubtree q - , missingKey = \k x -> fmap (forceMaybe . fmap f) $ missingKey q k x} - --- | Map covariantly over a @'WhenMatched' f k x y@. -mapWhenMatched :: Functor f => (a -> b) -> WhenMatched f x y a -> WhenMatched f x y b -mapWhenMatched f q = WhenMatched - { matchedKey = \k x y -> fmap (forceMaybe . fmap f) $ runWhenMatched q k x y } +import Data.IntMap.Merge.Internal --- | When a key is found in both maps, apply a function to the --- key and values and maybe use the result in the merged map. +(#!), (#) :: (a -> b) -> a -> b +(#!) = ($!) +(#) = ($) + +-- | Map over the entries whose keys are missing from the other map. -- -- @ --- zipWithMaybeMatched :: (k -> x -> y -> Maybe z) --- -> SimpleWhenMatched k x y z +-- mapMissing :: (Key -> a -> b) -> SimpleWhenMissing a b -- @ -zipWithMaybeMatched :: Applicative f - => (Key -> x -> y -> Maybe z) - -> WhenMatched f x y z -zipWithMaybeMatched f = WhenMatched $ - \k x y -> pure $! forceMaybe $! f k x y -{-# INLINE zipWithMaybeMatched #-} - --- | When a key is found in both maps, apply a function to the --- key and values, perform the resulting action, and maybe use --- the result in the merged map. -- --- This is the fundamental 'WhenMatched' tactic. -zipWithMaybeAMatched :: Applicative f - => (Key -> x -> y -> f (Maybe z)) - -> WhenMatched f x y z -zipWithMaybeAMatched f = WhenMatched $ - \ k x y -> forceMaybe <$> f k x y -{-# INLINE zipWithMaybeAMatched #-} - --- | When a key is found in both maps, apply a function to the --- key and values to produce an action and use its result in the merged map. -zipWithAMatched :: Applicative f - => (Key -> x -> y -> f z) - -> WhenMatched f x y z -zipWithAMatched f = WhenMatched $ - \ k x y -> (Just $!) <$> f k x y -{-# INLINE zipWithAMatched #-} - --- | When a key is found in both maps, apply a function to the --- key and values and use the result in the merged map. +-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) -- --- @ --- zipWithMatched :: (k -> x -> y -> z) --- -> SimpleWhenMatched k x y z --- @ -zipWithMatched :: Applicative f - => (Key -> x -> y -> z) -> WhenMatched f x y z -zipWithMatched f = WhenMatched $ - \k x y -> pure $! Just $! f k x y -{-# INLINE zipWithMatched #-} +-- but @mapMissing@ is somewhat faster. +mapMissing :: forall f a b. Applicative f => (Key -> a -> b) -> WhenMissing f a b +mapMissing f = WhenMissing (\k v -> Just $! f k v) go go (pure . start) where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # go root) + + go :: Node t a -> Node t b + go Tip = Tip + go (Bin k v l r) = Bin k #! f k v # go l # go r -- | Map over the entries whose keys are missing from the other map, -- optionally removing some. This is the most powerful 'SimpleWhenMissing' -- tactic, but others are usually more efficient. -- -- @ --- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y +-- mapMaybeMissing :: (Key -> a -> Maybe b) -> SimpleWhenMissing a b -- @ -- -- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x)) -- -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. -mapMaybeMissing :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y -mapMaybeMissing f = WhenMissing - { missingSubtree = \m -> pure $! mapMaybeWithKey f m - , missingKey = \k x -> pure $! forceMaybe $! f k x } -{-# INLINE mapMaybeMissing #-} +mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b +mapMaybeMissing f = WhenMissing f goLKeep goRKeep (pure . start) where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = case f min minV of + Just !minV' -> IntMap (NonEmpty min minV' (goLKeep root)) + Nothing -> IntMap (goL root) + + goLKeep Tip = Tip + goLKeep (Bin max maxV l r) = case f max maxV of + Just !maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) + Nothing -> case goR r of + Empty -> goLKeep l + NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' + + goRKeep Tip = Tip + goRKeep (Bin min minV l r) = case f min minV of + Just !minV' -> Bin min minV' (goLKeep l) (goRKeep r) + Nothing -> case goL l of + Empty -> goRKeep r + NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) + + goL Tip = Empty + goL (Bin max maxV l r) = case f max maxV of + Just !maxV' -> case goL l of + Empty -> case goRKeep r of + Tip -> NonEmpty max maxV' Tip + Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) + NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goRKeep r)) + Nothing -> binL (goL l) (goR r) + + goR Tip = Empty + goR (Bin min minV l r) = case f min minV of + Just !minV' -> case goR r of + Empty -> case goLKeep l of + Tip -> NonEmpty min minV' Tip + Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) + NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goLKeep l) r') + Nothing -> binR (goL l) (goR r) --- | Map over the entries whose keys are missing from the other map. + +-- | When a key is found in both maps, apply a function to the +-- key and values and maybe use the result in the merged map. -- -- @ --- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y +-- zipWithMaybeMatched :: (Key -> a -> b -> Maybe c) +-- -> SimpleWhenMatched a b c -- @ +{-# INLINE zipWithMaybeMatched #-} +zipWithMaybeMatched :: Applicative f => (Key -> a -> b -> Maybe c) -> WhenMatched f a b c +zipWithMaybeMatched f = WhenMatched (\k a b -> case f k a b of + Nothing -> pure Nothing + Just !c -> pure (Just c)) + +-- | When a key is found in both maps, apply a function to the +-- key and values and use the result in the merged map. -- --- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) --- --- but @mapMissing@ is somewhat faster. -mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y -mapMissing f = WhenMissing - { missingSubtree = \m -> pure $! mapWithKey f m - , missingKey = \k x -> pure $! Just $! f k x } -{-# INLINE mapMissing #-} - --- | Traverse over the entries whose keys are missing from the other map, --- optionally producing values to put in the result. --- This is the most powerful 'WhenMissing' tactic, but others are usually --- more efficient. -traverseMaybeMissing :: Applicative f - => (Key -> x -> f (Maybe y)) -> WhenMissing f x y -traverseMaybeMissing f = WhenMissing - { missingSubtree = traverseMaybeWithKey f - , missingKey = \k x -> forceMaybe <$> f k x } -{-# INLINE traverseMaybeMissing #-} - --- | Traverse over the entries whose keys are missing from the other map. -traverseMissing :: Applicative f - => (Key -> x -> f y) -> WhenMissing f x y -traverseMissing f = WhenMissing - { missingSubtree = traverseWithKey f - , missingKey = \k x -> (Just $!) <$> f k x } -{-# INLINE traverseMissing #-} - -forceMaybe :: Maybe a -> Maybe a -forceMaybe Nothing = Nothing -forceMaybe m@(Just !_) = m -{-# INLINE forceMaybe #-} +-- @ +-- zipWithMatched :: (Key -> a -> b -> c) +-- -> SimpleWhenMatched a b c +-- @ +{-# INLINE zipWithMatched #-} +zipWithMatched :: Applicative f => (Key -> a -> b -> c) -> WhenMatched f a b c +zipWithMatched f = zipWithMaybeMatched (\k a b -> Just $! f k a b) diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 938e9e770..0547bbceb 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1,13 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} - -#include "containers.h" +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Strict.Internal -- Copyright : (c) Daan Leijen 2002 -- (c) Andriy Palamarchuk 2008 +-- (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable @@ -64,31 +62,37 @@ -- -- == Implementation -- --- The implementation is based on /big-endian patricia trees/. This data --- structure performs especially well on binary operations like 'union' and --- 'intersection'. Additionally, benchmarks show that it is also (much) faster --- on insertions and deletions when compared to a generic size-balanced map --- implementation (see "Data.Map"). --- --- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", --- Workshop on ML, September 1998, pages 77-86, --- --- --- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve --- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), --- October 1968, pages 514-534. +-- Operation comments contain the operation time complexity in +-- the Big-O notation . +-- Many operations have a worst-case complexity of /O(min(n,W))/. +-- This means that the operation can become linear in the number of +-- elements with a maximum of /W/ -- the number of bits in an 'Int' +-- (32 or 64). -- +-- Be aware that the 'Functor', 'Traversable' and 'Data' instances +-- are the same as for the "Data.IntMap.Lazy" module, so if they are used +-- on strict maps, the resulting maps will be lazy. ----------------------------------------------------------------------------- --- See the notes at the beginning of Data.IntMap.Internal. - -module Data.IntMap.Strict.Internal ( +module Data.IntMap.Strict ( -- * Map type -#if !defined(TESTING) - IntMap, Key -- instance Eq,Show -#else - IntMap(..), Key -- instance Eq,Show -#endif + IntMap, Key + + -- * Operators + , (!) + , (\\) + + -- * Query + , null + , size + , member + , notMember + , lookup + , findWithDefault + , lookupLT + , lookupGT + , lookupLE + , lookupGE -- * Construction , empty @@ -140,7 +144,6 @@ module Data.IntMap.Strict.Internal ( , size -- * Combine - -- ** Union , union , unionWith @@ -159,10 +162,7 @@ module Data.IntMap.Strict.Internal ( , intersectionWith , intersectionWithKey - -- ** Disjoint - , disjoint - - -- ** Universal combining function + -- ** Deprecated, unsafe general combining function , mergeWithKey -- * Traversal @@ -200,7 +200,7 @@ module Data.IntMap.Strict.Internal ( -- ** Lists , toList --- ** Ordered lists + -- ** Ordered Lists , toAscList , toDescList @@ -211,19 +211,19 @@ module Data.IntMap.Strict.Internal ( , withoutKeys , partition , partitionWithKey - , mapMaybe , mapMaybeWithKey , mapEither , mapEitherWithKey - , split , splitLookup , splitRoot -- * Submap - , isSubmapOf, isSubmapOfBy - , isProperSubmapOf, isProperSubmapOfBy + , isSubmapOf + , isSubmapOfBy + , isProperSubmapOf + , isProperSubmapOfBy -- * Min\/Max , lookupMin @@ -247,170 +247,72 @@ module Data.IntMap.Strict.Internal ( -- * Debugging , showTree , showTreeWith -#endif - ) where + , valid +) where -import Prelude hiding (lookup,map,filter,foldr,foldl,null) - -import Data.Bits -import qualified Data.IntMap.Internal as L import Data.IntMap.Internal - ( IntMap (..) - , Key - , Prefix - , Mask - , mask - , branchMask - , shorter - , nomatch - , zero - , natFromInt - , intFromNat - , bin - , binCheckLeft - , binCheckRight - , link - , linkWithMask - - , (\\) - , (!) - , (!?) - , empty - , assocs - , filter - , filterWithKey - , findMin - , findMax - , foldMapWithKey - , foldr - , foldl - , foldr' - , foldl' - , foldlWithKey - , foldrWithKey - , foldlWithKey' - , foldrWithKey' - , keysSet - , mergeWithKey' - , delete - , deleteMin - , deleteMax - , deleteFindMax - , deleteFindMin - , difference - , elems - , intersection - , disjoint - , isProperSubmapOf - , isProperSubmapOfBy - , isSubmapOf - , isSubmapOfBy - , lookup - , lookupLE - , lookupGE - , lookupLT - , lookupGT - , lookupMin - , lookupMax - , minView - , maxView - , minViewWithKey - , maxViewWithKey - , keys - , mapKeys - , mapKeysMonotonic - , member - , notMember - , null - , partition - , partitionWithKey - , restrictKeys - , size - , split - , splitLookup - , splitRoot - , toAscList - , toDescList - , toList - , union - , unions - , withoutKeys - ) -#ifdef __GLASGOW_HASKELL__ -import Data.IntMap.Internal.DeprecatedDebug (showTree, showTreeWith) -#endif -import qualified Data.IntSet.Internal as IntSet -import Utils.Containers.Internal.BitUtil -import Utils.Containers.Internal.StrictPair -#if !MIN_VERSION_base(4,8,0) -import Data.Functor((<$>)) -#endif -import Control.Applicative (Applicative (..), liftA2) -import qualified Data.Foldable as Foldable -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable (Foldable()) -#endif - -{-------------------------------------------------------------------- - Query ---------------------------------------------------------------------} - --- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@ --- returns the value at key @k@ or returns @def@ when the key is not an --- element of the map. --- --- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' --- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' - --- See IntMap.Internal.Note: Local 'go' functions and capturing] -findWithDefault :: a -> Key -> IntMap a -> a -findWithDefault def !k = go - where - go (Bin p m l r) | nomatch k p m = def - | zero k m = go l - | otherwise = go r - go (Tip kx x) | k == kx = x - | otherwise = def - go Nil = def - -{-------------------------------------------------------------------- - Construction ---------------------------------------------------------------------} +import qualified Data.IntMap.Merge.Strict as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) + +import Control.Applicative (Applicative(..)) +import Data.Functor ((<$>)) + +import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) + +import qualified Data.List (foldl', map) +import qualified Data.IntSet (IntSet, toList) + +import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) + +(#!), (#) :: (a -> b) -> a -> b +(#!) = ($!) +(#) = ($) + -- | /O(1)/. A map of one element. -- -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 - singleton :: Key -> a -> IntMap a -singleton k !x - = Tip k x -{-# INLINE singleton #-} +singleton k v = v `seq` IntMap (NonEmpty k v Tip) -{-------------------------------------------------------------------- - Insert ---------------------------------------------------------------------} -- | /O(min(n,W))/. Insert a new key\/value pair in the map. -- If the key is already present in the map, the associated value is -- replaced with the supplied value, i.e. 'insert' is equivalent to --- @'insertWith' 'const'@. +-- @'insertWith' 'const'@ -- -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] -- > insert 5 'x' empty == singleton 5 'x' - insert :: Key -> a -> IntMap a -> IntMap a -insert !k !x t = - case t of - Bin p m l r - | nomatch k p m -> link k (Tip k x) p t - | zero k m -> Bin p m (insert k x l) r - | otherwise -> Bin p m l (insert k x r) - Tip ky _ - | k==ky -> Tip k x - | otherwise -> link k (Tip k x) ky t - Nil -> Tip k x - --- right-biased insertion, used by 'union' +insert = start + where + start !k !v (IntMap Empty) = IntMap (NonEmpty k v Tip) + start !k !v (IntMap (NonEmpty min minV root)) + | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) + | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) + | otherwise = IntMap (NonEmpty k v root) + + goL !k v !_ !_ Tip = Bin k v Tip Tip + goL !k v !xorCache !min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL k v xorCache min l) r + else Bin max maxV l (goR k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max v l r + where xorCacheMax = xor k max + + goR !k v !_ !_ Tip = Bin k v Tip Tip + goR !k v !xorCache !max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR k v xorCache max r) + else Bin min minV (goL k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min v l r + where xorCacheMin = xor min k + -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does @@ -420,10 +322,36 @@ insert !k !x t = -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" - insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith f k x t - = insertWithKey (\_ x' y' -> f x' y') k x t +insertWith combine = start + where + start !k v (IntMap Empty) = IntMap (NonEmpty k #! v # Tip) + start !k v (IntMap (NonEmpty min minV root)) + | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) + | k < min = IntMap (NonEmpty k #! v # insertMinL (xor min k) min minV root) + | otherwise = IntMap (NonEmpty k #! combine v minV # root) + + goL !k v !_ !_ Tip = Bin k #! v # Tip # Tip + goL !k v !xorCache !min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL k v xorCache min l) r + else Bin max maxV l (goR k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k #! v # Bin max maxV l r # Tip + else Bin k #! v # l # insertMaxR xorCacheMax max maxV r + | otherwise = Bin max #! combine v maxV # l # r + where xorCacheMax = xor k max + + goR !k v !_ !_ Tip = Bin k #! v # Tip # Tip + goR !k v !xorCache !max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR k v xorCache max r) + else Bin min minV (goL k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k #! v # Tip # Bin min minV l r + else Bin k #! v # insertMinL xorCacheMin min minV l # r + | otherwise = Bin min #! combine v minV # l # r + where xorCacheMin = xor min k -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWithKey' f key value mp@ @@ -435,21 +363,8 @@ insertWith f k x t -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" --- --- If the key exists in the map, this function is lazy in @value@ but strict --- in the result of @f@. - insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWithKey f !k x t = - case t of - Bin p m l r - | nomatch k p m -> link k (singleton k x) p t - | zero k m -> Bin p m (insertWithKey f k x l) r - | otherwise -> Bin p m l (insertWithKey f k x r) - Tip ky y - | k==ky -> Tip k $! f k x y - | otherwise -> link k (singleton k x) ky t - Nil -> singleton k x +insertWithKey f k = insertWith (f k) k -- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) -- is a pair where the first element is equal to (@'lookup' k map@) @@ -465,35 +380,74 @@ insertWithKey f !k x t = -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) - insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) -insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0 +insertLookupWithKey combine !k v = toPair . start where - go f k x t = - case t of - Bin p m l r - | nomatch k p m -> Nothing :*: link k (singleton k x) p t - | zero k m -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r) - | otherwise -> let (found :*: r') = go f k x r in (found :*: Bin p m l r') - Tip ky y - | k==ky -> (Just y :*: (Tip k $! f k x y)) - | otherwise -> (Nothing :*: link k (singleton k x) ky t) - Nil -> Nothing :*: (singleton k x) - - -{-------------------------------------------------------------------- - Deletion ---------------------------------------------------------------------} + start (IntMap Empty) = Nothing :*: IntMap (NonEmpty k #! v # Tip) + start (IntMap (NonEmpty min minV root)) + | k > min = let mv :*: root' = goL (xor min k) min root + in mv :*: IntMap (NonEmpty min minV root') + | k < min = Nothing :*: IntMap (NonEmpty k #! v # insertMinL (xor min k) min minV root) + | otherwise = Just minV :*: IntMap (NonEmpty k #! combine k v minV # root) + + goL !_ _ Tip = Nothing :*: (Bin k #! v # Tip # Tip) + goL !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then let mv :*: l' = goL xorCache min l + in mv :*: Bin max maxV l' r + else let mv :*: r' = goR xorCacheMax max r + in mv :*: Bin max maxV l r' + | k > max = if xor min max < xorCacheMax + then Nothing :*: (Bin k #! v # Bin max maxV l r # Tip) + else Nothing :*: (Bin k #! v # l # insertMaxR xorCacheMax max maxV r) + | otherwise = Just maxV :*: (Bin max #! combine k v maxV # l # r) + where xorCacheMax = xor k max + + goR !_ _ Tip = Nothing :*: (Bin k #! v # Tip # Tip) + goR !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then let mv :*: r' = goR xorCache max r + in mv :*: Bin min minV l r' + else let mv :*: l' = goL xorCacheMin min l + in mv :*: Bin min minV l' r + | k < min = if xor min max < xorCacheMin + then Nothing :*: (Bin k #! v # Tip # Bin min minV l r) + else Nothing :*: (Bin k #! v # insertMinL xorCacheMin min minV l # r) + | otherwise = Just minV :*: (Bin min #! combine k v minV # l # r) + where xorCacheMin = xor min k + -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > adjust ("new " ++) 7 empty == empty - -adjust :: (a -> a) -> Key -> IntMap a -> IntMap a -adjust f k m - = adjustWithKey (\_ x -> f x) k m +adjust :: (a -> a) -> Key -> IntMap a -> IntMap a +adjust f k = k `seq` start + where + start (IntMap Empty) = IntMap Empty + start m@(IntMap (NonEmpty min minV node)) + | k > min = IntMap (NonEmpty min minV (goL (xor min k) min node)) + | k < min = m + | otherwise = IntMap (NonEmpty min #! f minV # node) + + goL !_ _ Tip = Tip + goL !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL xorCache min l) r + else Bin max maxV l (goR xorCacheMax max r) + | k > max = n + | otherwise = Bin max #! f maxV # l # r + where xorCacheMax = xor k max + + goR !_ _ Tip = Tip + goR !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR xorCache max r) + else Bin min minV (goL xorCacheMin min l) r + | k < min = n + | otherwise = Bin min #! f minV # l # r + where xorCacheMin = xor min k -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. @@ -502,18 +456,8 @@ adjust f k m -- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] -- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > adjustWithKey f 7 empty == empty - -adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a -adjustWithKey f !k t = - case t of - Bin p m l r - | nomatch k p m -> t - | zero k m -> Bin p m (adjustWithKey f k l) r - | otherwise -> Bin p m l (adjustWithKey f k r) - Tip ky y - | k==ky -> Tip ky $! f k y - | otherwise -> t - Nil -> Nil +adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a +adjustWithKey f k = adjust (f k) k -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is @@ -523,12 +467,46 @@ adjustWithKey f !k t = -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a -update f - = updateWithKey (\_ x -> f x) - --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ +update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a +update f k = k `seq` start + where + start (IntMap Empty) = IntMap Empty + start m@(IntMap (NonEmpty min minV Tip)) + | k == min = case f minV of + Nothing -> IntMap Empty + Just !minV' -> IntMap (NonEmpty min minV' Tip) + | otherwise = m + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) + | k < min = m + | k == min = case f minV of + Nothing -> let DR min' minV' root' = deleteMinL max maxV l r + in IntMap (NonEmpty min' minV' root') + Just !minV' -> IntMap (NonEmpty min minV' root) + | otherwise = IntMap (NonEmpty min minV (goL (xor min k) min root)) + + goL !_ _ Tip = Tip + goL !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL xorCache min l) r + else Bin max maxV l (goR xorCacheMax max r) + | k > max = n + | otherwise = case f maxV of + Nothing -> extractBinL l r + Just !maxV' -> Bin max maxV' l r + where xorCacheMax = xor k max + + goR !_ _ Tip = Tip + goR !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR xorCache max r) + else Bin min minV (goL xorCacheMin min l) r + | k < min = n + | otherwise = case f minV of + Nothing -> extractBinR l r + Just !minV' -> Bin min minV' l r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. The expression (@'updateWithKey' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -- @@ -536,20 +514,8 @@ update f -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a -updateWithKey f !k t = - case t of - Bin p m l r - | nomatch k p m -> t - | zero k m -> binCheckLeft p m (updateWithKey f k l) r - | otherwise -> binCheckRight p m l (updateWithKey f k r) - Tip ky y - | k==ky -> case f k y of - Just !y' -> Tip ky y' - Nothing -> Nil - | otherwise -> t - Nil -> Nil +updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a +updateWithKey f k = update (f k) k -- | /O(min(n,W))/. Lookup and update. -- The function returns original value, if it is updated. @@ -560,47 +526,61 @@ updateWithKey f !k t = -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") - -updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a) -updateLookupWithKey f0 !k0 t0 = toPair $ go f0 k0 t0 +updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) +updateLookupWithKey f k = k `seq` start where - go f k t = - case t of - Bin p m l r - | nomatch k p m -> (Nothing :*: t) - | zero k m -> let (found :*: l') = go f k l in (found :*: binCheckLeft p m l' r) - | otherwise -> let (found :*: r') = go f k r in (found :*: binCheckRight p m l r') - Tip ky y - | k==ky -> case f k y of - Just !y' -> (Just y :*: Tip ky y') - Nothing -> (Just y :*: Nil) - | otherwise -> (Nothing :*: t) - Nil -> (Nothing :*: Nil) - - + start (IntMap Empty) = (Nothing, IntMap Empty) + start m@(IntMap (NonEmpty min minV Tip)) + | k == min = case f min minV of + Nothing -> (Just minV, IntMap Empty) + Just !minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) + | otherwise = (Nothing, m) + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) + | k < min = (Nothing, m) + | k == min = case f min minV of + Nothing -> let DR min' minV' root' = deleteMinL max maxV l r + in (Just minV, IntMap (NonEmpty min' minV' root')) + Just !minV' -> (Just minV, IntMap (NonEmpty min minV' root)) + | otherwise = let (mv, root') = goL (xor min k) min root + in (mv, IntMap (NonEmpty min minV root')) + + goL !_ _ Tip = (Nothing, Tip) + goL !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then let (mv, l') = goL xorCache min l + in (mv, Bin max maxV l' r) + else let (mv, r') = goR xorCacheMax max r + in (mv, Bin max maxV l r') + | k > max = (Nothing, n) + | otherwise = case f max maxV of + Nothing -> (Just maxV, extractBinL l r) + Just !maxV' -> (Just maxV, Bin max maxV' l r) + where xorCacheMax = xor k max + + goR !_ _ Tip = (Nothing, Tip) + goR !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then let (mv, r') = goR xorCache max r + in (mv, Bin min minV l r') + else let (mv, l') = goL xorCacheMin min l + in (mv, Bin min minV l' r) + | k < min = (Nothing, n) + | otherwise = case f min minV of + Nothing -> (Just minV, extractBinR l r) + Just !minV' -> (Just minV, Bin min minV' l r) + where xorCacheMin = xor min k -- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a -alter f !k t = - case t of - Bin p m l r - | nomatch k p m -> case f Nothing of - Nothing -> t - Just !x -> link k (Tip k x) p t - | zero k m -> binCheckLeft p m (alter f k l) r - | otherwise -> binCheckRight p m l (alter f k r) - Tip ky y - | k==ky -> case f (Just y) of - Just !x -> Tip ky x - Nothing -> Nil - | otherwise -> case f Nothing of - Just !x -> link k (Tip k x) ky t - Nothing -> t - Nil -> case f Nothing of - Just !x -> Tip k x - Nothing -> Nil +alter f k m = case lookup k m of + Nothing -> case f Nothing of + Nothing -> m + Just v -> insert k v m + Just v -> case f (Just v) of + Nothing -> delete k m + Just v' -> insert k v' m -- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, @@ -624,64 +604,204 @@ alter f !k t = -- -- 'alterF' is the most general operation for working with an individual -- key that may or may not be in a given map. - +-- -- Note: 'alterF' is a flipped version of the 'at' combinator from -- 'Control.Lens.At'. -- -- @since 0.5.8 - -alterF :: Functor f - => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a) --- This implementation was modified from 'Control.Lens.At'. -alterF f k m = (<$> f mv) $ \fres -> - case fres of - Nothing -> maybe m (const (delete k m)) mv - Just !v' -> insert k v' m - where mv = lookup k m - - -{-------------------------------------------------------------------- - Union ---------------------------------------------------------------------} --- | The union of a list of maps, with a combining operation. --- --- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] --- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] - -unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a -unionsWith f ts - = Foldable.foldl' (unionWith f) empty ts +alterF :: Functor f => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a) +alterF f k m = case lookup k m of + Nothing -> fmap (\ret -> case ret of + Nothing -> m + Just v -> insert k v m) (f Nothing) + Just v -> fmap (\ret -> case ret of + Nothing -> delete k m + Just v' -> insert k v' m) (f (Just v)) -- | /O(n+m)/. The union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] - unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWith f m1 m2 - = unionWithKey (\_ x y -> f x y) m1 m2 +unionWith f = unionWithKey (const f) -- | /O(n+m)/. The union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] - unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWithKey f m1 m2 - = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2 +unionWithKey combine = start + where + start (IntMap Empty) m2 = m2 + start m1 (IntMap Empty) = m1 + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 minV2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) + | otherwise = IntMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + + -- TODO: Should I bind 'minV1' in a closure? It never changes. + -- TODO: Should I cache @xor min1 min2@? + goL1 minV1 min1 Tip !_ Tip = Bin min1 minV1 Tip Tip + goL1 minV1 min1 Tip min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1 minV1 min1 n1 min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 + EQ | max2 < min1 -> disjoint + | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL1 minV1 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 + where + disjoint = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) + + -- TODO: Should I bind 'minV2' in a closure? It never changes. + -- TODO: Should I cache @xor min1 min2@? + goL2 minV2 !_ Tip min2 Tip = Bin min2 minV2 Tip Tip + goL2 minV2 min1 Tip min2 n2 = insertMinL (xor min1 min2) min2 minV2 n2 + goL2 minV2 min1 n1 min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 + EQ | max1 < min2 -> disjoint + | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL2 minV2 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l1 # goRFused max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 + where + disjoint = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) + + -- TODO: Should I bind 'min' in a closure? It never changes. + -- TODO: Should I use an xor cache here? + -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same + -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' + goLFused !_ Tip n2 = n2 + goLFused !_ n1 Tip = n1 + goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 + EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goLFused min l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 + + -- TODO: Should I bind 'maxV1' in a closure? It never changes. + -- TODO: Should I cache @xor max1 max2@? + goR1 maxV1 max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip + goR1 maxV1 max1 Tip max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 + goR1 maxV1 max1 n1 max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 + EQ | max1 < min2 -> disjoint + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR1 maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) + where + disjoint = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 + + -- TODO: Should I bind 'minV2' in a closure? It never changes. + -- TODO: Should I cache @xor min1 min2@? + goR2 maxV2 !_ Tip max2 Tip = Bin max2 maxV2 Tip Tip + goR2 maxV2 max1 Tip max2 n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 + goR2 maxV2 max1 n1 max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | otherwise -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) + EQ | max2 < min1 -> disjoint + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR2 maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 + | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 + where + disjoint = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 + + -- TODO: Should I bind 'max' in a closure? It never changes. + -- TODO: Should I use an xor cache here? + -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same + -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' + goRFused !_ Tip n2 = n2 + goRFused !_ n1 Tip = n1 + goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> Bin min2 minV2 l2 (goRFused max n1 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goRFused max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 + GT -> Bin min1 minV1 l1 (goRFused max r1 n2) + + goInsertL1 k v !_ _ Tip = Bin k #! v # Tip # Tip + goInsertL1 k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goInsertL1 k v xorCache min l) r + else Bin max maxV l (goInsertR1 k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max #! combine k v maxV # l # r + where xorCacheMax = xor k max + + goInsertR1 k v !_ _ Tip = Bin k v Tip Tip + goInsertR1 k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goInsertR1 k v xorCache max r) + else Bin min minV (goInsertL1 k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min #! combine k v minV # l # r + where xorCacheMin = xor min k + + goInsertL2 k v !_ _ Tip = Bin k v Tip Tip + goInsertL2 k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goInsertL2 k v xorCache min l) r + else Bin max maxV l (goInsertR2 k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max #! combine k maxV v # l # r + where xorCacheMax = xor k max + + goInsertR2 k v !_ _ Tip = Bin k v Tip Tip + goInsertR2 k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goInsertR2 k v xorCache max r) + else Bin min minV (goInsertL2 k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min #! combine k minV v # l # r + where xorCacheMin = xor min k -{-------------------------------------------------------------------- - Difference ---------------------------------------------------------------------} +-- | The union of a list of maps, with a combining operation. +-- +-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] +-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] +unionsWith :: (a -> a -> a) -> [IntMap a] -> IntMap a +unionsWith f = Data.List.foldl' (unionWith f) empty -- | /O(n+m)/. Difference with a combining function. -- -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) -- > == singleton 3 "b:B" - differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWith f m1 m2 - = differenceWithKey (\_ x y -> f x y) m1 m2 +differenceWith f = differenceWithKey (const f) -- | /O(n+m)/. Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. @@ -691,47 +811,345 @@ differenceWith f m1 m2 -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) -- > == singleton 3 "3:b|B" - differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWithKey f m1 m2 - = mergeWithKey f id (const Nil) m1 m2 - -{-------------------------------------------------------------------- - Intersection ---------------------------------------------------------------------} +differenceWithKey combine = start + where + start (IntMap Empty) !_ = IntMap Empty + start !m (IntMap Empty) = m + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + | otherwise = case combine min1 minV1 minV2 of + Nothing -> IntMap (goLFused min1 root1 root2) + Just !minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep min1 root1 root2)) + + goL1 minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 + Just !maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) + | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) + Just !maxV1' -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) + GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) + + goL2 !_ Tip !_ !_ = Tip + goL2 min1 n1 min2 Tip = deleteL min2 (xor min1 min2) n1 + goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = n1 + goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goL2 min1 n1 min2 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> goL2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> case goRFused max1 r1 r2 of + Empty -> goL2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + Just !maxV1' -> Bin max1 maxV1' (goL2 min1 l1 min2 l2) (goRFusedKeep max1 r1 r2) + GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of + Empty -> l1 + NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of + Empty -> l1 + NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' + Just !maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep max1 r1 (Bin min2 dummyV l2 r2)) + + goLFused min = loop + where + loop Tip !_ = Empty + loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of + DR min' minV' n' -> NonEmpty min' minV' n' + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) + | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + Just !maxV1' -> binL (loop l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) + GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) + + goLFusedKeep min = loop + where + loop n1 Tip = n1 + loop Tip !_ = Tip + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (loop l1 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> case goRFused max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + Just !maxV1' -> Bin max1 maxV1' (loop l1 l2) (goRFusedKeep max1 r1 r2) + GT -> Bin max1 maxV1 (loop l1 n2) r1 + + goR1 maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) + | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 + Just !minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) + Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (goR1 maxV1 max1 r1 max2 r2) + GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) + + goR2 !_ Tip !_ !_ = Tip + goR2 max1 n1 max2 Tip = deleteR max2 (xor max1 max2) n1 + goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = n1 + goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goR2 max1 n1 max2 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> goR2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> case goLFused min1 l1 l2 of + Empty -> goR2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (goR2 max1 r1 max2 r2) + GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 + | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of + Empty -> r1 + NonEmpty min' minV' l' -> Bin min' minV' l' r1 + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of + Empty -> r1 + NonEmpty min' minV' l' -> Bin min' minV' l' r1 + Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 (Bin max2 dummyV l2 r2)) r1 + + goRFused max = loop + where + loop Tip !_ = Empty + loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of + DR max' maxV' n' -> NonEmpty max' maxV' n' + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (loop r1 r2) + GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) + + goRFusedKeep max = loop + where + loop n1 Tip = n1 + loop Tip !_ = Tip + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (loop r1 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | otherwise -> case combine min1 minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + Nothing -> case goLFused min1 l1 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (loop r1 r2) + GT -> Bin min1 minV1 l1 (loop r1 n2) + + goLookupL k v !_ Tip = NonEmpty k v Tip + goLookupL k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL k v xorCache l + else goLookupR k v xorCacheMax r + | k > max = NonEmpty k v Tip + | otherwise = case combine k v maxV of + Nothing -> Empty + Just !v' -> NonEmpty k v' Tip + where xorCacheMax = xor k max + + goLookupR k v !_ Tip = NonEmpty k v Tip + goLookupR k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR k v xorCache r + else goLookupL k v xorCacheMin l + | k < min = NonEmpty k v Tip + | otherwise = case combine k v minV of + Nothing -> Empty + Just !v' -> NonEmpty k v' Tip + where xorCacheMin = xor min k + + dummyV = error "impossible" -- | /O(n+m)/. The intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" - intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWith f m1 m2 - = intersectionWithKey (\_ x y -> f x y) m1 m2 +intersectionWith f = intersectionWithKey (const f) -- | /O(n+m)/. The intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" - intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey f m1 m2 - = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2 - -{-------------------------------------------------------------------- - MergeWithKey ---------------------------------------------------------------------} - --- | /O(n+m)/. A high-performance universal combining function. Using --- 'mergeWithKey', all combining functions can be defined without any loss of --- efficiency (with exception of 'union', 'difference' and 'intersection', --- where sharing of some nodes is lost with 'mergeWithKey'). --- --- Please make sure you know what is going on when using 'mergeWithKey', --- otherwise you can be surprised by unexpected code growth or even --- corruption of the data structure. +intersectionWithKey combine = start + where + start (IntMap Empty) !_ = IntMap Empty + start !_ (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (goL2 minV2 min1 root1 min2 root2) + | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + | otherwise = IntMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + + -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. + + goL1 _ !_ !_ !_ Tip = Empty + goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 + goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> r2lMap $ NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 + EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine max1 maxV1 maxV2 # l' # goRFused max1 r1 r2) + GT -> goL1 minV1 min1 l1 min2 n2 + + goL2 _ !_ Tip !_ !_ = Empty + goL2 minV2 min1 n1 min2 Tip = goLookupL2 min2 minV2 (xor min1 min2) n1 + goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty + goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goL2 minV2 min1 n1 min2 l2 + EQ | max1 > max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL2 minV2 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine max1 maxV1 maxV2 # l' # goRFused max1 r1 r2) + GT | xor min1 min2 < xor min2 max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> r2lMap $ goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 (Bin min2 minV2 l2 r2) + + goLFused min = loop + where + loop Tip !_ = Tip + loop !_ Tip = Tip + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> case goR2 maxV2 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # loop l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> loop l1 n2 + + goR1 _ !_ !_ !_ Tip = Empty + goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 + goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> l2rMap $ NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 + EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # r') + GT -> goR1 maxV1 max1 r1 max2 n2 + + goR2 _ !_ Tip !_ !_ = Empty + goR2 maxV2 max1 n1 max2 Tip = goLookupR2 max2 maxV2 (xor max1 max2) n1 + goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty + goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goR2 maxV2 max1 n1 max2 r2 + EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> case goR2 maxV2 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # r') + GT | xor min1 max2 > xor max2 max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> l2rMap $ goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) + + goRFused max = loop + where + loop Tip !_ = Tip + loop !_ Tip = Tip + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> case goL2 minV2 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # loop r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> loop r1 n2 + + goLookupL1 !_ _ !_ Tip = Empty + goLookupL1 k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL1 k v xorCache l + else goLookupR1 k v xorCacheMax r + | k > max = Empty + | otherwise = NonEmpty k #! combine k v maxV # Tip + where xorCacheMax = xor k max + + goLookupR1 !_ _ !_ Tip = Empty + goLookupR1 k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR1 k v xorCache r + else goLookupL1 k v xorCacheMin l + | k < min = Empty + | otherwise = NonEmpty k #! combine k v minV # Tip + where xorCacheMin = xor min k + + goLookupL2 !_ _ !_ Tip = Empty + goLookupL2 k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL2 k v xorCache l + else goLookupR2 k v xorCacheMax r + | k > max = Empty + | otherwise = NonEmpty k #! combine k maxV v # Tip + where xorCacheMax = xor k max + + goLookupR2 !_ _ !_ Tip = Empty + goLookupR2 k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR2 k v xorCache r + else goLookupL2 k v xorCacheMin l + | k < min = Empty + | otherwise = NonEmpty k #! combine k minV v # Tip + where xorCacheMin = xor min k + +-- | /O(n+m)/. An unsafe general combining function. +-- +-- WARNING: This function can produce corrupt maps and its results +-- may depend on the internal structures of its inputs. Users should +-- prefer 'merge' or 'mergeA'. This function is also significantly slower +-- than 'merge'. -- -- When 'mergeWithKey' is given three arguments, it is inlined to the call --- site. You should therefore use 'mergeWithKey' only to define your custom +-- site. You should therefore use 'mergeWithKey' only to define custom -- combining functions. For example, you could define 'unionWithKey', -- 'differenceWithKey' and 'intersectionWithKey' as -- @@ -753,135 +1171,61 @@ intersectionWithKey f m1 m2 -- the output is added to the result. -- -- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. --- The values can be modified arbitrarily. Most common variants of @only1@ and --- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or --- @'filterWithKey' f@ could be used for any @f@. +-- The values can be modified arbitrarily. Most common variants of @only1@ and +-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@, +-- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@. +mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) -> IntMap a -> IntMap b -> IntMap c +mergeWithKey matched miss1 miss2 = Merge.merge (Merge.mapMaybeMissing (single miss1)) (Merge.mapMaybeMissing (single miss2)) (Merge.zipWithMaybeMatched matched) where + single miss k v = case miss (IntMap (NonEmpty k v Tip)) of + IntMap Empty -> Nothing + IntMap (NonEmpty _ v' _) -> Just v' -mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) - -> IntMap a -> IntMap b -> IntMap c -mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2 - where -- We use the lambda form to avoid non-exhaustive pattern matches warning. - combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil - Just !x -> Tip k1 x - {-# INLINE combine #-} -{-# INLINE mergeWithKey #-} - -{-------------------------------------------------------------------- - Min\/Max ---------------------------------------------------------------------} - --- | /O(log n)/. Update the value at the minimal key. --- --- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] --- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a -updateMinWithKey f t = - case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r) - _ -> go f t - where - go f' (Bin p m l r) = binCheckLeft p m (go f' l) r - go f' (Tip k y) = case f' k y of - Just !y' -> Tip k y' - Nothing -> Nil - go _ Nil = error "updateMinWithKey Nil" - --- | /O(log n)/. Update the value at the maximal key. --- --- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] --- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" - -updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a -updateMaxWithKey f t = - case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r - _ -> go f t - where - go f' (Bin p m l r) = binCheckRight p m l (go f' r) - go f' (Tip k y) = case f' k y of - Just !y' -> Tip k y' - Nothing -> Nil - go _ Nil = error "updateMaxWithKey Nil" - --- | /O(log n)/. Update the value at the maximal key. --- --- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] --- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" - -updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMax f = updateMaxWithKey (const f) - --- | /O(log n)/. Update the value at the minimal key. --- --- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] --- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" - -updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMin f = updateMinWithKey (const f) - - -{-------------------------------------------------------------------- - Mapping ---------------------------------------------------------------------} -- | /O(n)/. Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] - -map :: (a -> b) -> IntMap a -> IntMap b -map f = go +map :: forall a b. (a -> b) -> IntMap a -> IntMap b +map f = start where - go (Bin p m l r) = Bin p m (go l) (go r) - go (Tip k x) = Tip k $! f x - go Nil = Nil + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f minV # go root) -#ifdef __GLASGOW_HASKELL__ -{-# NOINLINE [1] map #-} -{-# RULES -"map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs -"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs - #-} -#endif + go :: Node t a -> Node t b + go Tip = Tip + go (Bin k v l r) = Bin k #! f v # go l # go r -- | /O(n)/. Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] +mapWithKey :: forall a b. (Key -> a -> b) -> IntMap a -> IntMap b +mapWithKey f = start + where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # go root) -mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b -mapWithKey f t - = case t of - Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r) - Tip k x -> Tip k $! f k x - Nil -> Nil + go :: Node t a -> Node t b + go Tip = Tip + go (Bin k v l r) = Bin k #! f k v # go l # go r -#ifdef __GLASGOW_HASKELL__ --- Pay close attention to strictness here. We need to force the --- intermediate result for map f . map g, and we need to refrain --- from forcing it for map f . L.map g, etc. --- --- TODO Consider moving map and mapWithKey to IntMap.Internal so we can write --- non-orphan RULES for things like L.map f (map g xs). We'd need a new function --- for this, and we'd have to pay attention to simplifier phases. Something like --- --- lsmap :: (b -> c) -> (a -> b) -> IntMap a -> IntMap c --- lsmap _ _ Nil = Nil --- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx) --- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r) -{-# NOINLINE [1] mapWithKey #-} -{-# RULES -"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) = - mapWithKey (\k a -> f k $! g k a) xs -"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) = - mapWithKey (\k a -> f k (g k a)) xs -"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) = - mapWithKey (\k a -> f k $! g a) xs -"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) = - mapWithKey (\k a -> f k (g a)) xs -"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) = - mapWithKey (\k a -> f $! g k a) xs -"map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) = - mapWithKey (\k a -> f (g k a)) xs - #-} -#endif + +-- | /O(n)/. +-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ +-- That is, behaves exactly like a regular 'traverse' except that the traversing +-- function also has access to the key associated with a value. +-- +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) +traverseWithKey f = start + where + start (IntMap Empty) = pure (IntMap Empty) + start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f min minV <*> goL root + + goL Tip = pure Tip + goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max #! maxV' # l' # r') <$> goL l <*> goR r <*> f max maxV + + goR Tip = pure Tip + goR (Bin min minV l r) = (\minV' l' r' -> Bin min #! minV' # l' # r') <$> f min minV <*> goL l <*> goR r -- | /O(n)/. -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ @@ -916,61 +1260,76 @@ traverseMaybeWithKey f = go -- -- > let f a b = (a ++ b, b ++ "X") -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) - -mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) -mapAccum f = mapAccumWithKey (\a' _ x -> f a' x) +mapAccum :: (a -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) +mapAccum f = mapAccumWithKey (\a _ x -> f a x) -- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") -- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) - -mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) -mapAccumWithKey f a t - = mapAccumL f a t - --- | /O(n)/. The function @'mapAccumL'@ threads an accumulating --- argument through the map in ascending order of keys. Strict in --- the accumulating argument and the both elements of the --- result of the function. -mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) -mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0 +mapAccumWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) +mapAccumWithKey f = start where - go f a t - = case t of - Bin p m l r - | m < 0 -> - let (a1 :*: r') = go f a r - (a2 :*: l') = go f a1 l - in (a2 :*: Bin p m l' r') - | otherwise -> - let (a1 :*: l') = go f a l - (a2 :*: r') = go f a1 r - in (a2 :*: Bin p m l' r') - Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') - Nil -> (a :*: Nil) + start a (IntMap Empty) = (a, IntMap Empty) + start a (IntMap (NonEmpty min minV root)) = + let (a', !minV') = f a min minV + (a'', root') = goL root a' + in (a'', IntMap (NonEmpty min minV' root')) + + goL Tip a = (a, Tip) + goL (Bin max maxV l r) a = + let (a', l') = goL l a + (a'', r') = goR r a' + (a''', !maxV') = f a'' max maxV + in (a''', Bin max maxV' l' r') + + goR Tip a = (a, Tip) + goR (Bin min minV l r) a = + let (a', !minV') = f a min minV + (a'', l') = goL l a' + (a''', r') = goR r a'' + in (a''', Bin min minV' l' r') -- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating -- argument through the map in descending order of keys. -mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) -mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0 +mapAccumRWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) +mapAccumRWithKey f = start where - go f a t - = case t of - Bin p m l r - | m < 0 -> - let (a1 :*: l') = go f a l - (a2 :*: r') = go f a1 r - in (a2 :*: Bin p m l' r') - | otherwise -> - let (a1 :*: r') = go f a r - (a2 :*: l') = go f a1 l - in (a2 :*: Bin p m l' r') - Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') - Nil -> (a :*: Nil) - --- | /O(n*log n)/. + start a (IntMap Empty) = (a, IntMap Empty) + start a (IntMap (NonEmpty min minV root)) = + let (a', root') = goL root a + (a'', !minV') = f a' min minV + in (a'', IntMap (NonEmpty min minV' root')) + + goL Tip a = (a, Tip) + goL (Bin max maxV l r) a = + let (a', !maxV') = f a max maxV + (a'', r') = goR r a' + (a''', l') = goL l a'' + in (a''', Bin max maxV' l' r') + + goR Tip a = (a, Tip) + goR (Bin min minV l r) a = + let (a', r') = goR r a + (a'', l') = goL l a' + (a''', !minV') = f a'' min minV + in (a''', Bin min minV' l' r') + +-- | /O(n*min(n,W))/. +-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the value at the greatest of the +-- original keys is retained. +-- +-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] +-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" +-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" +mapKeys :: (Key -> Key) -> IntMap a -> IntMap a +mapKeys f = foldlWithKey' (\m k a -> insert (f k) a m) empty + +-- | /O(n*min(n,W))/. -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct @@ -979,235 +1338,257 @@ mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0 -- -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" +mapKeysWith :: (a -> a -> a) -> (Key -> Key) -> IntMap a -> IntMap a +mapKeysWith combine f = foldlWithKey' (\m k a -> insertWith combine (f k) a m) empty -mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a -mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) [] - -{-------------------------------------------------------------------- - Filter ---------------------------------------------------------------------} --- | /O(n)/. Map values and collect the 'Just' results. +-- | /O(n*min(n,W))/. +-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ +-- is strictly monotonic. +-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. +-- /The precondition is not checked./ +-- Semi-formally, we have: -- --- > let f x = if x == "a" then Just "new a" else Nothing --- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" - -mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b -mapMaybe f = mapMaybeWithKey (\_ x -> f x) - --- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s +-- > where ls = keys s -- --- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing --- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" - -mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b -mapMaybeWithKey f (Bin p m l r) - = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r) -mapMaybeWithKey f (Tip k x) = case f k x of - Just !y -> Tip k y - Nothing -> Nil -mapMaybeWithKey _ Nil = Nil - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- This means that @f@ maps distinct original keys to distinct resulting keys. +-- This function has slightly better performance than 'mapKeys'. -- --- > let f a = if a < "c" then Left a else Right a --- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) --- > --- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) - -mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) -mapEither f m - = mapEitherWithKey (\_ x -> f x) m - --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. --- --- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) --- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) --- > --- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) - -mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) -mapEitherWithKey f0 t0 = toPair $ go f0 t0 - where - go f (Bin p m l r) - = bin p m l1 r1 :*: bin p m l2 r2 - where - (l1 :*: l2) = go f l - (r1 :*: r2) = go f r - go f (Tip k x) = case f k x of - Left !y -> (Tip k y :*: Nil) - Right !z -> (Nil :*: Tip k z) - go _ Nil = (Nil :*: Nil) - -{-------------------------------------------------------------------- - Conversions ---------------------------------------------------------------------} +-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] +mapKeysMonotonic :: (Key -> Key) -> IntMap a -> IntMap a +mapKeysMonotonic = mapKeys -- | /O(n)/. Build a map from a set of keys and a function which for each key -- computes its value. -- -- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] -- > fromSet undefined Data.IntSet.empty == empty +fromSet :: (Key -> a) -> Data.IntSet.IntSet -> IntMap a +fromSet f = fromDistinctAscList . Data.List.map (\k -> (k, f k)) . Data.IntSet.toList -fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a -fromSet _ IntSet.Nil = Nil -fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r) -fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) - where -- This is slightly complicated, as we to convert the dense - -- representation of IntSet into tree representation of IntMap. - -- - -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'. - -- We split bmask into halves corresponding to left and right subtree. - -- If they are both nonempty, we create a Bin node, otherwise exactly - -- one of them is nonempty and we construct the IntMap from that half. - buildTree g !prefix !bmask bits = case bits of - 0 -> Tip prefix $! g prefix - _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of - bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 -> - buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2 - | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 -> - buildTree g prefix bmask bits2 - | otherwise -> - Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) - -{-------------------------------------------------------------------- - Lists ---------------------------------------------------------------------} -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. --- --- > fromList [] == empty --- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] --- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] - -fromList :: [(Key,a)] -> IntMap a -fromList xs - = Foldable.foldl' ins empty xs - where - ins t (k,x) = insert k x t +fromList :: [(Key, a)] -> IntMap a +fromList = Data.List.foldl' (\t (k, a) -> insert k a t) empty -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] +-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] -- > fromListWith (++) [] == empty - -fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a -fromListWith f xs - = fromListWithKey (\_ x y -> f x y) xs +fromListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a +fromListWith f = Data.List.foldl' (\t (k, a) -> insertWith f k a t) empty -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. -- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")] --- > fromListWith (++) [] == empty +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] +-- > fromListWithKey f [] == empty +fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a +fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty -fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromListWithKey f xs - = Foldable.foldl' ins empty xs - where - ins t (k,x) = insertWithKey f k x t +-- TODO: Use the ordering -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order. -- -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] - -fromAscList :: [(Key,a)] -> IntMap a -fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) -{-# NOINLINE fromAscList #-} +fromAscList :: [(Key, a)] -> IntMap a +fromAscList = fromList -- | /O(n)/. Build a map from a list of key\/value pairs where --- the keys are in ascending order, with a combining function on equal keys. --- /The precondition (input list is ascending) is not checked./ +-- the keys are in ascending order. -- --- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] - -fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) -{-# NOINLINE fromAscListWith #-} +-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] +fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a +fromAscListWith = fromListWith -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. -- /The precondition (input list is ascending) is not checked./ -- --- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] - -fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWithKey f = fromMonoListWithKey Nondistinct f -{-# NOINLINE fromAscListWithKey #-} +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] +fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a +fromAscListWithKey = fromListWithKey -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. -- /The precondition (input list is strictly ascending) is not checked./ -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +fromDistinctAscList :: [(Key, a)] -> IntMap a +fromDistinctAscList = fromList -fromDistinctAscList :: [(Key,a)] -> IntMap a -fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) -{-# NOINLINE fromDistinctAscList #-} +-- | /O(n)/. Map values and collect the 'Just' results. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" +mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b +mapMaybe f = mapMaybeWithKey (const f) -data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada +-- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- +-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing +-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" +mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b +mapMaybeWithKey f = start + where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = case f min minV of + Just !minV' -> IntMap (NonEmpty min minV' (goL root)) + Nothing -> IntMap (goDeleteL root) + + goL Tip = Tip + goL (Bin max maxV l r) = case f max maxV of + Just !maxV' -> Bin max maxV' (goL l) (goR r) + Nothing -> case goDeleteR r of + Empty -> goL l + NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' + + goR Tip = Tip + goR (Bin min minV l r) = case f min minV of + Just !minV' -> Bin min minV' (goL l) (goR r) + Nothing -> case goDeleteL l of + Empty -> goR r + NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) + + goDeleteL Tip = Empty + goDeleteL (Bin max maxV l r) = case f max maxV of + Just !maxV' -> case goDeleteL l of + Empty -> case goR r of + Tip -> NonEmpty max maxV' Tip + Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) + NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR r)) + Nothing -> binL (goDeleteL l) (goDeleteR r) + + goDeleteR Tip = Empty + goDeleteR (Bin min minV l r) = case f min minV of + Just !minV' -> case goDeleteR r of + Empty -> case goL l of + Tip -> NonEmpty min minV' Tip + Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) + NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL l) r') + Nothing -> binR (goDeleteL l) (goDeleteR r) --- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys --- and a combining function. +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -- --- The precise conditions under which this function works are subtle: --- For any branch mask, keys with the same prefix w.r.t. the branch --- mask must occur consecutively in the list. +-- > let f a = if a < "c" then Left a else Right a +-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) +-- > +-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) +mapEither f = mapEitherWithKey (const f) -fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromMonoListWithKey distinct f = go +-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +-- +-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) +-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) +-- > +-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) +mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) +mapEitherWithKey func = start where - go [] = Nil - go ((kx,vx) : zs1) = addAll' kx vx zs1 - - -- `addAll'` collects all keys equal to `kx` into a single value, - -- and then proceeds with `addAll`. - addAll' !kx vx [] - = Tip kx $! vx - addAll' !kx vx ((ky,vy) : zs) - | Nondistinct <- distinct, kx == ky - = let !v = f kx vy vx in addAll' ky v zs - -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs) - | m <- branchMask kx ky - , Inserted ty zs' <- addMany' m ky vy zs - = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs' - - -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` - -- `addAll` consumes the rest of the list, adding to the tree `tx` - addAll !kx !tx [] - = tx - addAll !kx !tx ((ky,vy) : zs) - | m <- branchMask kx ky - , Inserted ty zs' <- addMany' m ky vy zs - = addAll kx (linkWithMask m ky ty {-kx-} tx) zs' - - -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. - addMany' !m !kx vx [] - = Inserted (Tip kx $! vx) [] - addMany' !m !kx vx zs0@((ky,vy) : zs) - | Nondistinct <- distinct, kx == ky - = let !v = f kx vy vx in addMany' m ky v zs - -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs) - | mask kx m /= mask ky m - = Inserted (Tip kx $! vx) zs0 - | mxy <- branchMask kx ky - , Inserted ty zs' <- addMany' mxy ky vy zs - = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs' - - -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. - addMany !m !kx tx [] - = Inserted tx [] - addMany !m !kx tx zs0@((ky,vy) : zs) - | mask kx m /= mask ky m - = Inserted tx zs0 - | mxy <- branchMask kx ky - , Inserted ty zs' <- addMany' mxy ky vy zs - = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs' -{-# INLINE fromMonoListWithKey #-} - -data Inserted a = Inserted !(IntMap a) ![(Key,a)] - -data Distinct = Distinct | Nondistinct + start (IntMap Empty) = (IntMap Empty, IntMap Empty) + start (IntMap (NonEmpty min minV root)) = case func min minV of + Left !v -> let SP t f = goTrueL root + in (IntMap (NonEmpty min v t), IntMap f) + Right !v -> let SP t f = goFalseL root + in (IntMap t, IntMap (NonEmpty min v f)) + + goTrueL Tip = SP Tip Empty + goTrueL (Bin max maxV l r) = case func max maxV of + Left !v -> let SP tl fl = goTrueL l + SP tr fr = goTrueR r + in SP (Bin max v tl tr) (binL fl fr) + Right !v -> let SP tl fl = goTrueL l + SP tr fr = goFalseR r + t = case tr of + Empty -> tl + NonEmpty max' maxV' r' -> Bin max' maxV' tl r' + f = case fl of + Empty -> r2lMap $ NonEmpty max v fr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' fr) + in SP t f + + goTrueR Tip = SP Tip Empty + goTrueR (Bin min minV l r) = case func min minV of + Left !v -> let SP tl fl = goTrueL l + SP tr fr = goTrueR r + in SP (Bin min v tl tr) (binR fl fr) + Right !v -> let SP tl fl = goFalseL l + SP tr fr = goTrueR r + t = case tl of + Empty -> tr + NonEmpty min' minV' l' -> Bin min' minV' l' tr + f = case fr of + Empty -> l2rMap $ NonEmpty min v fl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v fl r') + in SP t f + + goFalseL Tip = SP Empty Tip + goFalseL (Bin max maxV l r) = case func max maxV of + Left !v -> let SP tl fl = goFalseL l + SP tr fr = goTrueR r + t = case tl of + Empty -> r2lMap $ NonEmpty max v tr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' tr) + f = case fr of + Empty -> fl + NonEmpty max' maxV' r' -> Bin max' maxV' fl r' + in SP t f + Right !v -> let SP tl fl = goFalseL l + SP tr fr = goFalseR r + in SP (binL tl tr) (Bin max v fl fr) + + goFalseR Tip = SP Empty Tip + goFalseR (Bin min minV l r) = case func min minV of + Left !v -> let SP tl fl = goTrueL l + SP tr fr = goFalseR r + t = case tr of + Empty -> l2rMap $ NonEmpty min v tl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v tl r') + f = case fl of + Empty -> fr + NonEmpty min' minV' l' -> Bin min' minV' l' fr + in SP t f + Right !v -> let SP tl fl = goFalseL l + SP tr fr = goFalseR r + in SP (binR tl tr) (Bin min v fl fr) + +-- | /O(min(n,W))/. Update the value at the minimal key. +-- +-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] +-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a +updateMin _ (IntMap Empty) = IntMap Empty +updateMin f m = update f (fst (findMin m)) m + +-- | /O(min(n,W))/. Update the value at the maximal key. +-- +-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] +-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a +updateMax _ (IntMap Empty) = IntMap Empty +updateMax f m = update f (fst (findMax m)) m + +-- | /O(min(n,W))/. Update the value at the minimal key. +-- +-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] +-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a +updateMinWithKey _ (IntMap Empty) = IntMap Empty +updateMinWithKey f m = updateWithKey f (fst (findMin m)) m + +-- | /O(min(n,W))/. Update the value at the maximal key. +-- +-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] +-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a +updateMaxWithKey _ (IntMap Empty) = IntMap Empty +updateMaxWithKey f m = updateWithKey f (fst (findMax m)) m From ff87e0993747729d912f95d21d492fe581c645eb Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 10:18:11 -0500 Subject: [PATCH 003/147] Use a local version of Identity on old versions of base --- containers/src/Data/IntMap/Merge/Internal.hs | 35 ++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 30a1ab78c..58bf492e4 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns #-} + +#include "containers.h" ----------------------------------------------------------------------------- -- | @@ -30,10 +32,39 @@ module Data.IntMap.Merge.Internal where import Prelude hiding (min, max) -import Data.Functor.Identity (Identity, runIdentity) import Data.IntMap.Internal +#if MIN_VERSION_base (4,8,0) +import Data.Functor.Identity (Identity, runIdentity) +#else +import Control.Applicative (Applicative(..)) +#if __GLASGOW_HASKELL__ >= 708 +import Data.Coerce +#endif +#endif + + +#if !MIN_VERSION_base (4,8,0) +-- | The identity type. +newtype Identity a = Identity { runIdentity :: a } + +#if __GLASGOW_HASKELL__ >= 708 +instance Functor Identity where + fmap = coerce +instance Applicative Identity where + (<*>) = coerce + pure = Identity +#else +instance Functor Identity where + fmap f (Identity a) = Identity (f a) +instance Applicative Identity where + Identity f <*> Identity x = Identity (f x) + pure = Identity +#endif +#endif + + -- | A tactic for dealing with keys present in one map but not the other in -- 'merge' or 'mergeA'. -- From 218959be0c55c79bde614850c38daf46ee2380db Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 10:35:00 -0500 Subject: [PATCH 004/147] Stop requiring EmptyDataDecls --- containers/src/Data/IntMap/Internal.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 7a409e6ed..79d79060e 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, EmptyDataDecls #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -65,8 +65,8 @@ i2w = fromIntegral xor :: Key -> Key -> Word xor a b = Data.Bits.xor (i2w a) (i2w b) -data L -data R +newtype L = L L +newtype R = R R newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) data IntMap_ t a = NonEmpty {-# UNPACK #-} !Key a !(Node t a) | Empty deriving (Eq) From 5c01e564839d275e34eef8878062ca5dbf9b4b8c Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 10:53:58 -0500 Subject: [PATCH 005/147] Stop requiring ScopedTypeVariables --- containers/src/Data/IntMap/Lazy.hs | 14 +++++----- containers/src/Data/IntMap/Merge/Lazy.hs | 16 +++++++----- containers/src/Data/IntMap/Merge/Strict.hs | 16 +++++++----- containers/src/Data/IntMap/Strict/Internal.hs | 26 +++++++++++-------- 4 files changed, 41 insertions(+), 31 deletions(-) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 51e2b768e..83e5f843d 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -1165,15 +1165,17 @@ map = fmap -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] -mapWithKey :: forall a b. (Key -> a -> b) -> IntMap a -> IntMap b +mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b mapWithKey f = start where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f min minV) (go root)) + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f min minV) (goL root)) - go :: Node t a -> Node t b - go Tip = Tip - go (Bin k v l r) = Bin k (f k v) (go l) (go r) + goL Tip = Tip + goL (Bin k v l r) = Bin k (f k v) (goL l) (goR r) + + goR Tip = Tip + goR (Bin k v l r) = Bin k (f k v) (goL l) (goR r) -- | /O(n)/. diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 8e5a1408b..93b25bb9f 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -61,14 +61,16 @@ import Data.IntMap.Merge.Internal -- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) -- -- but @mapMissing@ is somewhat faster. -mapMissing :: forall f a b. Applicative f => (Key -> a -> b) -> WhenMissing f a b -mapMissing f = WhenMissing (\k v -> Just (f k v)) go go (pure . start) where +mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b +mapMissing f = WhenMissing (\k v -> Just (f k v)) goL goR (pure . start) where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f min minV) (go root)) + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f min minV) (goL root)) - go :: Node t a -> Node t b - go Tip = Tip - go (Bin k v l r) = Bin k (f k v) (go l) (go r) + goL Tip = Tip + goL (Bin k v l r) = Bin k (f k v) (goL l) (goR r) + + goR Tip = Tip + goR (Bin k v l r) = Bin k (f k v) (goL l) (goR r) -- | Map over the entries whose keys are missing from the other map, -- optionally removing some. This is the most powerful 'SimpleWhenMissing' diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 8ad467896..3f6ef5eee 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -65,14 +65,16 @@ import Data.IntMap.Merge.Internal -- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) -- -- but @mapMissing@ is somewhat faster. -mapMissing :: forall f a b. Applicative f => (Key -> a -> b) -> WhenMissing f a b -mapMissing f = WhenMissing (\k v -> Just $! f k v) go go (pure . start) where +mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b +mapMissing f = WhenMissing (\k v -> Just $! f k v) goL goR (pure . start) where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # go root) + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # goL root) - go :: Node t a -> Node t b - go Tip = Tip - go (Bin k v l r) = Bin k #! f k v # go l # go r + goL Tip = Tip + goL (Bin k v l r) = Bin k #! f k v # goL l # goR r + + goR Tip = Tip + goR (Bin k v l r) = Bin k #! f k v # goL l # goR r -- | Map over the entries whose keys are missing from the other map, -- optionally removing some. This is the most powerful 'SimpleWhenMissing' diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 0547bbceb..4cf4fcdc6 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -1183,29 +1183,33 @@ mergeWithKey matched miss1 miss2 = Merge.merge (Merge.mapMaybeMissing (single mi -- | /O(n)/. Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] -map :: forall a b. (a -> b) -> IntMap a -> IntMap b +map :: (a -> b) -> IntMap a -> IntMap b map f = start where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f minV # go root) + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f minV # goL root) - go :: Node t a -> Node t b - go Tip = Tip - go (Bin k v l r) = Bin k #! f v # go l # go r + goL Tip = Tip + goL (Bin k v l r) = Bin k #! f v # goL l # goR r + + goR Tip = Tip + goR (Bin k v l r) = Bin k #! f v # goL l # goR r -- | /O(n)/. Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] -mapWithKey :: forall a b. (Key -> a -> b) -> IntMap a -> IntMap b +mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b mapWithKey f = start where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # go root) + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # goL root) - go :: Node t a -> Node t b - go Tip = Tip - go (Bin k v l r) = Bin k #! f k v # go l # go r + goL Tip = Tip + goL (Bin k v l r) = Bin k #! f k v # goL l # goR r + + goR Tip = Tip + goR (Bin k v l r) = Bin k #! f k v # goL l # goR r -- | /O(n)/. From c90c027b421fb024de20c723cd5f297ce74f61c4 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 10:57:30 -0500 Subject: [PATCH 006/147] Only implement foldr' and foldl' in Foldable for later bases --- containers/src/Data/IntMap/Internal.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 79d79060e..4b32aaa07 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns #-} + +#include "containers.h" ----------------------------------------------------------------------------- -- | @@ -99,9 +101,11 @@ instance Data.Foldable.Foldable IntMap where goR (Bin _ minV l r) = f minV `mappend` goL l `mappend` goR r foldr = foldr - foldr' = foldr' foldl = foldl +#if MIN_VERSION_base(4,6,0) + foldr' = foldr' foldl' = foldl' +#endif instance Traversable IntMap where traverse f = start From 11e2cc0ad110b52fdf5e9aa51ddb87df18cd4d82 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 11:01:05 -0500 Subject: [PATCH 007/147] Properly import Applicative for when it isn't in the Prelude --- containers/src/Data/IntMap/Merge/Internal.hs | 2 +- containers/src/Data/IntMap/Merge/Lazy.hs | 1 + containers/src/Data/IntMap/Merge/Strict.hs | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 58bf492e4..1d40b92a3 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -31,6 +31,7 @@ module Data.IntMap.Merge.Internal where +import Control.Applicative (Applicative(..)) import Prelude hiding (min, max) import Data.IntMap.Internal @@ -38,7 +39,6 @@ import Data.IntMap.Internal #if MIN_VERSION_base (4,8,0) import Data.Functor.Identity (Identity, runIdentity) #else -import Control.Applicative (Applicative(..)) #if __GLASGOW_HASKELL__ >= 708 import Data.Coerce #endif diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 93b25bb9f..6273c4217 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -47,6 +47,7 @@ module Data.IntMap.Merge.Lazy ( , filterMissing ) where +import Control.Applicative (Applicative(..)) import Prelude hiding (min, max) import Data.IntMap.Internal diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 3f6ef5eee..fe62d5de4 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -47,6 +47,7 @@ module Data.IntMap.Merge.Strict ( , filterMissing ) where +import Control.Applicative (Applicative(..)) import Prelude hiding (min, max) import Data.IntMap.Internal From 231db1ade68a8c9ea88b4364862069b663a430df Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 11:10:10 -0500 Subject: [PATCH 008/147] Use foldl' from Data.List instead of from Data.Foldable --- containers/src/Data/IntMap/Internal.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 4b32aaa07..6fc7cebb0 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -46,6 +46,7 @@ import Control.DeepSeq (NFData(..)) import Control.Applicative (Applicative(..)) import Data.Monoid (Monoid(..)) +import qualified Data.List (foldl') import qualified Data.Foldable (Foldable(..)) import Data.Traversable (Traversable(..)) @@ -622,7 +623,7 @@ union = start -- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] -- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] unions :: [IntMap a] -> IntMap a -unions = Data.Foldable.foldl' union empty +unions = Data.List.foldl' union empty -- | /O(n+m)/. Difference between two maps (based on keys). -- From e0f7a37f06d96528c9b0252fabd0d0609fa2ffb3 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 14:24:27 -0500 Subject: [PATCH 009/147] Add a bunch of safety annotations to the new IntMap code --- containers/src/Data/IntMap/Internal.hs | 3 +++ containers/src/Data/IntMap/Lazy.hs | 5 ++++- containers/src/Data/IntMap/Merge/Internal.hs | 3 +++ containers/src/Data/IntMap/Merge/Lazy.hs | 5 ++++- containers/src/Data/IntMap/Merge/Strict.hs | 5 ++++- containers/src/Data/IntMap/Strict/Internal.hs | 5 ++++- 6 files changed, 22 insertions(+), 4 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 6fc7cebb0..9ddc8ed50 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP, BangPatterns #-} +#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Safe #-} +#endif #include "containers.h" diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 83e5f843d..f3a95c4a8 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns #-} +#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Safe #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 1d40b92a3..71394e0ea 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP, BangPatterns #-} +#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Safe #-} +#endif #include "containers.h" diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 6273c4217..0e6aa747b 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns #-} +#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Safe #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index fe62d5de4..7a5554260 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns #-} +#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Safe #-} +#endif ----------------------------------------------------------------------------- -- | diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 4cf4fcdc6..f7f0cddf3 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns #-} +#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Safe #-} +#endif ----------------------------------------------------------------------------- -- | From 24d7d2c3426391f60aaff6c72ca8d5a85c44b50d Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 14:55:42 -0500 Subject: [PATCH 010/147] Mark Data.IntMap.Merge.Internal as Trustworth when Data.Coerce is used --- containers/src/Data/IntMap/Merge/Internal.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 71394e0ea..f4956866a 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -1,9 +1,14 @@ {-# LANGUAGE CPP, BangPatterns #-} + +#include "containers.h" + #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if MIN_VERSION_base(4,8,0) || __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Safe #-} +#else +{-# LANGUAGE Trustworthy #-} +#endif #endif - -#include "containers.h" ----------------------------------------------------------------------------- -- | @@ -41,11 +46,9 @@ import Data.IntMap.Internal #if MIN_VERSION_base (4,8,0) import Data.Functor.Identity (Identity, runIdentity) -#else -#if __GLASGOW_HASKELL__ >= 708 +#elif __GLASGOW_HASKELL__ >= 708 import Data.Coerce #endif -#endif #if !MIN_VERSION_base (4,8,0) From 0453b32ad1e5d8b1b3f25dd84565775dfae2f88c Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 16:43:55 -0500 Subject: [PATCH 011/147] Undo a misguided constant argument capture in intersection --- containers/src/Data/IntMap/Internal.hs | 48 +++++++++++++------------- 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 9ddc8ed50..5a79097c1 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -798,20 +798,20 @@ intersection = start | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 r1 (Bin min2 dummyV l2 r2)) - goLFused min = loop - where - loop Tip !_ = Tip - loop !_ Tip = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of - LT -> loop n1 l2 + goLFused !_ Tip !_ = Tip + goLFused !_ !_ Tip = Tip + goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> goLFused min n1 l2 EQ | max1 > max2 -> case goR2 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> Bin max1 maxV1 (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT -> loop l1 n2 + Empty -> l' + NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + | otherwise -> Bin max1 maxV1 l' (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + where + l' = goLFused min l1 l2 + GT -> goLFused min l1 n2 goR1 _ !_ !_ !_ Tip = Empty goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 @@ -843,20 +843,20 @@ intersection = start | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 l1 (Bin max2 dummyV l2 r2)) - goRFused max = loop - where - loop Tip !_ = Tip - loop !_ Tip = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of - LT -> loop n1 r2 + goRFused !_ Tip !_ = Tip + goRFused !_ !_ Tip = Tip + goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> goRFused max n1 r2 EQ | min1 < min2 -> case goL2 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (loop r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT -> loop r1 n2 + Empty -> r' + NonEmpty min' minV' l' -> Bin min' minV' l' r' + | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) r' -- we choose max1 arbitrarily, as max1 == max2 + where + r' = goRFused max r1 r2 + GT -> goRFused max r1 n2 goLookupL1 !_ _ !_ Tip = Empty goLookupL1 k v !xorCache (Bin max _ l r) From 6f91acff48e738eb45ed854649c9f122062da69b Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 13 Sep 2016 19:16:35 -0500 Subject: [PATCH 012/147] Add an incredibly hacky way to improve the worst-case performance of intersection Relative to stock Data.IntMap: ``` Benchmark Runtime change Original runtime intersection-disj_nn -71.86% 1.24e-07 intersection-disj_nn -71.81% 1.24e-07 intersection-disj_ns -68.89% 1.12e-07 intersection-disj_ns -68.78% 1.12e-07 intersection-disj_sn -67.40% 1.12e-07 intersection-disj_sn -67.28% 1.12e-07 intersection-disj_nt -62.80% 9.38e-08 intersection-disj_nt -62.78% 9.38e-08 intersection-disj_tn -59.92% 9.28e-08 intersection-disj_tn -60.66% 9.27e-08 intersection-common_nn +7.99% 7.08e-03 intersection-common_nn +7.01% 7.07e-03 intersection-common_ns -26.13% 1.04e-03 intersection-common_ns -26.95% 1.05e-03 intersection-common_sn -16.47% 1.07e-03 intersection-common_sn -22.00% 1.05e-03 intersection-common_nt -35.18% 5.48e-05 intersection-common_nt -34.25% 5.45e-05 intersection-common_tn -30.00% 5.97e-05 intersection-common_tn -32.24% 5.98e-05 intersection-mix_nn -0.21% 3.01e-03 intersection-mix_nn -6.72% 3.14e-03 intersection-mix_ns -32.58% 6.40e-04 intersection-mix_ns -32.51% 6.39e-04 intersection-mix_sn -24.22% 6.64e-04 intersection-mix_sn -24.55% 6.58e-04 intersection-mix_nt -26.15% 3.90e-05 intersection-mix_nt -25.79% 3.91e-05 intersection-mix_tn -30.97% 4.63e-05 intersection-mix_tn -31.45% 4.59e-05 intersection-block_nn -63.35% 4.88e-05 intersection-block_nn -63.47% 4.88e-05 intersection-block_ns -44.32% 3.52e-06 intersection-block_ns -44.75% 3.54e-06 intersection-block_sn -29.14% 3.43e-06 intersection-block_sn -28.87% 3.43e-06 ``` Relative to the code before this commit: ``` Benchmark Runtime change Original runtime intersection-disj_nn +12.32% 3.11e-08 intersection-disj_nn +12.11% 3.12e-08 intersection-disj_ns +12.22% 3.11e-08 intersection-disj_ns +12.12% 3.12e-08 intersection-disj_sn +8.91% 3.35e-08 intersection-disj_sn +9.08% 3.35e-08 intersection-disj_nt +12.27% 3.11e-08 intersection-disj_nt +12.13% 3.11e-08 intersection-disj_tn +11.10% 3.35e-08 intersection-disj_tn +8.97% 3.35e-08 intersection-common_nn -2.11% 7.81e-03 intersection-common_nn -2.17% 7.74e-03 intersection-common_ns -48.10% 1.48e-03 intersection-common_ns -48.18% 1.48e-03 intersection-common_sn -41.53% 1.53e-03 intersection-common_sn -46.44% 1.53e-03 intersection-common_nt -18.63% 4.36e-05 intersection-common_nt -17.45% 4.34e-05 intersection-common_tn -2.54% 4.29e-05 intersection-common_tn -4.53% 4.25e-05 intersection-mix_nn +19.16% 2.52e-03 intersection-mix_nn +16.65% 2.51e-03 intersection-mix_ns +13.31% 3.81e-04 intersection-mix_ns +11.09% 3.88e-04 intersection-mix_sn +14.91% 4.38e-04 intersection-mix_sn +10.95% 4.47e-04 intersection-mix_nt -11.50% 3.26e-05 intersection-mix_nt -10.80% 3.25e-05 intersection-mix_tn -2.21% 3.27e-05 intersection-mix_tn -3.26% 3.26e-05 intersection-block_nn +19.33% 1.50e-05 intersection-block_nn +18.70% 1.50e-05 intersection-block_ns +14.94% 1.70e-06 intersection-block_ns +14.82% 1.70e-06 intersection-block_sn +17.61% 2.07e-06 intersection-block_sn +18.07% 2.07e-06 ``` --- containers/src/Data/IntMap/Internal.hs | 144 +++++++++++++++---------- 1 file changed, 86 insertions(+), 58 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 5a79097c1..8bf00102c 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -762,50 +762,50 @@ intersection = start start (IntMap Empty) !_ = IntMap Empty start !_ (IntMap Empty) = IntMap Empty start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 _ root2)) - | min1 < min2 = IntMap (goL2 min1 root1 min2 root2) - | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + | min1 < min2 = IntMap (fromSketchy (goL2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (fromSketchy (goL1 minV1 min1 root1 min2 root2)) | otherwise = IntMap (NonEmpty min1 minV1 (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. - goL1 _ !_ !_ !_ Tip = Empty + goL1 _ !_ !_ !_ Tip = toSketchy Empty goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 - goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty + goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = toSketchy Empty goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lMap $ goR2 max1 (Bin min1 minV1 l1 r1) max2 r2 - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2)) + | max1 > max2 -> r2lSketchyMap $ goR2 max1 (Bin min1 minV1 l1 r1) max2 r2 + | max1 < max2 -> r2lSketchyMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> toSketchy $ r2lMap $ NonEmpty max1 maxV1 (goRFused max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> sketchyBinL (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> sketchyBinL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case fromSketchy (goL1 minV1 min1 l1 min2 l2) of + Empty -> toSketchy $ r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) + NonEmpty min' minV' l' -> toSketchy (NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2))) GT -> goL1 minV1 min1 l1 min2 n2 - goL2 !_ Tip !_ !_ = Empty + goL2 !_ Tip !_ !_ = toSketchy Empty goL2 min1 n1 min2 Tip = goLookupL2 min2 (xor min1 min2) n1 - goL2 _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty + goL2 _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = toSketchy Empty goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT -> goL2 min1 n1 min2 l2 - EQ | max1 > max2 -> binL (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> binL (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2)) + EQ | max1 > max2 -> sketchyBinL (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> sketchyBinL (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case fromSketchy (goL2 min1 l1 min2 l2) of + Empty -> toSketchy (r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2))) + NonEmpty min' minV' l' -> toSketchy (NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2))) GT | xor min1 min2 < xor min2 max1 -> goL2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> r2lMap $ goR2 max1 r1 max2 (Bin min2 dummyV l2 r2) - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 r1 (Bin min2 dummyV l2 r2)) + | max1 > max2 -> r2lSketchyMap $ goR2 max1 r1 max2 (Bin min2 dummyV l2 r2) + | max1 < max2 -> r2lSketchyMap $ goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) + | otherwise -> toSketchy $ r2lMap $ NonEmpty max1 maxV1 (goRFused max1 r1 (Bin min2 dummyV l2 r2)) goLFused !_ Tip !_ = Tip goLFused !_ !_ Tip = Tip goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of LT -> goLFused min n1 l2 - EQ | max1 > max2 -> case goR2 max1 r1 max2 r2 of + EQ | max1 > max2 -> case fromSketchy (goR2 max1 r1 max2 r2) of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + | max1 < max2 -> case fromSketchy (goR1 maxV1 max1 r1 max2 r2) of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' | otherwise -> Bin max1 maxV1 l' (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 @@ -813,44 +813,44 @@ intersection = start l' = goLFused min l1 l2 GT -> goLFused min l1 n2 - goR1 _ !_ !_ !_ Tip = Empty + goR1 _ !_ !_ !_ Tip = toSketchy Empty goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 - goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty + goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = toSketchy Empty goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rMap $ goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) - EQ | min1 < min2 -> binR (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') + | min1 < min2 -> l2rSketchyMap $ goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | min1 > min2 -> l2rSketchyMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> toSketchy $ l2rMap $ NonEmpty min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> sketchyBinR (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> sketchyBinR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case fromSketchy (goR1 maxV1 max1 r1 max2 r2) of + Empty -> toSketchy $ l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> toSketchy $ NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') GT -> goR1 maxV1 max1 r1 max2 n2 - goR2 !_ Tip !_ !_ = Empty + goR2 !_ Tip !_ !_ = toSketchy Empty goR2 max1 n1 max2 Tip = goLookupR2 max2 (xor max1 max2) n1 - goR2 _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty + goR2 _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = toSketchy Empty goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT -> goR2 max1 n1 max2 r2 - EQ | min1 < min2 -> binR (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | otherwise -> case goR2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') + EQ | min1 < min2 -> sketchyBinR (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | min1 > min2 -> sketchyBinR (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | otherwise -> case fromSketchy (goR2 max1 r1 max2 r2) of + Empty -> toSketchy $ l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> toSketchy $ NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') GT | xor min1 max2 > xor max2 max1 -> goR2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> l2rMap $ goL2 min1 l1 min2 (Bin max2 dummyV l2 r2) - | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 l1 (Bin max2 dummyV l2 r2)) + | min1 < min2 -> l2rSketchyMap $ goL2 min1 l1 min2 (Bin max2 dummyV l2 r2) + | min1 > min2 -> l2rSketchyMap $ goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) + | otherwise -> toSketchy $ l2rMap $ NonEmpty min1 minV1 (goLFused min1 l1 (Bin max2 dummyV l2 r2)) goRFused !_ Tip !_ = Tip goRFused !_ !_ Tip = Tip goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of LT -> goRFused max n1 r2 - EQ | min1 < min2 -> case goL2 min1 l1 min2 l2 of + EQ | min1 < min2 -> case fromSketchy (goL2 min1 l1 min2 l2) of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + | min1 > min2 -> case fromSketchy (goL1 minV1 min1 l1 min2 l2) of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) r' -- we choose max1 arbitrarily, as max1 == max2 @@ -858,40 +858,40 @@ intersection = start r' = goRFused max r1 r2 GT -> goRFused max r1 n2 - goLookupL1 !_ _ !_ Tip = Empty + goLookupL1 !_ _ !_ Tip = toSketchy Empty goLookupL1 k v !xorCache (Bin max _ l r) | k < max = if xorCache < xorCacheMax then goLookupL1 k v xorCache l else goLookupR1 k v xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k v Tip + | k > max = toSketchy Empty + | otherwise = toSketchy $ NonEmpty k v Tip where xorCacheMax = xor k max - goLookupR1 !_ _ !_ Tip = Empty + goLookupR1 !_ _ !_ Tip = toSketchy Empty goLookupR1 k v !xorCache (Bin min _ l r) | k > min = if xorCache < xorCacheMin then goLookupR1 k v xorCache r else goLookupL1 k v xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k v Tip + | k < min = toSketchy Empty + | otherwise = toSketchy $ NonEmpty k v Tip where xorCacheMin = xor min k - goLookupL2 !_ !_ Tip = Empty + goLookupL2 !_ !_ Tip = toSketchy Empty goLookupL2 k !xorCache (Bin max maxV l r) | k < max = if xorCache < xorCacheMax then goLookupL2 k xorCache l else goLookupR2 k xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k maxV Tip + | k > max = toSketchy Empty + | otherwise = toSketchy (NonEmpty k maxV Tip) where xorCacheMax = xor k max - goLookupR2 !_ !_ Tip = Empty + goLookupR2 !_ !_ Tip = toSketchy Empty goLookupR2 k !xorCache (Bin min minV l r) | k > min = if xorCache < xorCacheMin then goLookupR2 k xorCache r else goLookupL2 k xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k minV Tip + | k < min = toSketchy Empty + | otherwise = toSketchy (NonEmpty k minV Tip) where xorCacheMin = xor min k dummyV = error "impossible" @@ -1833,3 +1833,31 @@ deleteR !k !xorCache n@(Bin min minV l r) | k < min = n | otherwise = extractBinR l r where xorCacheMin = xor min k + +data SketchyIntMap_ t a = SIM !Bool {-# UNPACK #-} !Key a !(Node t a) + +{-# INLINE fromSketchy #-} +fromSketchy :: SketchyIntMap_ t a -> IntMap_ t a +fromSketchy (SIM False _ _ _) = Empty +fromSketchy (SIM True k v root) = NonEmpty k v root + +{-# INLINE toSketchy #-} +toSketchy :: IntMap_ t a -> SketchyIntMap_ t a +toSketchy Empty = SIM False 0 (error "sketchyEmpty") Tip +toSketchy (NonEmpty k v root) = SIM True k v root + +{-# INLINE sketchyBinL #-} +sketchyBinL :: SketchyIntMap_ L a -> SketchyIntMap_ R a -> SketchyIntMap_ L a +sketchyBinL l r = toSketchy (binL (fromSketchy l) (fromSketchy r)) + +{-# INLINE sketchyBinR #-} +sketchyBinR :: SketchyIntMap_ L a -> SketchyIntMap_ R a -> SketchyIntMap_ R a +sketchyBinR l r = toSketchy (binR (fromSketchy l) (fromSketchy r)) + +{-# INLINE l2rSketchyMap #-} +l2rSketchyMap :: SketchyIntMap_ L a -> SketchyIntMap_ R a +l2rSketchyMap = toSketchy . l2rMap . fromSketchy + +{-# INLINE r2lSketchyMap #-} +r2lSketchyMap :: SketchyIntMap_ R a -> SketchyIntMap_ L a +r2lSketchyMap = toSketchy . r2lMap . fromSketchy From 97e05bab43a9aac0be6eb447a0c6bfafdb79cb33 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 14 Sep 2016 10:32:51 -0500 Subject: [PATCH 013/147] Reorganize union to separately handle disjoint and non-disjoint maps Relative to the original Data.IntMap: ``` Benchmark Runtime change Original runtime union-disj_nn +16.41% 2.08e-07 union-disj_nn +15.60% 2.09e-07 union-disj_ns +13.90% 1.85e-07 union-disj_ns +17.19% 1.85e-07 union-disj_sn +10.35% 1.94e-07 union-disj_sn +10.59% 1.94e-07 union-disj_nt +10.43% 1.55e-07 union-disj_nt +10.20% 1.55e-07 union-disj_tn +10.41% 1.61e-07 union-disj_tn +10.15% 1.61e-07 union-common_nn -15.09% 1.12e-02 union-common_nn -14.84% 1.10e-02 union-common_ns -11.72% 4.69e-03 union-common_ns -11.40% 4.67e-03 union-common_sn -11.01% 4.67e-03 union-common_sn -11.03% 4.67e-03 union-common_nt -24.59% 9.11e-05 union-common_nt -27.28% 9.43e-05 union-common_tn -21.94% 8.89e-05 union-common_tn -20.53% 8.80e-05 union-mix_nn +12.55% 2.06e-02 union-mix_nn +12.53% 2.06e-02 union-mix_ns +5.96% 5.10e-03 union-mix_ns +5.87% 5.10e-03 union-mix_sn +5.96% 5.11e-03 union-mix_sn +6.63% 5.08e-03 union-mix_nt -3.65% 8.05e-05 union-mix_nt -2.77% 8.03e-05 union-mix_tn -9.27% 8.58e-05 union-mix_tn -9.39% 8.61e-05 union-block_nn +40.41% 1.03e-04 union-block_nn +40.85% 1.03e-04 union-block_ns +34.73% 6.79e-06 union-block_ns +35.32% 6.78e-06 union-block_sn +31.34% 6.92e-06 union-block_sn +31.53% 6.88e-06 ``` Relative to the code before this commit: ``` Benchmark Runtime change Original runtime union-disj_nn -3.11% 2.50e-07 union-disj_nn -3.92% 2.51e-07 union-disj_ns -4.89% 2.21e-07 union-disj_ns -1.98% 2.21e-07 union-disj_sn -2.77% 2.20e-07 union-disj_sn -2.69% 2.21e-07 union-disj_nt -5.08% 1.80e-07 union-disj_nt -5.19% 1.80e-07 union-disj_tn -0.00% 1.78e-07 union-disj_tn -0.09% 1.78e-07 union-common_nn -1.46% 9.64e-03 union-common_nn -1.86% 9.57e-03 union-common_ns -1.62% 4.21e-03 union-common_ns -1.48% 4.20e-03 union-common_sn +0.14% 4.15e-03 union-common_sn +0.21% 4.14e-03 union-common_nt -3.74% 7.14e-05 union-common_nt -3.88% 7.13e-05 union-common_tn +1.27% 6.85e-05 union-common_tn +2.40% 6.83e-05 union-mix_nn -0.70% 2.34e-02 union-mix_nn -0.85% 2.34e-02 union-mix_ns -0.78% 5.45e-03 union-mix_ns -0.87% 5.45e-03 union-mix_sn +0.39% 5.40e-03 union-mix_sn +0.24% 5.40e-03 union-mix_nt -4.99% 8.17e-05 union-mix_nt -4.44% 8.17e-05 union-mix_tn -1.80% 7.93e-05 union-mix_tn -1.26% 7.90e-05 union-block_nn -2.76% 1.49e-04 union-block_nn -2.26% 1.49e-04 union-block_ns -3.94% 9.53e-06 union-block_ns -3.93% 9.55e-06 union-block_sn -0.97% 9.18e-06 union-block_sn -1.11% 9.15e-06 ``` --- containers/src/Data/IntMap/Internal.hs | 136 +++++++++++++++---------- 1 file changed, 80 insertions(+), 56 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 8bf00102c..eb012e525 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -471,51 +471,63 @@ union = start -- TODO: Should I bind 'minV1' in a closure? It never changes. -- TODO: Should I cache @xor min1 min2@? - goL1 minV1 min1 Tip !_ Tip = Bin min1 minV1 Tip Tip - goL1 minV1 min1 Tip min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 - goL1 minV1 min1 n1 min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min1 min2 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip + goL1 minV1 !min1 Tip !min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = goL1Disjoint minV1 min1 n1 min2 n2 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min1 min2 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) | otherwise -> Bin max1 maxV1 l2 (goRFused max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 - EQ | max2 < min1 -> disjoint - | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + EQ | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - where - disjoint = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) + GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 + + goL1Disjoint minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip + goL1Disjoint minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 + goL1Disjoint minV1 !min1 Tip !min2 n2@(Bin max2 maxV2 l2 r2) + | xor min2 max2 < xor min1 max2 = Bin min1 minV1 n2 Tip + | otherwise = Bin min1 minV1 l2 (insertMaxR (xor min1 max2) max2 maxV2 r2) + goL1Disjoint minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) + | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin max1 maxV1 l2 (goR2Disjoint maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin max1 maxV1 (goL1Disjoint minV1 min1 l1 min2 n2) r1 + | otherwise = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) -- TODO: Should I bind 'minV2' in a closure? It never changes. -- TODO: Should I cache @xor min1 min2@? - goL2 minV2 !_ Tip min2 Tip = Bin min2 minV2 Tip Tip - goL2 minV2 min1 Tip min2 n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 min1 n1 min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 - goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 - EQ | max1 < min2 -> disjoint - | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip + goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = goL2Disjoint minV2 min1 n1 min2 n2 + goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) | otherwise -> Bin max1 maxV1 l1 (goRFused max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 - where - disjoint = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 + + goL2Disjoint minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip + goL2Disjoint minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 + goL2Disjoint minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 Tip + | xor min1 max1 < xor min2 max1 = Bin min2 minV2 n1 Tip + | otherwise = Bin min2 minV2 l1 (insertMaxR (xor min2 max1) max1 maxV1 r1) + goL2Disjoint minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) + | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin max2 maxV2 l1 (goR1Disjoint maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin max2 maxV2 (goL2Disjoint minV2 min1 n1 min2 l2) r2 + | otherwise = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) -- TODO: Should I bind 'min' in a closure? It never changes. -- TODO: Should I use an xor cache here? -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' - goLFused !_ Tip n2 = n2 - goLFused !_ n1 Tip = n1 - goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + goLFused !_ Tip !n2 = n2 + goLFused !_ !n1 Tip = n1 + goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) @@ -524,43 +536,55 @@ union = start -- TODO: Should I bind 'maxV1' in a closure? It never changes. -- TODO: Should I cache @xor max1 max2@? - goR1 maxV1 max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip - goR1 maxV1 max1 Tip max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1 maxV1 max1 n1 max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 + goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = goR1Disjoint maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | otherwise -> Bin min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 - EQ | max1 < min2 -> disjoint - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 - GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - where - disjoint = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 + GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) + + goR1Disjoint maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip + goR1Disjoint maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 + goR1Disjoint maxV1 !max1 Tip !max2 n2@(Bin min2 minV2 l2 r2) + | xor min2 max2 < xor min2 max1 = Bin max1 maxV1 Tip n2 + | otherwise = Bin max1 maxV1 (insertMinL (xor min2 max1) min2 minV2 l2) r2 + goR1Disjoint maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) + | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin min1 minV1 (goL2Disjoint minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin min1 minV1 l1 (goR1Disjoint maxV1 max1 r1 max2 n2) + | otherwise = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 -- TODO: Should I bind 'minV2' in a closure? It never changes. -- TODO: Should I cache @xor min1 min2@? - goR2 maxV2 !_ Tip max2 Tip = Bin max2 maxV2 Tip Tip - goR2 maxV2 max1 Tip max2 n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 max1 n1 max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 - goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) - EQ | max2 < min1 -> disjoint - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 - GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip + goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = goR2Disjoint maxV2 max1 n1 max2 n2 + goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | otherwise -> Bin min1 minV1 (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 - where - disjoint = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) + + goR2Disjoint maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip + goR2Disjoint maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 + goR2Disjoint maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 Tip + | xor min1 max1 < xor min1 max2 = Bin max2 maxV2 Tip n1 + | otherwise = Bin max2 maxV2 (insertMinL (xor min1 max2) min1 minV1 l1) r1 + goR2Disjoint maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) + | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin min2 minV2 (goL1Disjoint minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin min2 minV2 l2 (goR2Disjoint maxV2 max1 n1 max2 r2) + | otherwise = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 -- TODO: Should I bind 'max' in a closure? It never changes. -- TODO: Should I use an xor cache here? @@ -568,7 +592,7 @@ union = start -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' goRFused !_ Tip n2 = n2 goRFused !_ n1 Tip = n1 - goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of LT -> Bin min2 minV2 l2 (goRFused max n1 r2) EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) From a2fb9d06c983a06a52593c570b4492cb514e4a8f Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 14 Sep 2016 14:29:38 -0500 Subject: [PATCH 014/147] Minor cleanup for union Relative to original Data.IntMap: ``` Benchmark Runtime change Original runtime union-disj_nn +11.64% 2.08e-07 union-disj_nn +11.98% 2.09e-07 union-disj_ns +11.20% 1.85e-07 union-disj_ns +12.42% 1.85e-07 union-disj_sn +7.87% 1.94e-07 union-disj_sn +7.66% 1.94e-07 union-disj_nt +8.44% 1.55e-07 union-disj_nt +8.03% 1.55e-07 union-disj_tn +5.08% 1.61e-07 union-disj_tn +5.35% 1.61e-07 union-common_nn -16.32% 1.12e-02 union-common_nn -15.21% 1.10e-02 union-common_ns -12.33% 4.69e-03 union-common_ns -10.50% 4.67e-03 union-common_sn -11.36% 4.67e-03 union-common_sn -11.32% 4.67e-03 union-common_nt -23.86% 9.11e-05 union-common_nt -27.90% 9.43e-05 union-common_tn -19.68% 8.89e-05 union-common_tn -19.35% 8.80e-05 union-mix_nn +11.03% 2.06e-02 union-mix_nn +11.02% 2.06e-02 union-mix_ns +4.49% 5.10e-03 union-mix_ns +4.59% 5.10e-03 union-mix_sn +5.58% 5.11e-03 union-mix_sn +6.26% 5.08e-03 union-mix_nt -4.59% 8.05e-05 union-mix_nt -3.59% 8.03e-05 union-mix_tn -6.20% 8.58e-05 union-mix_tn -6.55% 8.61e-05 union-block_nn +38.52% 1.03e-04 union-block_nn +38.82% 1.03e-04 union-block_ns +34.45% 6.79e-06 union-block_ns +33.66% 6.78e-06 union-block_sn +31.59% 6.92e-06 union-block_sn +32.49% 6.88e-06 ``` Relative to before this commit: ``` Benchmark Runtime change Original runtime union-disj_nn -4.09% 2.42e-07 union-disj_nn -3.14% 2.41e-07 union-disj_ns -2.37% 2.10e-07 union-disj_ns -4.07% 2.16e-07 union-disj_sn -2.25% 2.14e-07 union-disj_sn -2.66% 2.15e-07 union-disj_nt -1.80% 1.71e-07 union-disj_nt -1.97% 1.71e-07 union-disj_tn -4.82% 1.78e-07 union-disj_tn -4.36% 1.78e-07 union-common_nn -1.45% 9.50e-03 union-common_nn -0.44% 9.39e-03 union-common_ns -0.70% 4.14e-03 union-common_ns +1.02% 4.14e-03 union-common_sn -0.40% 4.15e-03 union-common_sn -0.33% 4.15e-03 union-common_nt +0.96% 6.87e-05 union-common_nt -0.86% 6.85e-05 union-common_tn +2.89% 6.94e-05 union-common_tn +1.49% 6.99e-05 union-mix_nn -1.35% 2.32e-02 union-mix_nn -1.34% 2.32e-02 union-mix_ns -1.39% 5.41e-03 union-mix_ns -1.21% 5.40e-03 union-mix_sn -0.36% 5.42e-03 union-mix_sn -0.35% 5.41e-03 union-mix_nt -0.97% 7.76e-05 union-mix_nt -0.85% 7.81e-05 union-mix_tn +3.39% 7.79e-05 union-mix_tn +3.14% 7.80e-05 union-block_nn -1.35% 1.45e-04 union-block_nn -1.44% 1.45e-04 union-block_ns -0.21% 9.15e-06 union-block_ns -1.23% 9.17e-06 union-block_sn +0.19% 9.09e-06 union-block_sn +0.73% 9.04e-06 ``` --- containers/src/Data/IntMap/Internal.hs | 34 ++++++++++---------------- 1 file changed, 13 insertions(+), 21 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index eb012e525..4aa9cbdc1 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -469,12 +469,10 @@ union = start | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) | otherwise = IntMap (NonEmpty min1 minV1 (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 - -- TODO: Should I bind 'minV1' in a closure? It never changes. - -- TODO: Should I cache @xor min1 min2@? - goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip - goL1 minV1 !min1 Tip !min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = goL1Disjoint minV1 min1 n1 min2 n2 + goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min1 min2 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) @@ -485,22 +483,19 @@ union = start | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - goL1Disjoint minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip - goL1Disjoint minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 + goL1Disjoint _ !_ !_ !_ Tip = error "Data.IntMap.union: impossible" goL1Disjoint minV1 !min1 Tip !min2 n2@(Bin max2 maxV2 l2 r2) | xor min2 max2 < xor min1 max2 = Bin min1 minV1 n2 Tip | otherwise = Bin min1 minV1 l2 (insertMaxR (xor min1 max2) max2 maxV2 r2) - goL1Disjoint minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) + goL1Disjoint minV1 !min1 (Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin max1 maxV1 l2 (goR2Disjoint maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin max1 maxV1 (goL1Disjoint minV1 min1 l1 min2 n2) r1 | otherwise = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) - -- TODO: Should I bind 'minV2' in a closure? It never changes. - -- TODO: Should I cache @xor min1 min2@? goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = goL2Disjoint minV2 min1 n1 min2 n2 + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) @@ -511,12 +506,11 @@ union = start | otherwise -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 - goL2Disjoint minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip - goL2Disjoint minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 + goL2Disjoint _ !_ Tip !_ !_ = error "Data.IntMap.union: impossible" goL2Disjoint minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 Tip | xor min1 max1 < xor min2 max1 = Bin min2 minV2 n1 Tip | otherwise = Bin min2 minV2 l1 (insertMaxR (xor min2 max1) max1 maxV1 r1) - goL2Disjoint minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) + goL2Disjoint minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 (Bin max2 maxV2 l2 r2) | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin max2 maxV2 l1 (goR1Disjoint maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin max2 maxV2 (goL2Disjoint minV2 min1 n1 min2 l2) r2 | otherwise = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) @@ -537,9 +531,9 @@ union = start -- TODO: Should I bind 'maxV1' in a closure? It never changes. -- TODO: Should I cache @xor max1 max2@? goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip - goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = goR1Disjoint maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 @@ -550,12 +544,11 @@ union = start | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - goR1Disjoint maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip - goR1Disjoint maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 + goR1Disjoint _ !_ !_ !_ Tip = error "Data.IntMap.union: impossible" goR1Disjoint maxV1 !max1 Tip !max2 n2@(Bin min2 minV2 l2 r2) | xor min2 max2 < xor min2 max1 = Bin max1 maxV1 Tip n2 | otherwise = Bin max1 maxV1 (insertMinL (xor min2 max1) min2 minV2 l2) r2 - goR1Disjoint maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) + goR1Disjoint maxV1 !max1 (Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin min1 minV1 (goL2Disjoint minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin min1 minV1 l1 (goR1Disjoint maxV1 max1 r1 max2 n2) | otherwise = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 @@ -564,8 +557,8 @@ union = start -- TODO: Should I cache @xor min1 min2@? goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = goR2Disjoint maxV2 max1 n1 max2 n2 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 @@ -576,12 +569,11 @@ union = start | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) - goR2Disjoint maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip - goR2Disjoint maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 + goR2Disjoint _ !_ Tip !_ !_ = error "Data.IntMap.union: impossible" goR2Disjoint maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 Tip | xor min1 max1 < xor min1 max2 = Bin max2 maxV2 Tip n1 | otherwise = Bin max2 maxV2 (insertMinL (xor min1 max2) min1 minV1 l1) r1 - goR2Disjoint maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) + goR2Disjoint maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 (Bin min2 minV2 l2 r2) | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin min2 minV2 (goL1Disjoint minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin min2 minV2 l2 (goR2Disjoint maxV2 max1 n1 max2 r2) | otherwise = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 From 8a98e3e0dddfa5d073a668f7607bd8bc1ef03b82 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 14 Sep 2016 15:04:00 -0500 Subject: [PATCH 015/147] Update unionWithKey to match recent changes to union --- containers/src/Data/IntMap/Internal.hs | 88 +++++++-------- containers/src/Data/IntMap/Lazy.hs | 104 +++++++----------- containers/src/Data/IntMap/Strict/Internal.hs | 104 +++++++----------- 3 files changed, 116 insertions(+), 180 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 4aa9cbdc1..d77825e99 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -471,7 +471,7 @@ union = start goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = goL1Disjoint minV1 min1 n1 min2 n2 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL1 minV1 min1 n1 min2 n2 goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min1 min2 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 @@ -483,18 +483,9 @@ union = start | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - goL1Disjoint _ !_ !_ !_ Tip = error "Data.IntMap.union: impossible" - goL1Disjoint minV1 !min1 Tip !min2 n2@(Bin max2 maxV2 l2 r2) - | xor min2 max2 < xor min1 max2 = Bin min1 minV1 n2 Tip - | otherwise = Bin min1 minV1 l2 (insertMaxR (xor min1 max2) max2 maxV2 r2) - goL1Disjoint minV1 !min1 (Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) - | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin max1 maxV1 l2 (goR2Disjoint maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin max1 maxV1 (goL1Disjoint minV1 min1 l1 min2 n2) r1 - | otherwise = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) - goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = goL2Disjoint minV2 min1 n1 min2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL2 minV2 min1 n1 min2 n2 goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 @@ -506,17 +497,6 @@ union = start | otherwise -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 - goL2Disjoint _ !_ Tip !_ !_ = error "Data.IntMap.union: impossible" - goL2Disjoint minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 Tip - | xor min1 max1 < xor min2 max1 = Bin min2 minV2 n1 Tip - | otherwise = Bin min2 minV2 l1 (insertMaxR (xor min2 max1) max1 maxV1 r1) - goL2Disjoint minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 (Bin max2 maxV2 l2 r2) - | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin max2 maxV2 l1 (goR1Disjoint maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin max2 maxV2 (goL2Disjoint minV2 min1 n1 min2 l2) r2 - | otherwise = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) - - -- TODO: Should I bind 'min' in a closure? It never changes. - -- TODO: Should I use an xor cache here? -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' goLFused !_ Tip !n2 = n2 @@ -528,11 +508,9 @@ union = start | otherwise -> Bin max1 maxV1 (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - -- TODO: Should I bind 'maxV1' in a closure? It never changes. - -- TODO: Should I cache @xor max1 max2@? goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = goR1Disjoint maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR1 maxV1 max1 n1 max2 n2 goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 @@ -544,20 +522,9 @@ union = start | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - goR1Disjoint _ !_ !_ !_ Tip = error "Data.IntMap.union: impossible" - goR1Disjoint maxV1 !max1 Tip !max2 n2@(Bin min2 minV2 l2 r2) - | xor min2 max2 < xor min2 max1 = Bin max1 maxV1 Tip n2 - | otherwise = Bin max1 maxV1 (insertMinL (xor min2 max1) min2 minV2 l2) r2 - goR1Disjoint maxV1 !max1 (Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) - | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin min1 minV1 (goL2Disjoint minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin min1 minV1 l1 (goR1Disjoint maxV1 max1 r1 max2 n2) - | otherwise = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 - - -- TODO: Should I bind 'minV2' in a closure? It never changes. - -- TODO: Should I cache @xor min1 min2@? goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = goR2Disjoint maxV2 max1 n1 max2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR2 maxV2 max1 n1 max2 n2 goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 @@ -569,17 +536,6 @@ union = start | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) - goR2Disjoint _ !_ Tip !_ !_ = error "Data.IntMap.union: impossible" - goR2Disjoint maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 Tip - | xor min1 max1 < xor min1 max2 = Bin max2 maxV2 Tip n1 - | otherwise = Bin max2 maxV2 (insertMinL (xor min1 max2) min1 minV1 l1) r1 - goR2Disjoint maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 (Bin min2 minV2 l2 r2) - | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin min2 minV2 (goL1Disjoint minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin min2 minV2 l2 (goR2Disjoint maxV2 max1 n1 max2 r2) - | otherwise = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 - - -- TODO: Should I bind 'max' in a closure? It never changes. - -- TODO: Should I use an xor cache here? -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' goRFused !_ Tip n2 = n2 @@ -635,6 +591,42 @@ union = start | otherwise = Bin min minV l r where xorCacheMin = xor min k +unionDisjointL1 _ !_ !_ !_ Tip = error "Data.IntMap.unionDisjoint: impossible" +unionDisjointL1 minV1 !min1 Tip !min2 n2@(Bin max2 maxV2 l2 r2) + | xor min2 max2 < xor min1 max2 = Bin min1 minV1 n2 Tip + | otherwise = Bin min1 minV1 l2 (insertMaxR (xor min1 max2) max2 maxV2 r2) +unionDisjointL1 minV1 !min1 (Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) + | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin max1 maxV1 l2 (unionDisjointR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin max1 maxV1 (unionDisjointL1 minV1 min1 l1 min2 n2) r1 + | otherwise = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) + +unionDisjointL2 _ !_ Tip !_ !_ = error "Data.IntMap.unionDisjoint: impossible" +unionDisjointL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 Tip + | xor min1 max1 < xor min2 max1 = Bin min2 minV2 n1 Tip + | otherwise = Bin min2 minV2 l1 (insertMaxR (xor min2 max1) max1 maxV1 r1) +unionDisjointL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 (Bin max2 maxV2 l2 r2) + | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin max2 maxV2 l1 (unionDisjointR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin max2 maxV2 (unionDisjointL2 minV2 min1 n1 min2 l2) r2 + | otherwise = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) + +unionDisjointR1 _ !_ !_ !_ Tip = error "Data.IntMap.unionDisjoint: impossible" +unionDisjointR1 maxV1 !max1 Tip !max2 n2@(Bin min2 minV2 l2 r2) + | xor min2 max2 < xor min2 max1 = Bin max1 maxV1 Tip n2 + | otherwise = Bin max1 maxV1 (insertMinL (xor min2 max1) min2 minV2 l2) r2 +unionDisjointR1 maxV1 !max1 (Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) + | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin min1 minV1 (unionDisjointL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin min1 minV1 l1 (unionDisjointR1 maxV1 max1 r1 max2 n2) + | otherwise = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 + +unionDisjointR2 _ !_ Tip !_ !_ = error "Data.IntMap.unionDisjoint: impossible" +unionDisjointR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 Tip + | xor min1 max1 < xor min1 max2 = Bin max2 maxV2 Tip n1 + | otherwise = Bin max2 maxV2 (insertMinL (xor min1 max2) min1 minV1 l1) r1 +unionDisjointR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 (Bin min2 minV2 l2 r2) + | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin min2 minV2 (unionDisjointL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin min2 minV2 l2 (unionDisjointR2 maxV2 max1 n1 max2 r2) + | otherwise = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 + -- | The union of a list of maps. -- -- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index f3a95c4a8..9408fb2de 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -616,48 +616,34 @@ unionWithKey combine = start | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) | otherwise = IntMap (NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 - -- TODO: Should I bind 'minV1' in a closure? It never changes. - -- TODO: Should I cache @xor min1 min2@? - goL1 minV1 min1 Tip !_ Tip = Bin min1 minV1 Tip Tip - goL1 minV1 min1 Tip min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 - goL1 minV1 min1 n1 min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip + goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL1 minV1 min1 n1 min2 n2 + goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) | otherwise -> Bin max1 (combine max1 maxV1 maxV2) l2 (goRFused max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 - EQ | max2 < min1 -> disjoint - | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + EQ | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - where - disjoint = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) - - -- TODO: Should I bind 'minV2' in a closure? It never changes. - -- TODO: Should I cache @xor min1 min2@? - goL2 minV2 !_ Tip min2 Tip = Bin min2 minV2 Tip Tip - goL2 minV2 min1 Tip min2 n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 min1 n1 min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 - goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 - EQ | max1 < min2 -> disjoint - | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 + + goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip + goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL2 minV2 min1 n1 min2 n2 + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) | otherwise -> Bin max1 (combine max1 maxV1 maxV2) l1 (goRFused max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 - where - disjoint = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 - -- TODO: Should I bind 'min' in a closure? It never changes. - -- TODO: Should I use an xor cache here? -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' goLFused !_ Tip n2 = n2 @@ -669,48 +655,34 @@ unionWithKey combine = start | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - -- TODO: Should I bind 'maxV1' in a closure? It never changes. - -- TODO: Should I cache @xor max1 max2@? - goR1 maxV1 max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip - goR1 maxV1 max1 Tip max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1 maxV1 max1 n1 max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip + goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR1 maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 - EQ | max1 < min2 -> disjoint - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 - GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - where - disjoint = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 - - -- TODO: Should I bind 'minV2' in a closure? It never changes. - -- TODO: Should I cache @xor min1 min2@? - goR2 maxV2 !_ Tip max2 Tip = Bin max2 maxV2 Tip Tip - goR2 maxV2 max1 Tip max2 n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 max1 n1 max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 - goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) - EQ | max2 < min1 -> disjoint - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 - GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) + + goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip + goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR2 maxV2 max1 n1 max2 n2 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 - where - disjoint = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) - -- TODO: Should I bind 'max' in a closure? It never changes. - -- TODO: Should I use an xor cache here? -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' goRFused !_ Tip n2 = n2 diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index f7f0cddf3..6568b1ef7 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -641,48 +641,34 @@ unionWithKey combine = start | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) | otherwise = IntMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 - -- TODO: Should I bind 'minV1' in a closure? It never changes. - -- TODO: Should I cache @xor min1 min2@? - goL1 minV1 min1 Tip !_ Tip = Bin min1 minV1 Tip Tip - goL1 minV1 min1 Tip min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 - goL1 minV1 min1 n1 min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip + goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL1 minV1 min1 n1 min2 n2 + goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 - EQ | max2 < min1 -> disjoint - | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + EQ | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL1 minV1 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - where - disjoint = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) - - -- TODO: Should I bind 'minV2' in a closure? It never changes. - -- TODO: Should I cache @xor min1 min2@? - goL2 minV2 !_ Tip min2 Tip = Bin min2 minV2 Tip Tip - goL2 minV2 min1 Tip min2 n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 min1 n1 min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 - goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 - EQ | max1 < min2 -> disjoint - | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL2 minV2 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint -- we choose min1 and min2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 + + goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip + goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL2 minV2 min1 n1 min2 n2 + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l1 # goRFused max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 - where - disjoint = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL2 minV2 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 - -- TODO: Should I bind 'min' in a closure? It never changes. - -- TODO: Should I use an xor cache here? -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' goLFused !_ Tip n2 = n2 @@ -694,48 +680,34 @@ unionWithKey combine = start | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goLFused min l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - -- TODO: Should I bind 'maxV1' in a closure? It never changes. - -- TODO: Should I cache @xor max1 max2@? - goR1 maxV1 max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip - goR1 maxV1 max1 Tip max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1 maxV1 max1 n1 max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip + goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR1 maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 - EQ | max1 < min2 -> disjoint - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR1 maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 - GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - where - disjoint = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 - - -- TODO: Should I bind 'minV2' in a closure? It never changes. - -- TODO: Should I cache @xor min1 min2@? - goR2 maxV2 !_ Tip max2 Tip = Bin max2 maxV2 Tip Tip - goR2 maxV2 max1 Tip max2 n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 max1 n1 max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 - goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | otherwise -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) - EQ | max2 < min1 -> disjoint - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR2 maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 - GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint -- we choose max1 and max2 arbitrarily - we just need something from tree 1 and something from tree 2 - | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) + + goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip + goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR2 maxV2 max1 n1 max2 n2 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 - where - disjoint = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR2 maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) - -- TODO: Should I bind 'max' in a closure? It never changes. - -- TODO: Should I use an xor cache here? -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' goRFused !_ Tip n2 = n2 From b81e3d0f253d4b38396fc4a706f698ba544a5279 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 14 Sep 2016 16:54:05 -0500 Subject: [PATCH 016/147] Remove a misguided constant argument capture in difference Relative to original Data.IntMap: ``` Benchmark Runtime change Original runtime difference-disj_nn -79.35% 1.72e-07 difference-disj_nn -79.26% 1.72e-07 difference-disj_ns -77.59% 1.60e-07 difference-disj_ns -77.66% 1.60e-07 difference-disj_sn -80.81% 1.91e-07 difference-disj_sn -81.84% 1.91e-07 difference-disj_nt -74.41% 1.40e-07 difference-disj_nt -74.47% 1.40e-07 difference-disj_tn -76.19% 1.47e-07 difference-disj_tn -76.24% 1.47e-07 difference-common_nn +4.65% 7.50e-03 difference-common_nn +2.73% 7.50e-03 difference-common_ns -2.21% 4.27e-03 difference-common_ns -2.98% 4.28e-03 difference-common_sn -35.44% 8.64e-04 difference-common_sn -37.30% 8.55e-04 difference-common_nt -21.60% 1.00e-04 difference-common_nt -21.92% 1.01e-04 difference-common_tn -43.92% 5.91e-05 difference-common_tn -41.78% 5.92e-05 difference-mix_nn -19.40% 1.78e-02 difference-mix_nn -19.75% 1.78e-02 difference-mix_ns -21.96% 4.36e-03 difference-mix_ns -20.79% 4.35e-03 difference-mix_sn +17.39% 1.49e-03 difference-mix_sn +17.54% 1.49e-03 difference-mix_nt -32.09% 8.57e-05 difference-mix_nt -31.74% 8.52e-05 difference-mix_tn -31.83% 5.37e-05 difference-mix_tn -34.00% 5.45e-05 difference-block_nn -69.98% 7.37e-05 difference-block_nn -70.80% 7.57e-05 difference-block_ns -65.17% 6.55e-06 difference-block_ns -65.14% 6.54e-06 difference-block_sn -38.22% 5.43e-06 difference-block_sn -40.15% 5.44e-06 ``` Relative to before this commit: ``` Benchmark Runtime change Original runtime difference-disj_nn -5.13% 3.75e-08 difference-disj_nn -4.66% 3.75e-08 difference-disj_ns -4.45% 3.75e-08 difference-disj_ns -4.79% 3.75e-08 difference-disj_sn +3.17% 3.56e-08 difference-disj_sn -1.96% 3.54e-08 difference-disj_nt -4.57% 3.74e-08 difference-disj_nt -4.60% 3.74e-08 difference-disj_tn -1.27% 3.54e-08 difference-disj_tn -1.70% 3.54e-08 difference-common_nn -2.97% 8.08e-03 difference-common_nn -4.76% 8.08e-03 difference-common_ns -3.80% 4.34e-03 difference-common_ns -4.62% 4.35e-03 difference-common_sn -11.50% 6.30e-04 difference-common_sn -13.83% 6.22e-04 difference-common_nt -0.85% 7.91e-05 difference-common_nt -0.62% 7.92e-05 difference-common_tn -10.57% 3.71e-05 difference-common_tn -7.08% 3.71e-05 difference-mix_nn -3.75% 1.49e-02 difference-mix_nn -3.89% 1.49e-02 difference-mix_ns -2.90% 3.51e-03 difference-mix_ns -1.76% 3.51e-03 difference-mix_sn -5.58% 1.86e-03 difference-mix_sn -5.90% 1.86e-03 difference-mix_nt -4.51% 6.09e-05 difference-mix_nt -4.66% 6.10e-05 difference-mix_tn -12.26% 4.18e-05 difference-mix_tn -13.59% 4.16e-05 difference-block_nn -14.32% 2.58e-05 difference-block_nn -15.50% 2.62e-05 difference-block_ns -26.95% 3.12e-06 difference-block_ns -25.84% 3.07e-06 difference-block_sn -8.31% 3.66e-06 difference-block_sn -11.33% 3.67e-06 ``` --- containers/src/Data/IntMap/Internal.hs | 40 ++++++++++++-------------- 1 file changed, 18 insertions(+), 22 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index d77825e99..6c681f918 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -683,17 +683,15 @@ difference = start Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - goLFused min = loop - where - loop Tip !_ = Empty - loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of - DR min' minV' n' -> NonEmpty min' minV' n' - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) - | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) + goLFused !_ Tip !_ = Empty + goLFused !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of + DR min' minV' n' -> NonEmpty min' minV' n' + goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> goLFused min n1 l2 + EQ | max1 > max2 -> binL (goLFused min l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) + | max1 < max2 -> binL (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> binL (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> binL (goLFused min l1 n2) (NonEmpty max1 maxV1 r1) goR1 maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 @@ -729,17 +727,15 @@ difference = start Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - goRFused max = loop - where - loop Tip !_ = Empty - loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of - DR max' maxV' n' -> NonEmpty max' maxV' n' - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) - | otherwise -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 - GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) + goRFused !_ Tip !_ = Empty + goRFused !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of + DR max' maxV' n' -> NonEmpty max' maxV' n' + goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> goRFused max n1 r2 + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goRFused max r1 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) + | otherwise -> binR (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT -> binR (NonEmpty min1 minV1 l1) (goRFused max r1 n2) goLookupL k v !_ Tip = NonEmpty k v Tip goLookupL k v !xorCache (Bin max _ l r) From 4ce50315fb6bb031bcdc47eed80d948c987f9773 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 15 Sep 2016 00:26:21 -0500 Subject: [PATCH 017/147] Remove a redundant strict pair type --- containers/src/Data/IntMap/Internal.hs | 63 +++++++++---------- containers/src/Data/IntMap/Lazy.hs | 60 +++++++++--------- containers/src/Data/IntMap/Strict/Internal.hs | 60 +++++++++--------- 3 files changed, 91 insertions(+), 92 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 6c681f918..a1380ae56 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -59,6 +59,7 @@ import Data.Word (Word) import qualified Data.Bits (xor) import qualified Data.IntSet (IntSet, fromDistinctAscList, member, notMember) +import Utils.Containers.Internal.StrictPair (StrictPair(..)) import Prelude hiding (foldr, foldl, lookup, null, map, min, max) @@ -1212,72 +1213,70 @@ partitionWithKey p = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) start (IntMap (NonEmpty min minV root)) - | p min minV = let SP t f = goTrueL root + | p min minV = let t :*: f = goTrueL root in (IntMap (NonEmpty min minV t), IntMap f) - | otherwise = let SP t f = goFalseL root + | otherwise = let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min minV f)) - goTrueL Tip = SP Tip Empty + goTrueL Tip = Tip :*: Empty goTrueL (Bin max maxV l r) - | p max maxV = let SP tl fl = goTrueL l - SP tr fr = goTrueR r - in SP (Bin max maxV tl tr) (binL fl fr) - | otherwise = let SP tl fl = goTrueL l - SP tr fr = goFalseR r + | p max maxV = let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin max maxV tl tr :*: binL fl fr + | otherwise = let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r t = case tr of Empty -> tl NonEmpty max' maxV' r' -> Bin max' maxV' tl r' f = case fl of Empty -> r2lMap $ NonEmpty max maxV fr NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' fr) - in SP t f + in t :*: f - goTrueR Tip = SP Tip Empty + goTrueR Tip = Tip :*: Empty goTrueR (Bin min minV l r) - | p min minV = let SP tl fl = goTrueL l - SP tr fr = goTrueR r - in SP (Bin min minV tl tr) (binR fl fr) - | otherwise = let SP tl fl = goFalseL l - SP tr fr = goTrueR r + | p min minV = let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin min minV tl tr :*: binR fl fr + | otherwise = let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r t = case tl of Empty -> tr NonEmpty min' minV' l' -> Bin min' minV' l' tr f = case fr of Empty -> l2rMap $ NonEmpty min minV fl NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV fl r') - in SP t f + in t :*: f - goFalseL Tip = SP Empty Tip + goFalseL Tip = Empty :*: Tip goFalseL (Bin max maxV l r) - | p max maxV = let SP tl fl = goFalseL l - SP tr fr = goTrueR r + | p max maxV = let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r t = case tl of Empty -> r2lMap $ NonEmpty max maxV tr NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' tr) f = case fr of Empty -> fl NonEmpty max' maxV' r' -> Bin max' maxV' fl r' - in SP t f - | otherwise = let SP tl fl = goFalseL l - SP tr fr = goFalseR r - in SP (binL tl tr) (Bin max maxV fl fr) + in t :*: f + | otherwise = let tl :*: fl = goFalseL l + tr :*: fr = goFalseR r + in binL tl tr :*: Bin max maxV fl fr - goFalseR Tip = SP Empty Tip + goFalseR Tip = Empty :*: Tip goFalseR (Bin min minV l r) - | p min minV = let SP tl fl = goTrueL l - SP tr fr = goFalseR r + | p min minV = let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r t = case tr of Empty -> l2rMap $ NonEmpty min minV tl NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV tl r') f = case fl of Empty -> fr NonEmpty min' minV' l' -> Bin min' minV' l' fr - in SP t f - | otherwise = let SP tl fl = goFalseL l - SP tr fr = goFalseR r - in SP (binR tl tr) (Bin min minV fl fr) - -data SP a b = SP !a !b + in t :*: f + | otherwise = let tl :*: fl = goFalseL l + tr :*: fr = goFalseR r + in binR tl tr :*: Bin min minV fl fr -- | /O(min(n,W))/. The expression (@'split' k map@) is a pair @(map1,map2)@ -- where all keys in @map1@ are lower than @k@ and all keys in diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 9408fb2de..dfab80aa8 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1413,70 +1413,70 @@ mapEitherWithKey func = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) start (IntMap (NonEmpty min minV root)) = case func min minV of - Left v -> let SP t f = goTrueL root + Left v -> let t :*: f = goTrueL root in (IntMap (NonEmpty min v t), IntMap f) - Right v -> let SP t f = goFalseL root + Right v -> let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min v f)) - goTrueL Tip = SP Tip Empty + goTrueL Tip = Tip :*: Empty goTrueL (Bin max maxV l r) = case func max maxV of - Left v -> let SP tl fl = goTrueL l - SP tr fr = goTrueR r - in SP (Bin max v tl tr) (binL fl fr) - Right v -> let SP tl fl = goTrueL l - SP tr fr = goFalseR r + Left v -> let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin max v tl tr :*: binL fl fr + Right v -> let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r t = case tr of Empty -> tl NonEmpty max' maxV' r' -> Bin max' maxV' tl r' f = case fl of Empty -> r2lMap $ NonEmpty max v fr NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' fr) - in SP t f + in t :*: f - goTrueR Tip = SP Tip Empty + goTrueR Tip = Tip :*: Empty goTrueR (Bin min minV l r) = case func min minV of - Left v -> let SP tl fl = goTrueL l - SP tr fr = goTrueR r - in SP (Bin min v tl tr) (binR fl fr) - Right v -> let SP tl fl = goFalseL l - SP tr fr = goTrueR r + Left v -> let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin min v tl tr :*: binR fl fr + Right v -> let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r t = case tl of Empty -> tr NonEmpty min' minV' l' -> Bin min' minV' l' tr f = case fr of Empty -> l2rMap $ NonEmpty min v fl NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v fl r') - in SP t f + in t :*: f - goFalseL Tip = SP Empty Tip + goFalseL Tip = Empty :*: Tip goFalseL (Bin max maxV l r) = case func max maxV of - Left v -> let SP tl fl = goFalseL l - SP tr fr = goTrueR r + Left v -> let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r t = case tl of Empty -> r2lMap $ NonEmpty max v tr NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' tr) f = case fr of Empty -> fl NonEmpty max' maxV' r' -> Bin max' maxV' fl r' - in SP t f - Right v -> let SP tl fl = goFalseL l - SP tr fr = goFalseR r - in SP (binL tl tr) (Bin max v fl fr) + in t :*: f + Right v -> let tl :*: fl = goFalseL l + tr :*: fr = goFalseR r + in binL tl tr :*: Bin max v fl fr - goFalseR Tip = SP Empty Tip + goFalseR Tip = Empty :*: Tip goFalseR (Bin min minV l r) = case func min minV of - Left v -> let SP tl fl = goTrueL l - SP tr fr = goFalseR r + Left v -> let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r t = case tr of Empty -> l2rMap $ NonEmpty min v tl NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v tl r') f = case fl of Empty -> fr NonEmpty min' minV' l' -> Bin min' minV' l' fr - in SP t f - Right v -> let SP tl fl = goFalseL l - SP tr fr = goFalseR r - in SP (binR tl tr) (Bin min v fl fr) + in t :*: f + Right v -> let tl :*: fl = goFalseL l + tr :*: fr = goFalseR r + in binR tl tr :*: Bin min v fl fr -- | /O(min(n,W))/. Update the value at the minimal key. -- diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 6568b1ef7..65e58ceb5 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1475,70 +1475,70 @@ mapEitherWithKey func = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) start (IntMap (NonEmpty min minV root)) = case func min minV of - Left !v -> let SP t f = goTrueL root + Left !v -> let t :*: f = goTrueL root in (IntMap (NonEmpty min v t), IntMap f) - Right !v -> let SP t f = goFalseL root + Right !v -> let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min v f)) - goTrueL Tip = SP Tip Empty + goTrueL Tip = Tip :*: Empty goTrueL (Bin max maxV l r) = case func max maxV of - Left !v -> let SP tl fl = goTrueL l - SP tr fr = goTrueR r - in SP (Bin max v tl tr) (binL fl fr) - Right !v -> let SP tl fl = goTrueL l - SP tr fr = goFalseR r + Left !v -> let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin max v tl tr :*: binL fl fr + Right !v -> let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r t = case tr of Empty -> tl NonEmpty max' maxV' r' -> Bin max' maxV' tl r' f = case fl of Empty -> r2lMap $ NonEmpty max v fr NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' fr) - in SP t f + in t :*: f - goTrueR Tip = SP Tip Empty + goTrueR Tip = Tip :*: Empty goTrueR (Bin min minV l r) = case func min minV of - Left !v -> let SP tl fl = goTrueL l - SP tr fr = goTrueR r - in SP (Bin min v tl tr) (binR fl fr) - Right !v -> let SP tl fl = goFalseL l - SP tr fr = goTrueR r + Left !v -> let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin min v tl tr :*: binR fl fr + Right !v -> let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r t = case tl of Empty -> tr NonEmpty min' minV' l' -> Bin min' minV' l' tr f = case fr of Empty -> l2rMap $ NonEmpty min v fl NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v fl r') - in SP t f + in t :*: f - goFalseL Tip = SP Empty Tip + goFalseL Tip = Empty :*: Tip goFalseL (Bin max maxV l r) = case func max maxV of - Left !v -> let SP tl fl = goFalseL l - SP tr fr = goTrueR r + Left !v -> let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r t = case tl of Empty -> r2lMap $ NonEmpty max v tr NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' tr) f = case fr of Empty -> fl NonEmpty max' maxV' r' -> Bin max' maxV' fl r' - in SP t f - Right !v -> let SP tl fl = goFalseL l - SP tr fr = goFalseR r - in SP (binL tl tr) (Bin max v fl fr) + in t :*: f + Right !v -> let tl :*: fl = goFalseL l + tr :*: fr = goFalseR r + in binL tl tr :*: Bin max v fl fr - goFalseR Tip = SP Empty Tip + goFalseR Tip = Empty :*: Tip goFalseR (Bin min minV l r) = case func min minV of - Left !v -> let SP tl fl = goTrueL l - SP tr fr = goFalseR r + Left !v -> let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r t = case tr of Empty -> l2rMap $ NonEmpty min v tl NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v tl r') f = case fl of Empty -> fr NonEmpty min' minV' l' -> Bin min' minV' l' fr - in SP t f - Right !v -> let SP tl fl = goFalseL l - SP tr fr = goFalseR r - in SP (binR tl tr) (Bin min v fl fr) + in t :*: f + Right !v -> let tl :*: fl = goFalseL l + tr :*: fr = goFalseR r + in binR tl tr :*: Bin min v fl fr -- | /O(min(n,W))/. Update the value at the minimal key. -- From d78be1a23305b9afa26058611d4eb874dc9c85df Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 15 Sep 2016 14:53:40 -0500 Subject: [PATCH 018/147] Add type signatures to unionDisjoint* --- containers/src/Data/IntMap/Internal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index a1380ae56..9250bd5de 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -592,6 +592,7 @@ union = start | otherwise = Bin min minV l r where xorCacheMin = xor min k +unionDisjointL1 :: a -> Key -> Node L a -> Key -> Node L a -> Node L a unionDisjointL1 _ !_ !_ !_ Tip = error "Data.IntMap.unionDisjoint: impossible" unionDisjointL1 minV1 !min1 Tip !min2 n2@(Bin max2 maxV2 l2 r2) | xor min2 max2 < xor min1 max2 = Bin min1 minV1 n2 Tip @@ -601,6 +602,7 @@ unionDisjointL1 minV1 !min1 (Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin max1 maxV1 (unionDisjointL1 minV1 min1 l1 min2 n2) r1 | otherwise = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) +unionDisjointL2 :: a -> Key -> Node L a -> Key -> Node L a -> Node L a unionDisjointL2 _ !_ Tip !_ !_ = error "Data.IntMap.unionDisjoint: impossible" unionDisjointL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 Tip | xor min1 max1 < xor min2 max1 = Bin min2 minV2 n1 Tip @@ -610,6 +612,7 @@ unionDisjointL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 (Bin max2 maxV2 l2 r | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin max2 maxV2 (unionDisjointL2 minV2 min1 n1 min2 l2) r2 | otherwise = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) +unionDisjointR1 :: a -> Key -> Node R a -> Key -> Node R a -> Node R a unionDisjointR1 _ !_ !_ !_ Tip = error "Data.IntMap.unionDisjoint: impossible" unionDisjointR1 maxV1 !max1 Tip !max2 n2@(Bin min2 minV2 l2 r2) | xor min2 max2 < xor min2 max1 = Bin max1 maxV1 Tip n2 @@ -619,6 +622,7 @@ unionDisjointR1 maxV1 !max1 (Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin min1 minV1 l1 (unionDisjointR1 maxV1 max1 r1 max2 n2) | otherwise = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 +unionDisjointR2 :: a -> Key -> Node R a -> Key -> Node R a -> Node R a unionDisjointR2 _ !_ Tip !_ !_ = error "Data.IntMap.unionDisjoint: impossible" unionDisjointR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 Tip | xor min1 max1 < xor min1 max2 = Bin max2 maxV2 Tip n1 From cb5f54c74d14dae95505dfacbdc9c144fd2f2e53 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 15 Sep 2016 16:42:14 -0500 Subject: [PATCH 019/147] Update merge to match union, separately handling disjoint maps. This should greatly improve the performance of, e.g., emulated difference and intersection. --- containers/src/Data/IntMap/Merge/Internal.hs | 90 ++++++++++---------- containers/src/Data/IntMap/Merge/Lazy.hs | 12 +-- containers/src/Data/IntMap/Merge/Strict.hs | 12 +-- 3 files changed, 57 insertions(+), 57 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index f4956866a..2c2a709ca 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -80,7 +80,7 @@ data WhenMissing f a b = WhenMissing { missingSingle :: Key -> a -> Maybe b, missingLeft :: Node L a -> Node L b, missingRight :: Node R a -> Node R b, - missingAll :: IntMap a -> f (IntMap b) + missingAll :: IntMap_ L a -> f (IntMap_ L b) } -- | A tactic for dealing with keys present in one map but not the other in @@ -102,7 +102,7 @@ type SimpleWhenMissing = WhenMissing Identity -- but @dropMissing@ is much faster. {-# INLINE dropMissing #-} dropMissing :: Applicative f => WhenMissing f a b -dropMissing = WhenMissing (\_ _ -> Nothing) (const Tip) (const Tip) (const (pure (IntMap Empty))) +dropMissing = WhenMissing (\_ _ -> Nothing) (const Tip) (const Tip) (const (pure Empty)) -- | Preserve, unchanged, the entries whose keys are missing from -- the other map. @@ -129,10 +129,10 @@ preserveMissing = WhenMissing (\_ v -> Just v) id id pure -- but this should be a little faster. filterMissing :: Applicative f => (Key -> a -> Bool) -> WhenMissing f a a filterMissing p = WhenMissing (\k v -> if p k v then Just v else Nothing) goLKeep goRKeep (pure . start) where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) - | p min minV = IntMap (NonEmpty min minV (goLKeep root)) - | otherwise = IntMap (goL root) + start Empty = Empty + start (NonEmpty min minV root) + | p min minV = NonEmpty min minV (goLKeep root) + | otherwise = goL root goLKeep Tip = Tip goLKeep (Bin max maxV l r) @@ -253,8 +253,8 @@ type SimpleWhenMatched = WhenMatched Identity merge :: SimpleWhenMissing a c -> SimpleWhenMissing b c -> SimpleWhenMatched a b c -> IntMap a -> IntMap b -> IntMap c merge miss1 miss2 match = start where start (IntMap Empty) (IntMap Empty) = IntMap Empty - start (IntMap Empty) !m2 = runIdentity (missingAll miss2 m2) - start !m1 (IntMap Empty) = runIdentity (missingAll miss1 m1) + start (IntMap Empty) (IntMap !m2) = IntMap (runIdentity (missingAll miss2 m2)) + start (IntMap !m1) (IntMap Empty) = IntMap (runIdentity (missingAll miss1 m1)) start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = case missingSingle miss1 min1 minV1 of Nothing -> IntMap (goL2 minV2 min1 root1 min2 root2) @@ -272,13 +272,17 @@ merge miss1 miss2 match = start where goL1Keep minV1 !min1 Tip !_ Tip = case missingSingle miss1 min1 minV1 of Nothing -> Tip Just minV' -> Bin min1 minV' Tip Tip - goL1Keep minV1 !min1 Tip !min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 goL1Keep minV1 !min1 n1 !min2 Tip = case missingSingle miss1 min1 minV1 of Nothing -> missingLeft miss1 n1 Just minV' -> insertMinL (xor min1 min2) min1 minV' (missingLeft miss1 n1) + goL1Keep minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = case runIdentity (missingAll miss1 (NonEmpty min1 minV1 n1)) of + Empty -> missingLeft miss2 n2 + NonEmpty min1' minV1' n1' -> case missingLeft miss2 n2 of + Tip -> insertMinL (xor min1' min2) min1' minV1' n1' + n2'@(Bin _ _ _ _) -> unionDisjointL1 minV1' min1' n1' min2 n2' + goL1Keep minV1 !min1 Tip !min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 goL1Keep minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint - | xor min1 min2 < xor min1 max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missingRight miss2 r2) + LT | xor min1 min2 < xor min1 max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missingRight miss2 r2) | max1 > max2 -> case missingSingle miss1 max1 maxV1 of Nothing -> case goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 of Empty -> l' @@ -297,8 +301,7 @@ merge miss1 miss2 match = start where where {-# INLINE l' #-} l' = missingLeft miss2 l2 - EQ | max2 < min1 -> disjoint - | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + EQ | max1 > max2 -> case missingSingle miss1 max1 maxV1 of Nothing -> case goR2 maxV2 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' @@ -316,10 +319,7 @@ merge miss1 miss2 match = start where where {-# INLINE l' #-} l' = goL1Keep minV1 min1 l1 min2 l2 - GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint - | otherwise -> binL1 max1 maxV1 (goL1Keep minV1 min1 l1 min2 n2) (missingRight miss1 r1) - where - disjoint = binL1 max1 maxV1 (missingLeft miss2 n2) (missingRight miss1 (Bin min1 minV1 l1 r1)) + GT -> binL1 max1 maxV1 (goL1Keep minV1 min1 l1 min2 n2) (missingRight miss1 r1) -- Merge two left nodes and a minimum value for the second node into a new left node -- Precondition: min2 > min1 @@ -330,10 +330,14 @@ merge miss1 miss2 match = start where goL2Keep minV2 !min1 Tip !min2 n2 = case missingSingle miss2 min2 minV2 of Nothing -> missingLeft miss2 n2 Just minV' -> insertMinL (xor min1 min2) min2 minV' (missingLeft miss2 n2) - goL2Keep minV2 !min1 n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2Keep minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = case runIdentity (missingAll miss2 (NonEmpty min2 minV2 n2)) of + Empty -> missingLeft miss1 n1 + NonEmpty min2' minV2' n2' -> case missingLeft miss1 n1 of + Tip -> insertMinL (xor min1 min2') min2' minV2' n2' + n1'@(Bin _ _ _ _) -> unionDisjointL2 minV2' min1 n1' min2' n2' + goL2Keep minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 goL2Keep minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint - | xor min1 min2 < xor min2 max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missingRight miss1 r1) + GT | xor min1 min2 < xor min2 max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missingRight miss1 r1) | max1 > max2 -> case missingSingle miss1 max1 maxV1 of Nothing -> case goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) of Empty -> l' @@ -352,8 +356,7 @@ merge miss1 miss2 match = start where where {-# INLINE l' #-} l' = missingLeft miss1 l1 - EQ | max1 < min2 -> disjoint - | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + EQ | max1 > max2 -> case missingSingle miss1 max1 maxV1 of Nothing -> case goR2 maxV2 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' @@ -371,10 +374,7 @@ merge miss1 miss2 match = start where where {-# INLINE l' #-} l' = goL2Keep minV2 min1 l1 min2 l2 - LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint - | otherwise -> binL2 max2 maxV2 (goL2Keep minV2 min1 n1 min2 l2) (missingRight miss2 r2) - where - disjoint = binL2 max2 maxV2 (missingLeft miss1 n1) (missingRight miss2 (Bin min2 minV2 l2 r2)) + LT -> binL2 max2 maxV2 (goL2Keep minV2 min1 n1 min2 l2) (missingRight miss2 r2) -- goLFusedKeep !_ Tip Tip = Tip goLFusedKeep !_ Tip n2 = missingLeft miss2 n2 @@ -407,13 +407,17 @@ merge miss1 miss2 match = start where goR1Keep maxV1 !max1 Tip !_ Tip = case missingSingle miss1 max1 maxV1 of Nothing -> Tip Just maxV' -> Bin max1 maxV' Tip Tip - goR1Keep maxV1 !max1 Tip !max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1Keep maxV1 !max1 n1 !max2 Tip = case missingSingle miss1 max1 maxV1 of + goR1Keep maxV1 !max1 !n1 !max2 Tip = case missingSingle miss1 max1 maxV1 of Nothing -> missingRight miss1 n1 Just maxV' -> insertMaxR (xor max1 max2) max1 maxV' (missingRight miss1 n1) + goR1Keep maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = case l2rMap (runIdentity (missingAll miss1 (r2lMap (NonEmpty max1 maxV1 n1)))) of + Empty -> missingRight miss2 n2 + NonEmpty max1' maxV1' n1' -> case missingRight miss2 n2 of + Tip -> insertMaxR (xor max1' max2) max1' maxV1' n1' + n2'@(Bin _ _ _ _) -> unionDisjointR1 maxV1' max1' n1' max2 n2' + goR1Keep maxV1 !max1 Tip !max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 goR1Keep maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint - | xor min2 max1 > xor max1 max2 -> binR2 min2 minV2 (missingLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) + LT | xor min2 max1 > xor max1 max2 -> binR2 min2 minV2 (missingLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) | min1 < min2 -> case missingSingle miss1 min1 minV1 of Nothing -> case goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 of Empty -> r' @@ -432,8 +436,7 @@ merge miss1 miss2 match = start where where {-# INLINE r' #-} r' = missingRight miss2 r2 - EQ | max1 < min2 -> disjoint - | min1 < min2 -> case missingSingle miss1 min1 minV1 of + EQ | min1 < min2 -> case missingSingle miss1 min1 minV1 of Nothing -> case goL2 minV2 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' @@ -451,10 +454,7 @@ merge miss1 miss2 match = start where where {-# INLINE r' #-} r' = goR1Keep maxV1 max1 r1 max2 r2 - GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint - | otherwise -> binR1 min1 minV1 (missingLeft miss1 l1) (goR1Keep maxV1 max1 r1 max2 n2) - where - disjoint = binR1 min1 minV1 (missingLeft miss1 (Bin max1 maxV1 l1 r1)) (missingRight miss2 n2) + GT -> binR1 min1 minV1 (missingLeft miss1 l1) (goR1Keep maxV1 max1 r1 max2 n2) -- Merge two left nodes and a minimum value for the second node into a new left node -- Precondition: max2 < max1 @@ -465,10 +465,14 @@ merge miss1 miss2 match = start where goR2Keep maxV2 !max1 Tip !max2 n2 = case missingSingle miss2 max2 maxV2 of Nothing -> missingRight miss2 n2 Just maxV' -> insertMaxR (xor max1 max2) max2 maxV' (missingRight miss2 n2) - goR2Keep maxV2 !max1 n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2Keep maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = case l2rMap (runIdentity (missingAll miss2 (r2lMap (NonEmpty max2 maxV2 n2)))) of + Empty -> missingRight miss1 n1 + NonEmpty max2' maxV2' n2' -> case missingRight miss1 n1 of + Tip -> insertMaxR (xor max1 max2') max2' maxV2' n2' + n1'@(Bin _ _ _ _) -> unionDisjointR2 maxV2' max1 n1' max2' n2' + goR2Keep maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 goR2Keep maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint - | xor min1 max2 > xor max2 max1 -> binR1 min1 minV1 (missingLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) + GT | xor min1 max2 > xor max2 max1 -> binR1 min1 minV1 (missingLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) | min1 < min2 -> case missingSingle miss1 min1 minV1 of Nothing -> case goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) of Empty -> r' @@ -487,8 +491,7 @@ merge miss1 miss2 match = start where where {-# INLINE r' #-} r' = missingRight miss1 r1 - EQ | max2 < min1 -> disjoint - | min1 < min2 -> case missingSingle miss1 min1 minV1 of + EQ | min1 < min2 -> case missingSingle miss1 min1 minV1 of Nothing -> case goL2 minV2 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' @@ -506,10 +509,7 @@ merge miss1 miss2 match = start where where {-# INLINE r' #-} r' = goR2Keep maxV2 max1 r1 max2 r2 - LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint - | otherwise -> binR2 min2 minV2 (missingLeft miss2 l2) (goR2Keep maxV2 max1 n1 max2 r2) - where - disjoint = binR2 min2 minV2 (missingLeft miss2 (Bin max2 maxV2 l2 r2)) (missingRight miss1 n1) + LT -> binR2 min2 minV2 (missingLeft miss2 l2) (goR2Keep maxV2 max1 n1 max2 r2) -- goRFusedKeep !_ Tip Tip = Tip goRFusedKeep !_ Tip n2 = missingRight miss2 n2 diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 0e6aa747b..ad7011e46 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -67,8 +67,8 @@ import Data.IntMap.Merge.Internal -- but @mapMissing@ is somewhat faster. mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b mapMissing f = WhenMissing (\k v -> Just (f k v)) goL goR (pure . start) where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f min minV) (goL root)) + start Empty = Empty + start (NonEmpty min minV root) = NonEmpty min (f min minV) (goL root) goL Tip = Tip goL (Bin k v l r) = Bin k (f k v) (goL l) (goR r) @@ -89,10 +89,10 @@ mapMissing f = WhenMissing (\k v -> Just (f k v)) goL goR (pure . start) where -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b mapMaybeMissing f = WhenMissing f goLKeep goRKeep (pure . start) where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = case f min minV of - Just minV' -> IntMap (NonEmpty min minV' (goLKeep root)) - Nothing -> IntMap (goL root) + start Empty = Empty + start (NonEmpty min minV root) = case f min minV of + Just minV' -> NonEmpty min minV' (goLKeep root) + Nothing -> goL root goLKeep Tip = Tip goLKeep (Bin max maxV l r) = case f max maxV of diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 7a5554260..07470d657 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -71,8 +71,8 @@ import Data.IntMap.Merge.Internal -- but @mapMissing@ is somewhat faster. mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b mapMissing f = WhenMissing (\k v -> Just $! f k v) goL goR (pure . start) where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # goL root) + start Empty = Empty + start (NonEmpty min minV root) = NonEmpty min #! f min minV # goL root goL Tip = Tip goL (Bin k v l r) = Bin k #! f k v # goL l # goR r @@ -93,10 +93,10 @@ mapMissing f = WhenMissing (\k v -> Just $! f k v) goL goR (pure . start) where -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b mapMaybeMissing f = WhenMissing f goLKeep goRKeep (pure . start) where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = case f min minV of - Just !minV' -> IntMap (NonEmpty min minV' (goLKeep root)) - Nothing -> IntMap (goL root) + start Empty = Empty + start (NonEmpty min minV root) = case f min minV of + Just !minV' -> NonEmpty min minV' (goLKeep root) + Nothing -> goL root goLKeep Tip = Tip goLKeep (Bin max maxV l r) = case f max maxV of From 50cb1e2df63420905395cb9111d3e90b0d541245 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Fri, 16 Sep 2016 15:56:21 -0500 Subject: [PATCH 020/147] Clarify copyright lines of Data.IntMap --- containers/src/Data/IntMap.hs | 6 +++--- containers/src/Data/IntMap/Internal.hs | 6 +++--- containers/src/Data/IntMap/Lazy.hs | 6 +++--- containers/src/Data/IntMap/Strict/Internal.hs | 8 ++++---- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/containers/src/Data/IntMap.hs b/containers/src/Data/IntMap.hs index 15df20d3e..b62f6f68d 100644 --- a/containers/src/Data/IntMap.hs +++ b/containers/src/Data/IntMap.hs @@ -14,9 +14,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 --- (c) Jonathan S. 2016 +-- Copyright : Documentation & Interface (c) Daan Leijen 2002 +-- Documentation (c) Andriy Palamarchuk 2008 +-- Documentation & Implementation (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 9250bd5de..0e8aaa8db 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -8,9 +8,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Internal --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 --- (c) Jonathan S. 2016 +-- Copyright : Documentation & Interface (c) Daan Leijen 2002 +-- Documentation (c) Andriy Palamarchuk 2008 +-- Documentation & Implementation (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index dfab80aa8..eafd8e940 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -6,9 +6,9 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Lazy --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 --- (c) Jonathan S. 2016 +-- Copyright : Documentation & Interface (c) Daan Leijen 2002 +-- Documentation (c) Andriy Palamarchuk 2008 +-- Documentation & Implementation (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 65e58ceb5..4fb96bce0 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -5,10 +5,10 @@ ----------------------------------------------------------------------------- -- | --- Module : Data.IntMap.Strict.Internal --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 --- (c) Jonathan S. 2016 +-- Module : Data.IntMap.Strict +-- Copyright : Documentation & Interface (c) Daan Leijen 2002 +-- Documentation (c) Andriy Palamarchuk 2008 +-- Documentation & Implementation (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable From 62add14a1009eacf9b3c54f02765502368ac5d0f Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 17 Sep 2016 17:23:59 -0500 Subject: [PATCH 021/147] Optimize fromAscList and friends Relative to old Data.IntMap: ``` Benchmark Runtime change Original runtime fromAscList -81.88% 6.83e-04 fromDistinctAscList -42.23% 2.24e-04 ``` --- containers/src/Data/IntMap/Internal.hs | 13 +++++++++ containers/src/Data/IntMap/Lazy.hs | 27 ++++++++++++++++--- containers/src/Data/IntMap/Strict/Internal.hs | 27 ++++++++++++++++--- 3 files changed, 59 insertions(+), 8 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 0e8aaa8db..6a4a066f0 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1124,6 +1124,19 @@ toAscList = foldrWithKey (\k v l -> (k, v) : l) [] toDescList :: IntMap a -> [(Key, a)] toDescList = foldlWithKey (\l k v -> (k, v) : l) [] +-- | A stack used in the in-order building of IntMaps. +data BuildStack a = Push {-# UNPACK #-} !Key a !(Node L a) !(BuildStack a) | StackBase + +pushBuildStack :: Word -> Key -> a -> Node R a -> BuildStack a -> BuildStack a +pushBuildStack !xorCache !k v !r (Push min minV l stk) + | xor min k < xorCache = pushBuildStack xorCache k v (Bin min minV l r) stk +pushBuildStack !_ !k v Tip !stk = Push k v Tip stk +pushBuildStack !_ !k v (Bin min minV l r) !stk = Push min minV (Bin k v l r) stk + +completeBuildStack :: Key -> a -> Node R a -> BuildStack a -> IntMap_ L a +completeBuildStack !max maxV !r StackBase = r2lMap (NonEmpty max maxV r) +completeBuildStack !max maxV !r (Push min minV l stk) = completeBuildStack max maxV (Bin min minV l r) stk + -- | /O(n)/. Filter all values that satisfy some predicate. -- -- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index eafd8e940..eef4e8b3a 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1311,7 +1311,14 @@ fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] fromAscList :: [(Key, a)] -> IntMap a -fromAscList = fromList +fromAscList = start where + start [] = IntMap Empty + start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + + go !k v [] !stk = completeBuildStack k v Tip stk + go !k v ((!next, nextV) : rest) !stk + | next == k = go k nextV rest stk + | otherwise = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order. @@ -1319,7 +1326,7 @@ fromAscList = fromList -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a -fromAscListWith = fromListWith +fromAscListWith f = fromAscListWithKey (const f) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -1328,7 +1335,14 @@ fromAscListWith = fromListWith -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a -fromAscListWithKey = fromListWithKey +fromAscListWithKey f = start where + start [] = IntMap Empty + start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + + go !k v [] !stk = completeBuildStack k v Tip stk + go !k v ((!next, nextV) : rest) !stk + | next == k = go k (f k nextV v) rest stk + | otherwise = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. @@ -1336,7 +1350,12 @@ fromAscListWithKey = fromListWithKey -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] fromDistinctAscList :: [(Key, a)] -> IntMap a -fromDistinctAscList = fromList +fromDistinctAscList = start where + start [] = IntMap Empty + start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + + go !k v [] !stk = completeBuildStack k v Tip stk + go !k v ((!next, nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) -- | /O(n)/. Map values and collect the 'Just' results. -- diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 4fb96bce0..85c038f2e 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1373,7 +1373,14 @@ fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] fromAscList :: [(Key, a)] -> IntMap a -fromAscList = fromList +fromAscList = start where + start [] = IntMap Empty + start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + + go !k v [] !stk = completeBuildStack k v Tip stk + go !k v ((!next, nextV) : rest) !stk + | next == k = nextV `seq` go k nextV rest stk + | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k next) k v Tip stk) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order. @@ -1381,7 +1388,7 @@ fromAscList = fromList -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a -fromAscListWith = fromListWith +fromAscListWith f = fromAscListWithKey (const f) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -1390,7 +1397,14 @@ fromAscListWith = fromListWith -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a -fromAscListWithKey = fromListWithKey +fromAscListWithKey f = start where + start [] = IntMap Empty + start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + + go !k v [] !stk = completeBuildStack k v Tip stk + go !k v ((!next, nextV) : rest) !stk + | next == k = let !v' = f k nextV v in go k v' rest stk + | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k next) k v Tip stk) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. @@ -1398,7 +1412,12 @@ fromAscListWithKey = fromListWithKey -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] fromDistinctAscList :: [(Key, a)] -> IntMap a -fromDistinctAscList = fromList +fromDistinctAscList = start where + start [] = IntMap Empty + start ((!min, !minV) : rest) = IntMap (go min minV rest StackBase) + + go !k !v [] !stk = completeBuildStack k v Tip stk + go !k !v ((!next, !nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) -- | /O(n)/. Map values and collect the 'Just' results. -- From b3d3f71049401d96a107a808ad33364622d32055 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sun, 18 Sep 2016 14:06:18 -0500 Subject: [PATCH 022/147] Implement Semigroup for IntMap --- containers/src/Data/IntMap/Internal.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 6a4a066f0..205ca3584 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -52,6 +52,9 @@ import Data.Monoid (Monoid(..)) import qualified Data.List (foldl') import qualified Data.Foldable (Foldable(..)) import Data.Traversable (Traversable(..)) +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..), stimesIdempotentMonoid) +#endif import Data.Functor ((<$>)) @@ -128,6 +131,11 @@ instance Monoid (IntMap a) where mempty = empty mappend = union +#if MIN_VERSION_base(4,9,0) +instance Semigroup (IntMap a) where + stimes = stimesIdempotentMonoid +#endif + instance NFData a => NFData (IntMap a) where rnf (IntMap Empty) = () rnf (IntMap (NonEmpty _ v n)) = rnf v `seq` rnf n From 77533700566b4d5f3999729de63de133f29e7e77 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 19 Sep 2016 10:39:12 -0500 Subject: [PATCH 023/147] Add a few small comments --- containers/src/Data/IntMap/Internal.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 205ca3584..531d7ebce 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -75,9 +75,12 @@ i2w = fromIntegral xor :: Key -> Key -> Word xor a b = Data.Bits.xor (i2w a) (i2w b) +-- Phantom types used to separate the types of left and right nodes. +-- They are uninhabited simply to ensure that they are only used as type parameters. newtype L = L L newtype R = R R +-- | A map of integers to values @a@. newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) data IntMap_ t a = NonEmpty {-# UNPACK #-} !Key a !(Node t a) | Empty deriving (Eq) data Node t a = Bin {-# UNPACK #-} !Key a !(Node L a) !(Node R a) | Tip deriving (Eq, Show) From 86c02f0f8febb6e56aa2768a2bd098d7fbec4db3 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 19 Sep 2016 11:22:58 -0500 Subject: [PATCH 024/147] Combine equivalent unionDisjoint functions Relative to old Data.IntMap: ``` Benchmark Runtime change Original runtime union-disj_nn +8.47% 2.08e-07 union-disj_nn +8.86% 2.09e-07 union-disj_ns +8.94% 1.85e-07 union-disj_ns +8.58% 1.85e-07 union-disj_sn +4.95% 1.94e-07 union-disj_sn +4.17% 1.94e-07 union-disj_nt +10.09% 1.55e-07 union-disj_nt +5.10% 1.55e-07 union-disj_tn +2.87% 1.61e-07 union-disj_tn +2.14% 1.61e-07 union-common_nn -15.47% 1.12e-02 union-common_nn -16.50% 1.10e-02 union-common_ns -12.74% 4.69e-03 union-common_ns -12.35% 4.67e-03 union-common_sn -10.91% 4.67e-03 union-common_sn -10.70% 4.67e-03 union-common_nt -29.49% 9.11e-05 union-common_nt -31.72% 9.43e-05 union-common_tn -21.95% 8.89e-05 union-common_tn -23.82% 8.80e-05 union-mix_nn +10.18% 2.06e-02 union-mix_nn +10.24% 2.06e-02 union-mix_ns +4.01% 5.10e-03 union-mix_ns +4.26% 5.10e-03 union-mix_sn +4.61% 5.11e-03 union-mix_sn +5.43% 5.08e-03 union-mix_nt -7.42% 8.05e-05 union-mix_nt -5.83% 8.03e-05 union-mix_tn -9.86% 8.58e-05 union-mix_tn -9.95% 8.61e-05 union-block_nn +34.10% 1.03e-04 union-block_nn +34.14% 1.03e-04 union-block_ns +27.90% 6.79e-06 union-block_ns +27.85% 6.78e-06 union-block_sn +28.33% 6.92e-06 union-block_sn +28.69% 6.88e-06 ``` Relative to previous commit: ``` Benchmark Runtime change Original runtime union-disj_nn -0.06% 2.26e-07 union-disj_nn -0.80% 2.29e-07 union-disj_ns -2.43% 2.06e-07 union-disj_ns +1.34% 1.98e-07 union-disj_sn -1.92% 2.08e-07 union-disj_sn -1.42% 2.05e-07 union-disj_nt +2.67% 1.66e-07 union-disj_nt -0.39% 1.64e-07 union-disj_tn -2.84% 1.71e-07 union-disj_tn -3.55% 1.71e-07 union-common_nn +0.13% 9.45e-03 union-common_nn -1.41% 9.34e-03 union-common_ns -1.23% 4.14e-03 union-common_ns -0.89% 4.13e-03 union-common_sn -0.47% 4.18e-03 union-common_sn -0.52% 4.19e-03 union-common_nt -4.65% 6.74e-05 union-common_nt -4.49% 6.74e-05 union-common_tn -1.19% 7.02e-05 union-common_tn -5.17% 7.07e-05 union-mix_nn -1.80% 2.31e-02 union-mix_nn -1.31% 2.30e-02 union-mix_ns -0.99% 5.36e-03 union-mix_ns -1.49% 5.40e-03 union-mix_sn -1.45% 5.43e-03 union-mix_sn -1.61% 5.44e-03 union-mix_nt -3.37% 7.72e-05 union-mix_nt -1.61% 7.69e-05 union-mix_tn -3.93% 8.05e-05 union-mix_tn -3.36% 8.02e-05 union-block_nn -2.99% 1.43e-04 union-block_nn -3.64% 1.44e-04 union-block_ns -2.02% 8.87e-06 union-block_ns -2.82% 8.92e-06 union-block_sn -0.84% 8.96e-06 union-block_sn -1.30% 8.97e-06 ``` --- containers/src/Data/IntMap/Internal.hs | 52 ++++++------------- containers/src/Data/IntMap/Lazy.hs | 8 +-- containers/src/Data/IntMap/Merge/Internal.hs | 8 +-- containers/src/Data/IntMap/Strict/Internal.hs | 8 +-- 4 files changed, 28 insertions(+), 48 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 531d7ebce..07c3500f1 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -483,7 +483,7 @@ union = start goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL1 minV1 min1 n1 min2 n2 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL minV1 min2 n2 min1 n1 goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min1 min2 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 @@ -497,7 +497,7 @@ union = start goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL2 minV2 min1 n1 min2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL minV2 min1 n1 min2 n2 goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 @@ -522,7 +522,7 @@ union = start goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR1 maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR maxV1 max1 n1 max2 n2 goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 @@ -536,7 +536,7 @@ union = start goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR2 maxV2 max1 n1 max2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR maxV2 max2 n2 max1 n1 goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 @@ -603,46 +603,26 @@ union = start | otherwise = Bin min minV l r where xorCacheMin = xor min k -unionDisjointL1 :: a -> Key -> Node L a -> Key -> Node L a -> Node L a -unionDisjointL1 _ !_ !_ !_ Tip = error "Data.IntMap.unionDisjoint: impossible" -unionDisjointL1 minV1 !min1 Tip !min2 n2@(Bin max2 maxV2 l2 r2) - | xor min2 max2 < xor min1 max2 = Bin min1 minV1 n2 Tip - | otherwise = Bin min1 minV1 l2 (insertMaxR (xor min1 max2) max2 maxV2 r2) -unionDisjointL1 minV1 !min1 (Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) - | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin max1 maxV1 l2 (unionDisjointR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin max1 maxV1 (unionDisjointL1 minV1 min1 l1 min2 n2) r1 - | otherwise = Bin max1 maxV1 n2 (Bin min1 minV1 l1 r1) - -unionDisjointL2 :: a -> Key -> Node L a -> Key -> Node L a -> Node L a -unionDisjointL2 _ !_ Tip !_ !_ = error "Data.IntMap.unionDisjoint: impossible" -unionDisjointL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 Tip +unionDisjointL :: a -> Key -> Node L a -> Key -> Node L a -> Node L a +unionDisjointL _ !_ Tip !_ !_ = error "Data.IntMap.unionDisjoint: impossible" +unionDisjointL minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 Tip | xor min1 max1 < xor min2 max1 = Bin min2 minV2 n1 Tip | otherwise = Bin min2 minV2 l1 (insertMaxR (xor min2 max1) max1 maxV1 r1) -unionDisjointL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 (Bin max2 maxV2 l2 r2) - | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin max2 maxV2 l1 (unionDisjointR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin max2 maxV2 (unionDisjointL2 minV2 min1 n1 min2 l2) r2 +unionDisjointL minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 (Bin max2 maxV2 l2 r2) + | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin max2 maxV2 l1 (unionDisjointR maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin max2 maxV2 (unionDisjointL minV2 min1 n1 min2 l2) r2 | otherwise = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) -unionDisjointR1 :: a -> Key -> Node R a -> Key -> Node R a -> Node R a -unionDisjointR1 _ !_ !_ !_ Tip = error "Data.IntMap.unionDisjoint: impossible" -unionDisjointR1 maxV1 !max1 Tip !max2 n2@(Bin min2 minV2 l2 r2) +unionDisjointR :: a -> Key -> Node R a -> Key -> Node R a -> Node R a +unionDisjointR _ !_ !_ !_ Tip = error "Data.IntMap.unionDisjoint: impossible" +unionDisjointR maxV1 !max1 Tip !max2 n2@(Bin min2 minV2 l2 r2) | xor min2 max2 < xor min2 max1 = Bin max1 maxV1 Tip n2 | otherwise = Bin max1 maxV1 (insertMinL (xor min2 max1) min2 minV2 l2) r2 -unionDisjointR1 maxV1 !max1 (Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) - | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin min1 minV1 (unionDisjointL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin min1 minV1 l1 (unionDisjointR1 maxV1 max1 r1 max2 n2) +unionDisjointR maxV1 !max1 (Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) + | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin min1 minV1 (unionDisjointL minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin min1 minV1 l1 (unionDisjointR maxV1 max1 r1 max2 n2) | otherwise = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 -unionDisjointR2 :: a -> Key -> Node R a -> Key -> Node R a -> Node R a -unionDisjointR2 _ !_ Tip !_ !_ = error "Data.IntMap.unionDisjoint: impossible" -unionDisjointR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 Tip - | xor min1 max1 < xor min1 max2 = Bin max2 maxV2 Tip n1 - | otherwise = Bin max2 maxV2 (insertMinL (xor min1 max2) min1 minV1 l1) r1 -unionDisjointR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 (Bin min2 minV2 l2 r2) - | not (xor min1 max1 `ltMSB` xor min2 max1) = Bin min2 minV2 (unionDisjointL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | not (xor min2 max2 `ltMSB` xor min2 max1) = Bin min2 minV2 l2 (unionDisjointR2 maxV2 max1 n1 max2 r2) - | otherwise = Bin min2 minV2 (Bin max2 maxV2 l2 r2) n1 - -- | The union of a list of maps. -- -- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index eef4e8b3a..a06b87b03 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -618,7 +618,7 @@ unionWithKey combine = start goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL1 minV1 min1 n1 min2 n2 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL minV1 min2 n2 min1 n1 goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 @@ -632,7 +632,7 @@ unionWithKey combine = start goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL2 minV2 min1 n1 min2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL minV2 min1 n1 min2 n2 goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 @@ -657,7 +657,7 @@ unionWithKey combine = start goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR1 maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR maxV1 max1 n1 max2 n2 goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 @@ -671,7 +671,7 @@ unionWithKey combine = start goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR2 maxV2 max1 n1 max2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR maxV2 max2 n2 max1 n1 goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 2c2a709ca..f91ebc755 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -279,7 +279,7 @@ merge miss1 miss2 match = start where Empty -> missingLeft miss2 n2 NonEmpty min1' minV1' n1' -> case missingLeft miss2 n2 of Tip -> insertMinL (xor min1' min2) min1' minV1' n1' - n2'@(Bin _ _ _ _) -> unionDisjointL1 minV1' min1' n1' min2 n2' + n2'@(Bin _ _ _ _) -> unionDisjointL minV1' min2 n2' min1' n1' goL1Keep minV1 !min1 Tip !min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 goL1Keep minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min1 min2 < xor min1 max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missingRight miss2 r2) @@ -334,7 +334,7 @@ merge miss1 miss2 match = start where Empty -> missingLeft miss1 n1 NonEmpty min2' minV2' n2' -> case missingLeft miss1 n1 of Tip -> insertMinL (xor min1 min2') min2' minV2' n2' - n1'@(Bin _ _ _ _) -> unionDisjointL2 minV2' min1 n1' min2' n2' + n1'@(Bin _ _ _ _) -> unionDisjointL minV2' min1 n1' min2' n2' goL2Keep minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 goL2Keep minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 min2 < xor min2 max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missingRight miss1 r1) @@ -414,7 +414,7 @@ merge miss1 miss2 match = start where Empty -> missingRight miss2 n2 NonEmpty max1' maxV1' n1' -> case missingRight miss2 n2 of Tip -> insertMaxR (xor max1' max2) max1' maxV1' n1' - n2'@(Bin _ _ _ _) -> unionDisjointR1 maxV1' max1' n1' max2 n2' + n2'@(Bin _ _ _ _) -> unionDisjointR maxV1' max1' n1' max2 n2' goR1Keep maxV1 !max1 Tip !max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 goR1Keep maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 max1 > xor max1 max2 -> binR2 min2 minV2 (missingLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) @@ -469,7 +469,7 @@ merge miss1 miss2 match = start where Empty -> missingRight miss1 n1 NonEmpty max2' maxV2' n2' -> case missingRight miss1 n1 of Tip -> insertMaxR (xor max1 max2') max2' maxV2' n2' - n1'@(Bin _ _ _ _) -> unionDisjointR2 maxV2' max1 n1' max2' n2' + n1'@(Bin _ _ _ _) -> unionDisjointR maxV2' max2' n2' max1 n1' goR2Keep maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 goR2Keep maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 max2 > xor max2 max1 -> binR1 min1 minV1 (missingLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 85c038f2e..24eab39f2 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -643,7 +643,7 @@ unionWithKey combine = start goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL1 minV1 min1 n1 min2 n2 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL minV1 min2 n2 min1 n1 goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 @@ -657,7 +657,7 @@ unionWithKey combine = start goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL2 minV2 min1 n1 min2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL minV2 min1 n1 min2 n2 goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 @@ -682,7 +682,7 @@ unionWithKey combine = start goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR1 maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR maxV1 max1 n1 max2 n2 goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 @@ -696,7 +696,7 @@ unionWithKey combine = start goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR2 maxV2 max1 n1 max2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR maxV2 max2 n2 max1 n1 goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 From b873f297eb87ea2b54e0a472f4bf40bdb356ad94 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 20 Sep 2016 09:57:22 -0500 Subject: [PATCH 025/147] Add comments explaining the merging process in Data.IntMap.Merge.Internal --- containers/src/Data/IntMap/Merge/Internal.hs | 66 +++++++++++++++++++- 1 file changed, 65 insertions(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index f91ebc755..1e2576941 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -266,24 +266,66 @@ merge miss1 miss2 match = start where Nothing -> IntMap (goLFused min1 root1 root2) Just minV' -> IntMap (NonEmpty min1 minV' (goLFusedKeep min1 root1 root2)) - -- Merge two left nodes and a minimum value for the first node into a new left node + -- The merge code is structured as 12 very repetitive methods that merge nodes and a value associated with + -- the bound of one of those nodes. These vary on 3 axes: + -- + -- * The functions ending in L take and produce left nodes/maps, while those ending in R take and produce right nodes/maps + -- * The functions ending with a 1 have the first argument "inside" the second, i.e., the L1 functions assume that min1 > min2 + -- and take minV1 and the R1 functions assume that max1 < max2 and take maxV1. The functions ending with a 2 are symmetrical, + -- and the functions ending with Fused assume that the two maps are aligned: LFused assumes that min1 = min2 and RFused assumes that max1 = max2. + -- * The functions ending in Keep produce a Node, while the functions without Keep produce an IntMap_ + -- + -- See goL1Keep and goLFusedKeep for detailed description of the merging process. + + + -- | Merge two left nodes and a minimum value for the first node into a new left node -- Precondition: min1 > min2 -- goL1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c + + -- We special case merging two empty nodes because the last time I checked it was faster than falling through to the next case goL1Keep minV1 !min1 Tip !_ Tip = case missingSingle miss1 min1 minV1 of Nothing -> Tip Just minV' -> Bin min1 minV' Tip Tip + + -- If the second node is empty, then we basically need a copy of the first node. However, the presence of minV1 complicates things, + -- so we need to insert it goL1Keep minV1 !min1 n1 !min2 Tip = case missingSingle miss1 min1 minV1 of Nothing -> missingLeft miss1 n1 Just minV' -> insertMinL (xor min1 min2) min1 minV' (missingLeft miss1 n1) + + -- We handle the case of nodes that cover disjoint ranges separately. The property of being disjoint, unlike a lot of things, remains + -- constant as we recurse into subnodes, and this representation is particularly good at efficiently detecting it. By assumption, + -- min1 > min2, so we don't need to handle the case of min2 > max1. goL1Keep minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = case runIdentity (missingAll miss1 (NonEmpty min1 minV1 n1)) of Empty -> missingLeft miss2 n2 NonEmpty min1' minV1' n1' -> case missingLeft miss2 n2 of Tip -> insertMinL (xor min1' min2) min1' minV1' n1' n2'@(Bin _ _ _ _) -> unionDisjointL minV1' min2 n2' min1' n1' + + -- If the first node is empty, we still need to insert minV1 goL1Keep minV1 !min1 Tip !min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + + -- This is the meat of the method. Since we already know that the two nodes cover overlapping ranges, there are three possibilities: + -- * Node 2 splits first, so we need to merge n1 with either l2 or r2 + -- * Both nodes split at the same time, so we need to merge l1 with l2 and r1 with r2 + -- * Node 1 splits first, so we need to merge n2 with either l1 or r1 goL1Keep minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + -- Node 2 splits first. Knowing that min1 < min2 doesn't really help here, so our first job is to determine if we need + -- to merge n1 with l2 or with r2. We do this with the same navigational test used in, e.g., lookup, using an arbirary key + -- from node 1 (in this case we chose min1). If that key would be on the left side of node 2, then (since node 1 covers a smaller + -- binary range) the whole node 1 must fit in on the left side of node 2. + -- + -- In the specific case of merging n1 with l2, we don't have to do any more comparisons: we already know that min1 > min2, + -- so we should be calling an L1 function LT | xor min1 min2 < xor min1 max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missingRight miss2 r2) + -- At this point, we know that we need to merge n1 with r2. There are two things needed to do this: + -- * n1 needs to be converted to a right node to match r2. + -- * We need to compare max1 and max2 to figure out which will be the maximum of the combined node and to + -- decide which (R1, R2, or RFused) function to recurse to. | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + -- If we had an optimized goR2 (no keep), then calling using it is more efficient than + -- calling goR2Keep and having to extract a new maximum from the result. Therefore, we + -- first check if we can keep our existing maximum, and if not, call goR2. Nothing -> case goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' @@ -301,6 +343,10 @@ merge miss1 miss2 match = start where where {-# INLINE l' #-} l' = missingLeft miss2 l2 + + -- The two nodes split at the same time. In this case we need to merge l1 and l2 and r1 and r2. We already know that + -- min1 > min2, so merging the left nodes is easy, but we need to branch to figure out which right merging function to call + -- and which maximum to keep. EQ | max1 > max2 -> case missingSingle miss1 max1 maxV1 of Nothing -> case goR2 maxV2 max1 r1 max2 r2 of Empty -> l' @@ -319,8 +365,12 @@ merge miss1 miss2 match = start where where {-# INLINE l' #-} l' = goL1Keep minV1 min1 l1 min2 l2 + + -- The simplest case is when node 1 splits first, meaning that we need to merge n2 and l1 or r1. However, since we already know + -- that min1 > min2, n2 must be merged with l1 instead of r1, and we already know the correct method to call. GT -> binL1 max1 maxV1 (goL1Keep minV1 min1 l1 min2 n2) (missingRight miss1 r1) + -- Merge two left nodes and a minimum value for the second node into a new left node -- Precondition: min2 > min1 -- goL2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c @@ -376,9 +426,21 @@ merge miss1 miss2 match = start where l' = goL2Keep minV2 min1 l1 min2 l2 LT -> binL2 max2 maxV2 (goL2Keep minV2 min1 n1 min2 l2) (missingRight miss2 r2) + + -- | Merge two left nodes that share a minimum bound. + + -- We can special case the merging of two empty nodes. This is currently commented out in an attempt to + -- match union as closely as possible -- goLFusedKeep !_ Tip Tip = Tip + + -- If one of the nodes is empty, we can just use the other one. Unlike the case of misaligned nodes, we don't have an + -- extra value to insert goLFusedKeep !_ Tip n2 = missingLeft miss2 n2 goLFusedKeep !_ n1 Tip = missingLeft miss1 n1 + + -- Since the two nodes are joined at the left, the choices are considerable limited in comparison to the misaligned case. + -- If node 1 splits first, n2 must be merged with l1 and if node 2 splits first, n1 must be merged with l2. The equal case + -- is still the same as in the misaligned case, since we need to determine which maximum to use and which goR to call. goLFusedKeep !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of LT -> binL2 max2 maxV2 (goLFusedKeep min n1 l2) (missingRight miss2 r2) EQ | max1 > max2 -> case missingSingle miss1 max1 maxV1 of @@ -536,6 +598,8 @@ merge miss1 miss2 match = start where r' = goRFusedKeep max r1 r2 GT -> binR1 min1 minV1 (missingLeft miss1 l1) (goRFusedKeep max r1 n2) + -- TODO: These are inefficient, obviously correct implementations. See intersection + -- and difference for examples of specialized implementations goL1 minV1 !min1 !n1 !min2 !n2 = nodeToMapL (goL1Keep minV1 min1 n1 min2 n2) goL2 minV2 !min1 !n1 !min2 !n2 = nodeToMapL (goL2Keep minV2 min1 n1 min2 n2) goLFused !min !n1 !n2 = nodeToMapL (goLFusedKeep min n1 n2) From 5ac00bbd42183de76090d292b3c7f15e82d17503 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 2 Jan 2018 13:09:20 -0600 Subject: [PATCH 026/147] Add some comments explaining how insert works. --- containers/src/Data/IntMap/Internal.hs | 6 ++++++ containers/src/Data/IntMap/Lazy.hs | 12 ++++++++++++ 2 files changed, 18 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 07c3500f1..a5410f1b4 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1765,6 +1765,12 @@ r2lDR (DR max maxV (Bin min minV l r)) = DR min minV (Bin max maxV l r) insertMinL :: Word -> Key -> a -> Node L a -> Node L a insertMinL !_ !min minV Tip = Bin min minV Tip Tip insertMinL !xorCache !min minV (Bin max maxV l r) + -- Although the new minimum is not directly passed into 'insertMinL', + -- it is captured in the 'xorCache'. We use standard navigation to + -- determine whether 'min' should belong in the left or right branch. + -- Since 'min' is, by assumption, smaller than any key in the tree, + -- if 'min' is assigned to the right branch than the entire subtree + -- must fit in the right branch. Otherwise, we need to continue recursing. | xor min max < xorCache = Bin max maxV Tip (Bin min minV l r) | otherwise = Bin max maxV (insertMinL xorCache min minV l) r diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index a06b87b03..135057f95 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -269,11 +269,23 @@ insert = start | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) | otherwise = IntMap (NonEmpty k v root) + -- | Insert a key/value pair into a left node when the key is known to be larger + -- than the minimum value of the tree. goL !k v !_ !_ Tip = Bin k v Tip Tip goL !k v !xorCache !min (Bin max maxV l r) + -- In the simple case, we just recurse into whichever branch is applicable. | k < max = if xorCache < xorCacheMax then Bin max maxV (goL k v xorCache min l) r else Bin max maxV l (goR k v xorCacheMax max r) + -- If the key is the new maximum, then we have two cases to consider. If + -- the split point between 'min' and 'k' is earlier than the split between + -- 'min' and 'max', then we can just immediately create a new node. Otherwise, + -- we need to push 'max' down into the right branch until it arrives at the + -- correct location. + -- We do the this check by simulating a navigation where 'max' is the key, + -- 'min' is the minimum, and 'k' is the maximum. If 'max' belongs on the + -- left side, then the entire old subtree belongs on the left side. If + -- 'max' belongs on the right side, then we have to push it down. | k > max = if xor min max < xorCacheMax then Bin k v (Bin max maxV l r) Tip else Bin k v l (insertMaxR xorCacheMax max maxV r) From d77ab7944b7fb05d71d07cc7945445d2070fd037 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 3 Jan 2018 12:16:00 -0600 Subject: [PATCH 027/147] Adjust insertWith to not capture the combining function, recovering perfomance on GHC 8.2. Relative to IntMap on master: ``` insertWith empty -15.65% 2.54e-04 insertWith update -7.77% 1.16e-03 insertWith' empty -13.84% 2.56e-04 insertWith' update -14.07% 9.88e-04 insertWithKey empty -6.55% 2.54e-04 insertWithKey update +1.41% 1.16e-03 insertWithKey' empty -3.59% 2.54e-04 insertWithKey' update -11.86% 9.87e-04 ``` Relative to before this commit: ``` insertWith empty -33.10% 3.21e-04 insertWith update -2.58% 1.10e-03 insertWith' empty -33.95% 3.34e-04 insertWith' update -4.42% 8.88e-04 insertWithKey empty -28.77% 3.34e-04 insertWithKey update -3.56% 1.22e-03 insertWithKey' empty -28.57% 3.43e-04 insertWithKey' update -1.00% 8.79e-04 ``` --- containers/src/Data/IntMap/Lazy.hs | 24 +++++++++---------- containers/src/Data/IntMap/Strict/Internal.hs | 24 +++++++++---------- 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 135057f95..3bb1a9ea2 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -313,30 +313,30 @@ insert = start -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith combine = start +insertWith = start where - start !k v (IntMap Empty) = IntMap (NonEmpty k v Tip) - start !k v (IntMap (NonEmpty min minV root)) - | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) + start _ !k v (IntMap Empty) = IntMap (NonEmpty k v Tip) + start combine !k v (IntMap (NonEmpty min minV root)) + | k > min = IntMap (NonEmpty min minV (goL combine k v (xor min k) min root)) | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) | otherwise = IntMap (NonEmpty k (combine v minV) root) - goL !k v !_ !_ Tip = Bin k v Tip Tip - goL !k v !xorCache !min (Bin max maxV l r) + goL _ !k v !_ !_ Tip = Bin k v Tip Tip + goL combine !k v !xorCache !min (Bin max maxV l r) | k < max = if xorCache < xorCacheMax - then Bin max maxV (goL k v xorCache min l) r - else Bin max maxV l (goR k v xorCacheMax max r) + then Bin max maxV (goL combine k v xorCache min l) r + else Bin max maxV l (goR combine k v xorCacheMax max r) | k > max = if xor min max < xorCacheMax then Bin k v (Bin max maxV l r) Tip else Bin k v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max (combine v maxV) l r where xorCacheMax = xor k max - goR !k v !_ !_ Tip = Bin k v Tip Tip - goR !k v !xorCache !max (Bin min minV l r) + goR _ !k v !_ !_ Tip = Bin k v Tip Tip + goR combine !k v !xorCache !max (Bin min minV l r) | k > min = if xorCache < xorCacheMin - then Bin min minV l (goR k v xorCache max r) - else Bin min minV (goL k v xorCacheMin min l) r + then Bin min minV l (goR combine k v xorCache max r) + else Bin min minV (goL combine k v xorCacheMin min l) r | k < min = if xor min max < xorCacheMin then Bin k v Tip (Bin min minV l r) else Bin k v (insertMinL xorCacheMin min minV l) r diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 24eab39f2..b886c88fa 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -326,30 +326,30 @@ insert = start -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith combine = start +insertWith = start where - start !k v (IntMap Empty) = IntMap (NonEmpty k #! v # Tip) - start !k v (IntMap (NonEmpty min minV root)) - | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) + start _ !k v (IntMap Empty) = IntMap (NonEmpty k #! v # Tip) + start combine !k v (IntMap (NonEmpty min minV root)) + | k > min = IntMap (NonEmpty min minV (goL combine k v (xor min k) min root)) | k < min = IntMap (NonEmpty k #! v # insertMinL (xor min k) min minV root) | otherwise = IntMap (NonEmpty k #! combine v minV # root) - goL !k v !_ !_ Tip = Bin k #! v # Tip # Tip - goL !k v !xorCache !min (Bin max maxV l r) + goL _ !k v !_ !_ Tip = Bin k #! v # Tip # Tip + goL combine !k v !xorCache !min (Bin max maxV l r) | k < max = if xorCache < xorCacheMax - then Bin max maxV (goL k v xorCache min l) r - else Bin max maxV l (goR k v xorCacheMax max r) + then Bin max maxV (goL combine k v xorCache min l) r + else Bin max maxV l (goR combine k v xorCacheMax max r) | k > max = if xor min max < xorCacheMax then Bin k #! v # Bin max maxV l r # Tip else Bin k #! v # l # insertMaxR xorCacheMax max maxV r | otherwise = Bin max #! combine v maxV # l # r where xorCacheMax = xor k max - goR !k v !_ !_ Tip = Bin k #! v # Tip # Tip - goR !k v !xorCache !max (Bin min minV l r) + goR _ !k v !_ !_ Tip = Bin k #! v # Tip # Tip + goR combine !k v !xorCache !max (Bin min minV l r) | k > min = if xorCache < xorCacheMin - then Bin min minV l (goR k v xorCache max r) - else Bin min minV (goL k v xorCacheMin min l) r + then Bin min minV l (goR combine k v xorCache max r) + else Bin min minV (goL combine k v xorCacheMin min l) r | k < min = if xor min max < xorCacheMin then Bin k #! v # Tip # Bin min minV l r else Bin k #! v # insertMinL xorCacheMin min minV l # r From 69a0b208bab5e7a9ec49d72b31be6aacd63b5ef6 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 3 Jan 2018 14:44:15 -0600 Subject: [PATCH 028/147] Implement IntMap.!? --- containers/src/Data/IntMap/Internal.hs | 11 +++++++++++ containers/src/Data/IntMap/Lazy.hs | 1 + containers/src/Data/IntMap/Strict/Internal.hs | 1 + 3 files changed, 13 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index a5410f1b4..820d5c5fc 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -155,6 +155,17 @@ instance NFData a => NFData (Node t a) where (!) :: IntMap a -> Key -> a (!) m k = findWithDefault (error $ "IntMap.!: key " ++ show k ++ " is not an element of the map") k m + +-- | /O(min(n,W))/. Find the value at a key. +-- Returns 'Nothing' when the element can not be found. +-- +-- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing +-- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a' +-- +-- @since 0.5.11 +(!?) :: IntMap a -> Key -> Maybe a +(!?) m k = lookup k m + -- | Same as 'difference'. (\\) :: IntMap a -> IntMap b -> IntMap a (\\) = difference diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 3bb1a9ea2..8c162fd5b 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -63,6 +63,7 @@ module Data.IntMap.Lazy ( -- * Operators , (!) + , (!?) , (\\) -- * Query diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index b886c88fa..97327eee4 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -83,6 +83,7 @@ module Data.IntMap.Strict ( -- * Operators , (!) + , (!?) , (\\) -- * Query From 4ced1c4770954b9f65790fa133a37d70d7bec2d9 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 3 Jan 2018 14:50:02 -0600 Subject: [PATCH 029/147] Implement IntMap.lookup{Min,Max}. --- containers/src/Data/IntMap/Internal.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 820d5c5fc..86072a1d1 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1605,6 +1605,19 @@ submapCmp p = start combine EQ EQ = EQ combine _ _ = LT + +-- | /O(1)/. The minimal key of the map. Returns 'Nothing' if the map is empty. +lookupMin :: IntMap a -> Maybe (Key, a) +lookupMin (IntMap Empty) = Nothing +lookupMin (IntMap (NonEmpty min minV _)) = Just (min, minV) + +-- | /O(1)/. The maximal key of the map. Returns 'Nothing' if the map is empty. +lookupMax :: IntMap a -> Maybe (Key, a) +lookupMax (IntMap Empty) = Nothing +lookupMax (IntMap (NonEmpty min minV root)) = case root of + Tip -> Just (min, minV) + Bin max maxV _ _ -> Just (max, maxV) + -- | /O(1)/. The minimal key of the map. findMin :: IntMap a -> (Key, a) findMin (IntMap Empty) = error "findMin: empty map has no minimal element" From e8e894114cd70406b7ebea6a0b7d936fdc7bc4e4 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 3 Jan 2018 18:48:28 -0600 Subject: [PATCH 030/147] Revert "Add an incredibly hacky way to improve the worst-case performance of intersection" This reverts commit 2c3404ad21baa055301353b629a89261fcdec0e6. --- containers/src/Data/IntMap/Internal.hs | 144 ++++++++++--------------- 1 file changed, 58 insertions(+), 86 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 86072a1d1..8e67c0054 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -773,50 +773,50 @@ intersection = start start (IntMap Empty) !_ = IntMap Empty start !_ (IntMap Empty) = IntMap Empty start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 _ root2)) - | min1 < min2 = IntMap (fromSketchy (goL2 min1 root1 min2 root2)) - | min1 > min2 = IntMap (fromSketchy (goL1 minV1 min1 root1 min2 root2)) + | min1 < min2 = IntMap (goL2 min1 root1 min2 root2) + | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) | otherwise = IntMap (NonEmpty min1 minV1 (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. - goL1 _ !_ !_ !_ Tip = toSketchy Empty + goL1 _ !_ !_ !_ Tip = Empty goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 - goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = toSketchy Empty + goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lSketchyMap $ goR2 max1 (Bin min1 minV1 l1 r1) max2 r2 - | max1 < max2 -> r2lSketchyMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> toSketchy $ r2lMap $ NonEmpty max1 maxV1 (goRFused max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> sketchyBinL (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> sketchyBinL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case fromSketchy (goL1 minV1 min1 l1 min2 l2) of - Empty -> toSketchy $ r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) - NonEmpty min' minV' l' -> toSketchy (NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2))) + | max1 > max2 -> r2lMap $ goR2 max1 (Bin min1 minV1 l1 r1) max2 r2 + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2)) GT -> goL1 minV1 min1 l1 min2 n2 - goL2 !_ Tip !_ !_ = toSketchy Empty + goL2 !_ Tip !_ !_ = Empty goL2 min1 n1 min2 Tip = goLookupL2 min2 (xor min1 min2) n1 - goL2 _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = toSketchy Empty + goL2 _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT -> goL2 min1 n1 min2 l2 - EQ | max1 > max2 -> sketchyBinL (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> sketchyBinL (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case fromSketchy (goL2 min1 l1 min2 l2) of - Empty -> toSketchy (r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2))) - NonEmpty min' minV' l' -> toSketchy (NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2))) + EQ | max1 > max2 -> binL (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL2 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2)) GT | xor min1 min2 < xor min2 max1 -> goL2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> r2lSketchyMap $ goR2 max1 r1 max2 (Bin min2 dummyV l2 r2) - | max1 < max2 -> r2lSketchyMap $ goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) - | otherwise -> toSketchy $ r2lMap $ NonEmpty max1 maxV1 (goRFused max1 r1 (Bin min2 dummyV l2 r2)) + | max1 > max2 -> r2lMap $ goR2 max1 r1 max2 (Bin min2 dummyV l2 r2) + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 r1 (Bin min2 dummyV l2 r2)) goLFused !_ Tip !_ = Tip goLFused !_ !_ Tip = Tip goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of LT -> goLFused min n1 l2 - EQ | max1 > max2 -> case fromSketchy (goR2 max1 r1 max2 r2) of + EQ | max1 > max2 -> case goR2 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' - | max1 < max2 -> case fromSketchy (goR1 maxV1 max1 r1 max2 r2) of + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' | otherwise -> Bin max1 maxV1 l' (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 @@ -824,44 +824,44 @@ intersection = start l' = goLFused min l1 l2 GT -> goLFused min l1 n2 - goR1 _ !_ !_ !_ Tip = toSketchy Empty + goR1 _ !_ !_ !_ Tip = Empty goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 - goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = toSketchy Empty + goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rSketchyMap $ goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | min1 > min2 -> l2rSketchyMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> toSketchy $ l2rMap $ NonEmpty min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) - EQ | min1 < min2 -> sketchyBinR (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> sketchyBinR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case fromSketchy (goR1 maxV1 max1 r1 max2 r2) of - Empty -> toSketchy $ l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> toSketchy $ NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') + | min1 < min2 -> l2rMap $ goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> binR (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') GT -> goR1 maxV1 max1 r1 max2 n2 - goR2 !_ Tip !_ !_ = toSketchy Empty + goR2 !_ Tip !_ !_ = Empty goR2 max1 n1 max2 Tip = goLookupR2 max2 (xor max1 max2) n1 - goR2 _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = toSketchy Empty + goR2 _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT -> goR2 max1 n1 max2 r2 - EQ | min1 < min2 -> sketchyBinR (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | min1 > min2 -> sketchyBinR (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | otherwise -> case fromSketchy (goR2 max1 r1 max2 r2) of - Empty -> toSketchy $ l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> toSketchy $ NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') + EQ | min1 < min2 -> binR (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | otherwise -> case goR2 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') GT | xor min1 max2 > xor max2 max1 -> goR2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> l2rSketchyMap $ goL2 min1 l1 min2 (Bin max2 dummyV l2 r2) - | min1 > min2 -> l2rSketchyMap $ goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) - | otherwise -> toSketchy $ l2rMap $ NonEmpty min1 minV1 (goLFused min1 l1 (Bin max2 dummyV l2 r2)) + | min1 < min2 -> l2rMap $ goL2 min1 l1 min2 (Bin max2 dummyV l2 r2) + | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 l1 (Bin max2 dummyV l2 r2)) goRFused !_ Tip !_ = Tip goRFused !_ !_ Tip = Tip goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of LT -> goRFused max n1 r2 - EQ | min1 < min2 -> case fromSketchy (goL2 min1 l1 min2 l2) of + EQ | min1 < min2 -> case goL2 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' - | min1 > min2 -> case fromSketchy (goL1 minV1 min1 l1 min2 l2) of + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) r' -- we choose max1 arbitrarily, as max1 == max2 @@ -869,40 +869,40 @@ intersection = start r' = goRFused max r1 r2 GT -> goRFused max r1 n2 - goLookupL1 !_ _ !_ Tip = toSketchy Empty + goLookupL1 !_ _ !_ Tip = Empty goLookupL1 k v !xorCache (Bin max _ l r) | k < max = if xorCache < xorCacheMax then goLookupL1 k v xorCache l else goLookupR1 k v xorCacheMax r - | k > max = toSketchy Empty - | otherwise = toSketchy $ NonEmpty k v Tip + | k > max = Empty + | otherwise = NonEmpty k v Tip where xorCacheMax = xor k max - goLookupR1 !_ _ !_ Tip = toSketchy Empty + goLookupR1 !_ _ !_ Tip = Empty goLookupR1 k v !xorCache (Bin min _ l r) | k > min = if xorCache < xorCacheMin then goLookupR1 k v xorCache r else goLookupL1 k v xorCacheMin l - | k < min = toSketchy Empty - | otherwise = toSketchy $ NonEmpty k v Tip + | k < min = Empty + | otherwise = NonEmpty k v Tip where xorCacheMin = xor min k - goLookupL2 !_ !_ Tip = toSketchy Empty + goLookupL2 !_ !_ Tip = Empty goLookupL2 k !xorCache (Bin max maxV l r) | k < max = if xorCache < xorCacheMax then goLookupL2 k xorCache l else goLookupR2 k xorCacheMax r - | k > max = toSketchy Empty - | otherwise = toSketchy (NonEmpty k maxV Tip) + | k > max = Empty + | otherwise = NonEmpty k maxV Tip where xorCacheMax = xor k max - goLookupR2 !_ !_ Tip = toSketchy Empty + goLookupR2 !_ !_ Tip = Empty goLookupR2 k !xorCache (Bin min minV l r) | k > min = if xorCache < xorCacheMin then goLookupR2 k xorCache r else goLookupL2 k xorCacheMin l - | k < min = toSketchy Empty - | otherwise = toSketchy (NonEmpty k minV Tip) + | k < min = Empty + | otherwise = NonEmpty k minV Tip where xorCacheMin = xor min k dummyV = error "impossible" @@ -1874,31 +1874,3 @@ deleteR !k !xorCache n@(Bin min minV l r) | k < min = n | otherwise = extractBinR l r where xorCacheMin = xor min k - -data SketchyIntMap_ t a = SIM !Bool {-# UNPACK #-} !Key a !(Node t a) - -{-# INLINE fromSketchy #-} -fromSketchy :: SketchyIntMap_ t a -> IntMap_ t a -fromSketchy (SIM False _ _ _) = Empty -fromSketchy (SIM True k v root) = NonEmpty k v root - -{-# INLINE toSketchy #-} -toSketchy :: IntMap_ t a -> SketchyIntMap_ t a -toSketchy Empty = SIM False 0 (error "sketchyEmpty") Tip -toSketchy (NonEmpty k v root) = SIM True k v root - -{-# INLINE sketchyBinL #-} -sketchyBinL :: SketchyIntMap_ L a -> SketchyIntMap_ R a -> SketchyIntMap_ L a -sketchyBinL l r = toSketchy (binL (fromSketchy l) (fromSketchy r)) - -{-# INLINE sketchyBinR #-} -sketchyBinR :: SketchyIntMap_ L a -> SketchyIntMap_ R a -> SketchyIntMap_ R a -sketchyBinR l r = toSketchy (binR (fromSketchy l) (fromSketchy r)) - -{-# INLINE l2rSketchyMap #-} -l2rSketchyMap :: SketchyIntMap_ L a -> SketchyIntMap_ R a -l2rSketchyMap = toSketchy . l2rMap . fromSketchy - -{-# INLINE r2lSketchyMap #-} -r2lSketchyMap :: SketchyIntMap_ R a -> SketchyIntMap_ L a -r2lSketchyMap = toSketchy . r2lMap . fromSketchy From 819929f3cd71624150fc29ca94da6e929ea4d0d1 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 17 Dec 2019 11:53:32 -0600 Subject: [PATCH 031/147] Fix rebase errors --- .../benchmarks/LookupGE/LookupGE_IntMap.hs | 60 +- containers-tests/containers-tests.cabal | 2 +- containers-tests/tests/IntMapValidity.hs | 80 +- containers-tests/tests/intmap-properties.hs | 6 +- containers/containers.cabal | 2 +- containers/src/Data/IntMap/Internal.hs | 45 - containers/src/Data/IntMap/Internal/Debug.hs | 16 + containers/src/Data/IntMap/Lazy.hs | 27 +- containers/src/Data/IntMap/Strict.hs | 1377 +++++++++++++- containers/src/Data/IntMap/Strict/Internal.hs | 1593 ----------------- 10 files changed, 1382 insertions(+), 1826 deletions(-) delete mode 100644 containers/src/Data/IntMap/Strict/Internal.hs diff --git a/containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs b/containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs index ff849b1d2..a168c8cc3 100644 --- a/containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs +++ b/containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs @@ -10,63 +10,10 @@ lookupGE1 k m = (_,Just v,_) -> Just (k,v) (_,Nothing,r) -> findMinMaybe r -lookupGE2 :: Key -> IntMap a -> Maybe (Key,a) -lookupGE2 k t = case t of - Bin _ m l r | m < 0 -> if k >= 0 - then go l - else case go r of - Nothing -> Just $ findMin l - justx -> justx - _ -> go t - where - go (Bin p m l r) - | nomatch k p m = if k < p - then Just $ findMin l - else Nothing - | zero k m = case go l of - Nothing -> Just $ findMin r - justx -> justx - | otherwise = go r - go (Tip ky y) - | k > ky = Nothing - | otherwise = Just (ky, y) - go Nil = Nothing -lookupGE3 :: Key -> IntMap a -> Maybe (Key,a) -lookupGE3 k t = k `seq` case t of - Bin _ m l r | m < 0 -> if k >= 0 - then go Nothing l - else go (Just (findMin l)) r - _ -> go Nothing t - where - go def (Bin p m l r) - | nomatch k p m = if k < p then Just $ findMin l else def - | zero k m = go (Just $ findMin r) l - | otherwise = go def r - go def (Tip ky y) - | k > ky = def - | otherwise = Just (ky, y) - go def Nil = def - -lookupGE4 :: Key -> IntMap a -> Maybe (Key,a) -lookupGE4 k t = k `seq` case t of - Bin _ m l r | m < 0 -> if k >= 0 then go Nil l - else go l r - _ -> go Nil t - where - go def (Bin p m l r) - | nomatch k p m = if k < p then fMin l else fMin def - | zero k m = go r l - | otherwise = go def r - go def (Tip ky y) - | k > ky = fMin def - | otherwise = Just (ky, y) - go def Nil = fMin def - - fMin :: IntMap a -> Maybe (Key, a) - fMin Nil = Nothing - fMin (Tip ky y) = Just (ky, y) - fMin (Bin _ _ l _) = fMin l +lookupGE2 = lookupGE +lookupGE3 = lookupGE +lookupGE4 = lookupGE ------------------------------------------------------------------------------- -- Utilities @@ -92,3 +39,4 @@ prop_lookupGE13 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookup prop_lookupGE14 :: Int -> [Int] -> Bool prop_lookupGE14 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE4 x m #endif + diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index 5be41e070..2c7637112 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -55,10 +55,10 @@ library Data.IntMap.Internal Data.IntMap.Internal.Debug Data.IntMap.Lazy + Data.IntMap.Merge.Internal Data.IntMap.Merge.Lazy Data.IntMap.Merge.Strict Data.IntMap.Strict - Data.IntMap.Strict.Internal Data.IntSet Data.IntSet.Internal Data.Map diff --git a/containers-tests/tests/IntMapValidity.hs b/containers-tests/tests/IntMapValidity.hs index 9e92ba631..789da2340 100644 --- a/containers-tests/tests/IntMapValidity.hs +++ b/containers-tests/tests/IntMapValidity.hs @@ -1,6 +1,5 @@ module IntMapValidity (valid) where -import Data.Bits (xor, (.&.)) import Data.IntMap.Internal import Test.QuickCheck (Property, counterexample, property, (.&&.)) import Utils.Containers.Internal.BitUtil (bitcount) @@ -9,57 +8,30 @@ import Utils.Containers.Internal.BitUtil (bitcount) Assertions --------------------------------------------------------------------} -- | Returns true iff the internal structure of the IntMap is valid. -valid :: IntMap a -> Property -valid t = - counterexample "nilNeverChildOfBin" (nilNeverChildOfBin t) .&&. - counterexample "commonPrefix" (commonPrefix t) .&&. - counterexample "maskRespected" (maskRespected t) - --- Invariant: Nil is never found as a child of Bin. -nilNeverChildOfBin :: IntMap a -> Bool -nilNeverChildOfBin t = - case t of - Nil -> True - Tip _ _ -> True - Bin _ _ l r -> noNilInSet l && noNilInSet r +valid :: IntMap a -> Bool +valid = start where - noNilInSet t' = - case t' of - Nil -> False - Tip _ _ -> True - Bin _ _ l' r' -> noNilInSet l' && noNilInSet r' - --- Invariant: The Mask is a power of 2. It is the largest bit position at which --- two keys of the map differ. -maskPowerOfTwo :: IntMap a -> Bool -maskPowerOfTwo t = - case t of - Nil -> True - Tip _ _ -> True - Bin _ m l r -> - bitcount 0 (fromIntegral m) == 1 && maskPowerOfTwo l && maskPowerOfTwo r - --- Invariant: Prefix is the common high-order bits that all elements share to --- the left of the Mask bit. -commonPrefix :: IntMap a -> Bool -commonPrefix t = - case t of - Nil -> True - Tip _ _ -> True - b@(Bin p _ l r) -> all (sharedPrefix p) (keys b) && commonPrefix l && commonPrefix r - where - sharedPrefix :: Prefix -> Int -> Bool - sharedPrefix p a = p == p .&. a - --- Invariant: In Bin prefix mask left right, left consists of the elements that --- don't have the mask bit set; right is all the elements that do. -maskRespected :: IntMap a -> Bool -maskRespected t = - case t of - Nil -> True - Tip _ _ -> True - Bin _ binMask l r -> - all (\x -> zero x binMask) (keys l) && - all (\x -> not (zero x binMask)) (keys r) && - maskRespected l && - maskRespected r + start (IntMap Empty) = True + start (IntMap (NonEmpty min _ root)) = allKeys (> min) root && goL min root + + goL _ Tip = True + goL min (Bin max _ l r) = + allKeys (< max) l + && allKeys (< max) r + && allKeys (\k -> xor min k < xor k max) l + && allKeys (\k -> xor min k > xor k max) r + && goL min l + && goR max r + + goR _ Tip = True + goR max (Bin min _ l r) = + allKeys (> min) l + && allKeys (> min) r + && allKeys (\k -> xor min k < xor k max) l + && allKeys (\k -> xor min k > xor k max) r + && goL min l + && goR max r + + allKeys :: (Key -> Bool) -> Node t a -> Bool + allKeys _ Tip = True + allKeys p (Bin b _ l r) = p b && allKeys p l && allKeys p r diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index e3d5f80d3..43475b376 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -173,7 +173,6 @@ main = defaultMain , testProperty "lookupGT" prop_lookupGT , testProperty "lookupLE" prop_lookupLE , testProperty "lookupGE" prop_lookupGE - , testProperty "disjoint" prop_disjoint , testProperty "lookupMin" prop_lookupMin , testProperty "lookupMax" prop_lookupMax , testProperty "findMin" prop_findMin @@ -1136,7 +1135,7 @@ prop_valid = forValidUnitTree $ \t -> valid t -- QuickCheck ---------------------------------------------------------------- -prop_emptyValid :: Property +prop_emptyValid :: Bool prop_emptyValid = valid empty prop_singleton :: Int -> Int -> Property @@ -1215,9 +1214,6 @@ prop_intersectionWithKeyModel xs ys ys' = List.nubBy ((==) `on` fst) ys f k l r = k + 2 * l + 3 * r -prop_disjoint :: UMap -> UMap -> Property -prop_disjoint m1 m2 = disjoint m1 m2 === null (intersection m1 m2) - -- TODO: the second argument should be simply an 'IntSet', but that -- runs afoul of our orphan instance. prop_restrictKeys :: IMap -> IMap -> Property diff --git a/containers/containers.cabal b/containers/containers.cabal index 42c01385e..23cfbcdb6 100644 --- a/containers/containers.cabal +++ b/containers/containers.cabal @@ -43,9 +43,9 @@ Library Data.IntMap Data.IntMap.Lazy Data.IntMap.Strict - Data.IntMap.Strict.Internal Data.IntMap.Internal Data.IntMap.Internal.Debug + Data.IntMap.Merge.Internal Data.IntMap.Merge.Lazy Data.IntMap.Merge.Strict Data.IntSet.Internal diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 8e67c0054..6077e4de6 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1690,51 +1690,6 @@ maxViewWithKey (IntMap Empty) = Nothing maxViewWithKey m = let (k, a) = findMax m in Just ((k, a), delete k m) ----------------------------- - --- | Show the tree that implements the map. -showTree :: Show a => IntMap a -> String -showTree = unlines . aux where - aux (IntMap Empty) = [] - aux (IntMap (NonEmpty min minV node)) = (show min ++ " " ++ show minV) : auxNode False node - auxNode :: Show a => Bool -> Node t a -> [String] - auxNode _ Tip = ["+-."] - auxNode lined (Bin bound val l r) = ["+--" ++ show bound ++ " " ++ show val, prefix : " |"] ++ fmap indent (auxNode True l) ++ [prefix : " |"] ++ fmap indent (auxNode False r) - where - prefix = if lined then '|' else ' ' - indent line = prefix : " " ++ line - -showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String -showTreeWith _ _ = showTree - -valid :: IntMap a -> Bool -valid = start - where - start (IntMap Empty) = True - start (IntMap (NonEmpty min _ root)) = allKeys (> min) root && goL min root - - goL _ Tip = True - goL min (Bin max _ l r) = - allKeys (< max) l - && allKeys (< max) r - && allKeys (\k -> xor min k < xor k max) l - && allKeys (\k -> xor min k > xor k max) r - && goL min l - && goR max r - - goR _ Tip = True - goR max (Bin min _ l r) = - allKeys (> min) l - && allKeys (> min) r - && allKeys (\k -> xor min k < xor k max) l - && allKeys (\k -> xor min k > xor k max) r - && goL min l - && goR max r - - allKeys :: (Key -> Bool) -> Node t a -> Bool - allKeys _ Tip = True - allKeys p (Bin b _ l r) = p b && allKeys p l && allKeys p r - -- | /O(1)/. Returns whether the most significant bit of its first -- argument is less significant than the most significant bit of its -- second argument. diff --git a/containers/src/Data/IntMap/Internal/Debug.hs b/containers/src/Data/IntMap/Internal/Debug.hs index a30dc6968..c50e1313d 100644 --- a/containers/src/Data/IntMap/Internal/Debug.hs +++ b/containers/src/Data/IntMap/Internal/Debug.hs @@ -3,4 +3,20 @@ module Data.IntMap.Internal.Debug , showTreeWith ) where +import Prelude hiding (min, max) import Data.IntMap.Internal + +-- | Show the tree that implements the map. +showTree :: Show a => IntMap a -> String +showTree = unlines . aux where + aux (IntMap Empty) = [] + aux (IntMap (NonEmpty min minV node)) = (show min ++ " " ++ show minV) : auxNode False node + auxNode :: Show a => Bool -> Node t a -> [String] + auxNode _ Tip = ["+-."] + auxNode lined (Bin bound val l r) = ["+--" ++ show bound ++ " " ++ show val, prefix : " |"] ++ fmap indent (auxNode True l) ++ [prefix : " |"] ++ fmap indent (auxNode False r) + where + prefix = if lined then '|' else ' ' + indent line = prefix : " " ++ line + +showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String +showTreeWith _ _ = showTree diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 8c162fd5b..ef276c1b4 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -61,23 +61,6 @@ module Data.IntMap.Lazy ( -- * Map type IntMap, Key - -- * Operators - , (!) - , (!?) - , (\\) - - -- * Query - , null - , size - , member - , notMember - , lookup - , findWithDefault - , lookupLT - , lookupGT - , lookupLE - , lookupGE - -- * Construction , empty , singleton @@ -112,7 +95,7 @@ module Data.IntMap.Lazy ( -- * Query -- ** Lookup - , IM.lookup + , lookup , (!?) , (!) , findWithDefault @@ -124,7 +107,7 @@ module Data.IntMap.Lazy ( , lookupGE -- ** Size - , IM.null + , null , size -- * Combine @@ -225,12 +208,6 @@ module Data.IntMap.Lazy ( , maxView , minViewWithKey , maxViewWithKey - -#ifdef __GLASGOW_HASKELL__ - -- * Debugging - , showTree - , showTreeWith - , valid ) where import Data.IntMap.Internal diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index ef732c2e2..22eb7a358 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1,16 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, BangPatterns #-} +#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Safe #-} #endif -#include "containers.h" - ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Strict --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 +-- Copyright : Documentation & Interface (c) Daan Leijen 2002 +-- Documentation (c) Andriy Palamarchuk 2008 +-- Documentation & Implementation (c) Jonathan S. 2016 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable @@ -67,31 +65,21 @@ -- -- == Implementation -- --- The implementation is based on /big-endian patricia trees/. This data --- structure performs especially well on binary operations like 'union' and --- 'intersection'. Additionally, benchmarks show that it is also (much) faster --- on insertions and deletions when compared to a generic size-balanced map --- implementation (see "Data.Map"). --- --- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", --- Workshop on ML, September 1998, pages 77-86, --- --- --- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve --- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), --- October 1968, pages 514-534. +-- Operation comments contain the operation time complexity in +-- the Big-O notation . +-- Many operations have a worst-case complexity of /O(min(n,W))/. +-- This means that the operation can become linear in the number of +-- elements with a maximum of /W/ -- the number of bits in an 'Int' +-- (32 or 64). -- +-- Be aware that the 'Functor', 'Traversable' and 'Data' instances +-- are the same as for the "Data.IntMap.Lazy" module, so if they are used +-- on strict maps, the resulting maps will be lazy. ----------------------------------------------------------------------------- --- See the notes at the beginning of Data.IntMap.Internal. - module Data.IntMap.Strict ( -- * Map type -#if !defined(TESTING) - IntMap, Key -- instance Eq,Show -#else - IntMap(..), Key -- instance Eq,Show -#endif + IntMap, Key -- * Construction , empty @@ -143,7 +131,6 @@ module Data.IntMap.Strict ( , size -- * Combine - -- ** Union , union , unionWith @@ -162,10 +149,7 @@ module Data.IntMap.Strict ( , intersectionWith , intersectionWithKey - -- ** Disjoint - , disjoint - - -- ** Universal combining function + -- ** Deprecated, unsafe general combining function , mergeWithKey -- * Traversal @@ -202,7 +186,7 @@ module Data.IntMap.Strict ( -- ** Lists , toList --- ** Ordered lists + -- ** Ordered Lists , toAscList , toDescList @@ -213,19 +197,19 @@ module Data.IntMap.Strict ( , withoutKeys , partition , partitionWithKey - , mapMaybe , mapMaybeWithKey , mapEither , mapEitherWithKey - , split , splitLookup , splitRoot -- * Submap - , isSubmapOf, isSubmapOfBy - , isProperSubmapOf, isProperSubmapOfBy + , isSubmapOf + , isSubmapOfBy + , isProperSubmapOf + , isProperSubmapOfBy -- * Min\/Max , lookupMin @@ -244,13 +228,1314 @@ module Data.IntMap.Strict ( , maxView , minViewWithKey , maxViewWithKey +) where -#ifdef __GLASGOW_HASKELL__ - -- * Debugging - , showTree - , showTreeWith -#endif - ) where +import Data.IntMap.Internal +import qualified Data.IntMap.Merge.Strict as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) + +import Control.Applicative (Applicative(..)) +import Data.Functor ((<$>)) + +import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) + +import qualified Data.List (foldl', map) +import qualified Data.IntSet (IntSet, toList) + +import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) + +(#!), (#) :: (a -> b) -> a -> b +(#!) = ($!) +(#) = ($) + +-- | /O(1)/. A map of one element. +-- +-- > singleton 1 'a' == fromList [(1, 'a')] +-- > size (singleton 1 'a') == 1 +singleton :: Key -> a -> IntMap a +singleton k v = v `seq` IntMap (NonEmpty k v Tip) + +-- | /O(min(n,W))/. Insert a new key\/value pair in the map. +-- If the key is already present in the map, the associated value is +-- replaced with the supplied value, i.e. 'insert' is equivalent to +-- @'insertWith' 'const'@ +-- +-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] +-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] +-- > insert 5 'x' empty == singleton 5 'x' +insert :: Key -> a -> IntMap a -> IntMap a +insert = start + where + start !k !v (IntMap Empty) = IntMap (NonEmpty k v Tip) + start !k !v (IntMap (NonEmpty min minV root)) + | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) + | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) + | otherwise = IntMap (NonEmpty k v root) + + goL !k v !_ !_ Tip = Bin k v Tip Tip + goL !k v !xorCache !min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL k v xorCache min l) r + else Bin max maxV l (goR k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max v l r + where xorCacheMax = xor k max + + goR !k v !_ !_ Tip = Bin k v Tip Tip + goR !k v !xorCache !max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR k v xorCache max r) + else Bin min minV (goL k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min v l r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. Insert with a combining function. +-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert @f new_value old_value@. +-- +-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] +-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWith = start + where + start _ !k v (IntMap Empty) = IntMap (NonEmpty k #! v # Tip) + start combine !k v (IntMap (NonEmpty min minV root)) + | k > min = IntMap (NonEmpty min minV (goL combine k v (xor min k) min root)) + | k < min = IntMap (NonEmpty k #! v # insertMinL (xor min k) min minV root) + | otherwise = IntMap (NonEmpty k #! combine v minV # root) + + goL _ !k v !_ !_ Tip = Bin k #! v # Tip # Tip + goL combine !k v !xorCache !min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL combine k v xorCache min l) r + else Bin max maxV l (goR combine k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k #! v # Bin max maxV l r # Tip + else Bin k #! v # l # insertMaxR xorCacheMax max maxV r + | otherwise = Bin max #! combine v maxV # l # r + where xorCacheMax = xor k max + + goR _ !k v !_ !_ Tip = Bin k #! v # Tip # Tip + goR combine !k v !xorCache !max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR combine k v xorCache max r) + else Bin min minV (goL combine k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k #! v # Tip # Bin min minV l r + else Bin k #! v # insertMinL xorCacheMin min minV l # r + | otherwise = Bin min #! combine v minV # l # r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. Insert with a combining function. +-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert @f key new_value old_value@. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] +-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] +-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" +insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithKey f k = insertWith (f k) k + +-- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) +-- is a pair where the first element is equal to (@'lookup' k map@) +-- and the second element equal to (@'insertWithKey' f k x map@). +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) +-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) +-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") +-- +-- This is how to define @insertLookup@ using @insertLookupWithKey@: +-- +-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t +-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) +-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) +insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) +insertLookupWithKey combine !k v = toPair . start + where + start (IntMap Empty) = Nothing :*: IntMap (NonEmpty k #! v # Tip) + start (IntMap (NonEmpty min minV root)) + | k > min = let mv :*: root' = goL (xor min k) min root + in mv :*: IntMap (NonEmpty min minV root') + | k < min = Nothing :*: IntMap (NonEmpty k #! v # insertMinL (xor min k) min minV root) + | otherwise = Just minV :*: IntMap (NonEmpty k #! combine k v minV # root) + + goL !_ _ Tip = Nothing :*: (Bin k #! v # Tip # Tip) + goL !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then let mv :*: l' = goL xorCache min l + in mv :*: Bin max maxV l' r + else let mv :*: r' = goR xorCacheMax max r + in mv :*: Bin max maxV l r' + | k > max = if xor min max < xorCacheMax + then Nothing :*: (Bin k #! v # Bin max maxV l r # Tip) + else Nothing :*: (Bin k #! v # l # insertMaxR xorCacheMax max maxV r) + | otherwise = Just maxV :*: (Bin max #! combine k v maxV # l # r) + where xorCacheMax = xor k max + + goR !_ _ Tip = Nothing :*: (Bin k #! v # Tip # Tip) + goR !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then let mv :*: r' = goR xorCache max r + in mv :*: Bin min minV l r' + else let mv :*: l' = goL xorCacheMin min l + in mv :*: Bin min minV l' r + | k < min = if xor min max < xorCacheMin + then Nothing :*: (Bin k #! v # Tip # Bin min minV l r) + else Nothing :*: (Bin k #! v # insertMinL xorCacheMin min minV l # r) + | otherwise = Just minV :*: (Bin min #! combine k v minV # l # r) + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > adjust ("new " ++) 7 empty == empty +adjust :: (a -> a) -> Key -> IntMap a -> IntMap a +adjust f k = k `seq` start + where + start (IntMap Empty) = IntMap Empty + start m@(IntMap (NonEmpty min minV node)) + | k > min = IntMap (NonEmpty min minV (goL (xor min k) min node)) + | k < min = m + | otherwise = IntMap (NonEmpty min #! f minV # node) + + goL !_ _ Tip = Tip + goL !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL xorCache min l) r + else Bin max maxV l (goR xorCacheMax max r) + | k > max = n + | otherwise = Bin max #! f maxV # l # r + where xorCacheMax = xor k max + + goR !_ _ Tip = Tip + goR !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR xorCache max r) + else Bin min minV (goL xorCacheMin min l) r + | k < min = n + | otherwise = Bin min #! f minV # l # r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +-- +-- > let f key x = (show key) ++ ":new " ++ x +-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > adjustWithKey f 7 empty == empty +adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a +adjustWithKey f k = adjust (f k) k + +-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] +-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a +update f k = k `seq` start + where + start (IntMap Empty) = IntMap Empty + start m@(IntMap (NonEmpty min minV Tip)) + | k == min = case f minV of + Nothing -> IntMap Empty + Just !minV' -> IntMap (NonEmpty min minV' Tip) + | otherwise = m + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) + | k < min = m + | k == min = case f minV of + Nothing -> let DR min' minV' root' = deleteMinL max maxV l r + in IntMap (NonEmpty min' minV' root') + Just !minV' -> IntMap (NonEmpty min minV' root) + | otherwise = IntMap (NonEmpty min minV (goL (xor min k) min root)) + + goL !_ _ Tip = Tip + goL !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goL xorCache min l) r + else Bin max maxV l (goR xorCacheMax max r) + | k > max = n + | otherwise = case f maxV of + Nothing -> extractBinL l r + Just !maxV' -> Bin max maxV' l r + where xorCacheMax = xor k max + + goR !_ _ Tip = Tip + goR !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goR xorCache max r) + else Bin min minV (goL xorCacheMin min l) r + | k < min = n + | otherwise = case f minV of + Nothing -> extractBinR l r + Just !minV' -> Bin min minV' l r + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. The expression (@'updateWithKey' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] +-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a +updateWithKey f k = update (f k) k + +-- | /O(min(n,W))/. Lookup and update. +-- The function returns original value, if it is updated. +-- This is different behavior than 'Data.Map.updateLookupWithKey'. +-- Returns the original key value if the map entry is deleted. +-- +-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing +-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) +-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) +-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") +updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) +updateLookupWithKey f k = k `seq` start + where + start (IntMap Empty) = (Nothing, IntMap Empty) + start m@(IntMap (NonEmpty min minV Tip)) + | k == min = case f min minV of + Nothing -> (Just minV, IntMap Empty) + Just !minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) + | otherwise = (Nothing, m) + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) + | k < min = (Nothing, m) + | k == min = case f min minV of + Nothing -> let DR min' minV' root' = deleteMinL max maxV l r + in (Just minV, IntMap (NonEmpty min' minV' root')) + Just !minV' -> (Just minV, IntMap (NonEmpty min minV' root)) + | otherwise = let (mv, root') = goL (xor min k) min root + in (mv, IntMap (NonEmpty min minV root')) + + goL !_ _ Tip = (Nothing, Tip) + goL !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then let (mv, l') = goL xorCache min l + in (mv, Bin max maxV l' r) + else let (mv, r') = goR xorCacheMax max r + in (mv, Bin max maxV l r') + | k > max = (Nothing, n) + | otherwise = case f max maxV of + Nothing -> (Just maxV, extractBinL l r) + Just !maxV' -> (Just maxV, Bin max maxV' l r) + where xorCacheMax = xor k max + + goR !_ _ Tip = (Nothing, Tip) + goR !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then let (mv, r') = goR xorCache max r + in (mv, Bin min minV l r') + else let (mv, l') = goL xorCacheMin min l + in (mv, Bin min minV l' r) + | k < min = (Nothing, n) + | otherwise = case f min minV of + Nothing -> (Just minV, extractBinR l r) + Just !minV' -> (Just minV, Bin min minV' l r) + where xorCacheMin = xor min k + +-- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. +-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. +alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a +alter f k m = case lookup k m of + Nothing -> case f Nothing of + Nothing -> m + Just v -> insert k v m + Just v -> case f (Just v) of + Nothing -> delete k m + Just v' -> insert k v' m + +-- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at +-- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, +-- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f +-- ('lookup' k m)@. +-- +-- Example: +-- +-- @ +-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String) +-- interactiveAlter k m = alterF f k m where +-- f Nothing = do +-- putStrLn $ show k ++ +-- " was not found in the map. Would you like to add it?" +-- getUserResponse1 :: IO (Maybe String) +-- f (Just old) = do +-- putStrLn $ "The key is currently bound to " ++ show old ++ +-- ". Would you like to change or delete it?" +-- getUserResponse2 :: IO (Maybe String) +-- @ +-- +-- 'alterF' is the most general operation for working with an individual +-- key that may or may not be in a given map. +-- +-- Note: 'alterF' is a flipped version of the 'at' combinator from +-- 'Control.Lens.At'. +-- +-- @since 0.5.8 +alterF :: Functor f => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a) +alterF f k m = case lookup k m of + Nothing -> fmap (\ret -> case ret of + Nothing -> m + Just v -> insert k v m) (f Nothing) + Just v -> fmap (\ret -> case ret of + Nothing -> delete k m + Just v' -> insert k v' m) (f (Just v)) + +-- | /O(n+m)/. The union with a combining function. +-- +-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] +unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWith f = unionWithKey (const f) + +-- | /O(n+m)/. The union with a combining function. +-- +-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value +-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] +unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWithKey combine = start + where + start (IntMap Empty) m2 = m2 + start m1 (IntMap Empty) = m1 + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 minV2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) + | otherwise = IntMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + + goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip + goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL minV1 min2 n2 min1 n1 + goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL1 minV1 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 + + goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip + goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL minV2 min1 n1 min2 n2 + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l1 # goRFused max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL2 minV2 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 + + -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same + -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' + goLFused !_ Tip n2 = n2 + goLFused !_ n1 Tip = n1 + goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 + EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goLFused min l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 + + goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip + goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR1 maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) + + goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip + goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR maxV2 max2 n2 max1 n1 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR2 maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) + + -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same + -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' + goRFused !_ Tip n2 = n2 + goRFused !_ n1 Tip = n1 + goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> Bin min2 minV2 l2 (goRFused max n1 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goRFused max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 + GT -> Bin min1 minV1 l1 (goRFused max r1 n2) + + goInsertL1 k v !_ _ Tip = Bin k #! v # Tip # Tip + goInsertL1 k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goInsertL1 k v xorCache min l) r + else Bin max maxV l (goInsertR1 k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max #! combine k v maxV # l # r + where xorCacheMax = xor k max + + goInsertR1 k v !_ _ Tip = Bin k v Tip Tip + goInsertR1 k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goInsertR1 k v xorCache max r) + else Bin min minV (goInsertL1 k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min #! combine k v minV # l # r + where xorCacheMin = xor min k + + goInsertL2 k v !_ _ Tip = Bin k v Tip Tip + goInsertL2 k v !xorCache min (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then Bin max maxV (goInsertL2 k v xorCache min l) r + else Bin max maxV l (goInsertR2 k v xorCacheMax max r) + | k > max = if xor min max < xorCacheMax + then Bin k v (Bin max maxV l r) Tip + else Bin k v l (insertMaxR xorCacheMax max maxV r) + | otherwise = Bin max #! combine k maxV v # l # r + where xorCacheMax = xor k max + + goInsertR2 k v !_ _ Tip = Bin k v Tip Tip + goInsertR2 k v !xorCache max (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then Bin min minV l (goInsertR2 k v xorCache max r) + else Bin min minV (goInsertL2 k v xorCacheMin min l) r + | k < min = if xor min max < xorCacheMin + then Bin k v Tip (Bin min minV l r) + else Bin k v (insertMinL xorCacheMin min minV l) r + | otherwise = Bin min #! combine k minV v # l # r + where xorCacheMin = xor min k + +-- | The union of a list of maps, with a combining operation. +-- +-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] +-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] +unionsWith :: (a -> a -> a) -> [IntMap a] -> IntMap a +unionsWith f = Data.List.foldl' (unionWith f) empty + +-- | /O(n+m)/. Difference with a combining function. +-- +-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing +-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) +-- > == singleton 3 "b:B" +differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a +differenceWith f = differenceWithKey (const f) + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns 'Nothing', the element is discarded (proper set difference). +-- If it returns (@'Just' y@), the element is updated with a new value @y@. +-- +-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing +-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) +-- > == singleton 3 "3:b|B" +differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a +differenceWithKey combine = start + where + start (IntMap Empty) !_ = IntMap Empty + start !m (IntMap Empty) = m + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + | otherwise = case combine min1 minV1 minV2 of + Nothing -> IntMap (goLFused min1 root1 root2) + Just !minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep min1 root1 root2)) + + goL1 minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 + Just !maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) + | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) + Just !maxV1' -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) + GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) + + goL2 !_ Tip !_ !_ = Tip + goL2 min1 n1 min2 Tip = deleteL min2 (xor min1 min2) n1 + goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = n1 + goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goL2 min1 n1 min2 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> goL2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> case goRFused max1 r1 r2 of + Empty -> goL2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + Just !maxV1' -> Bin max1 maxV1' (goL2 min1 l1 min2 l2) (goRFusedKeep max1 r1 r2) + GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of + Empty -> l1 + NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of + Empty -> l1 + NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' + Just !maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep max1 r1 (Bin min2 dummyV l2 r2)) + + goLFused min = loop + where + loop Tip !_ = Empty + loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of + DR min' minV' n' -> NonEmpty min' minV' n' + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) + | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + Just !maxV1' -> binL (loop l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) + GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) + + goLFusedKeep min = loop + where + loop n1 Tip = n1 + loop Tip !_ = Tip + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (loop l1 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | otherwise -> case combine max1 maxV1 maxV2 of + Nothing -> case goRFused max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + Just !maxV1' -> Bin max1 maxV1' (loop l1 l2) (goRFusedKeep max1 r1 r2) + GT -> Bin max1 maxV1 (loop l1 n2) r1 + + goR1 maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) + | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 + Just !minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) + Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (goR1 maxV1 max1 r1 max2 r2) + GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) + + goR2 !_ Tip !_ !_ = Tip + goR2 max1 n1 max2 Tip = deleteR max2 (xor max1 max2) n1 + goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = n1 + goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goR2 max1 n1 max2 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> goR2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> case goLFused min1 l1 l2 of + Empty -> goR2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (goR2 max1 r1 max2 r2) + GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 + | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of + Empty -> r1 + NonEmpty min' minV' l' -> Bin min' minV' l' r1 + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of + Empty -> r1 + NonEmpty min' minV' l' -> Bin min' minV' l' r1 + Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 (Bin max2 dummyV l2 r2)) r1 + + goRFused max = loop + where + loop Tip !_ = Empty + loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of + DR max' maxV' n' -> NonEmpty max' maxV' n' + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) + | otherwise -> case combine min1 minV1 minV2 of + Nothing -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (loop r1 r2) + GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) + + goRFusedKeep max = loop + where + loop n1 Tip = n1 + loop Tip !_ = Tip + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (loop r1 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | otherwise -> case combine min1 minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + Nothing -> case goLFused min1 l1 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (loop r1 r2) + GT -> Bin min1 minV1 l1 (loop r1 n2) + + goLookupL k v !_ Tip = NonEmpty k v Tip + goLookupL k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL k v xorCache l + else goLookupR k v xorCacheMax r + | k > max = NonEmpty k v Tip + | otherwise = case combine k v maxV of + Nothing -> Empty + Just !v' -> NonEmpty k v' Tip + where xorCacheMax = xor k max + + goLookupR k v !_ Tip = NonEmpty k v Tip + goLookupR k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR k v xorCache r + else goLookupL k v xorCacheMin l + | k < min = NonEmpty k v Tip + | otherwise = case combine k v minV of + Nothing -> Empty + Just !v' -> NonEmpty k v' Tip + where xorCacheMin = xor min k + + dummyV = error "impossible" + +-- | /O(n+m)/. The intersection with a combining function. +-- +-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" +intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c +intersectionWith f = intersectionWithKey (const f) + +-- | /O(n+m)/. The intersection with a combining function. +-- +-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar +-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" +intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c +intersectionWithKey combine = start + where + start (IntMap Empty) !_ = IntMap Empty + start !_ (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (goL2 minV2 min1 root1 min2 root2) + | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + | otherwise = IntMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + + -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. + + goL1 _ !_ !_ !_ Tip = Empty + goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 + goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> r2lMap $ NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 + EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine max1 maxV1 maxV2 # l' # goRFused max1 r1 r2) + GT -> goL1 minV1 min1 l1 min2 n2 -import Data.IntMap.Strict.Internal -import Prelude () + goL2 _ !_ Tip !_ !_ = Empty + goL2 minV2 min1 n1 min2 Tip = goLookupL2 min2 minV2 (xor min1 min2) n1 + goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty + goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goL2 minV2 min1 n1 min2 l2 + EQ | max1 > max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goL2 minV2 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine max1 maxV1 maxV2 # l' # goRFused max1 r1 r2) + GT | xor min1 min2 < xor min2 max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> r2lMap $ goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) + | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 (Bin min2 minV2 l2 r2) + + goLFused min = loop + where + loop Tip !_ = Tip + loop !_ Tip = Tip + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> loop n1 l2 + EQ | max1 > max2 -> case goR2 maxV2 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> loop l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' + | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # loop l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> loop l1 n2 + + goR1 _ !_ !_ !_ Tip = Empty + goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 + goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> l2rMap $ NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 + EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # r') + GT -> goR1 maxV1 max1 r1 max2 n2 + + goR2 _ !_ Tip !_ !_ = Empty + goR2 maxV2 max1 n1 max2 Tip = goLookupR2 max2 maxV2 (xor max1 max2) n1 + goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty + goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT -> goR2 maxV2 max1 n1 max2 r2 + EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> case goR2 maxV2 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # r') + GT | xor min1 max2 > xor max2 max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> l2rMap $ goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) + + goRFused max = loop + where + loop Tip !_ = Tip + loop !_ Tip = Tip + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> loop n1 r2 + EQ | min1 < min2 -> case goL2 minV2 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of + Empty -> loop r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) + | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # loop r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> loop r1 n2 + + goLookupL1 !_ _ !_ Tip = Empty + goLookupL1 k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL1 k v xorCache l + else goLookupR1 k v xorCacheMax r + | k > max = Empty + | otherwise = NonEmpty k #! combine k v maxV # Tip + where xorCacheMax = xor k max + + goLookupR1 !_ _ !_ Tip = Empty + goLookupR1 k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR1 k v xorCache r + else goLookupL1 k v xorCacheMin l + | k < min = Empty + | otherwise = NonEmpty k #! combine k v minV # Tip + where xorCacheMin = xor min k + + goLookupL2 !_ _ !_ Tip = Empty + goLookupL2 k v !xorCache (Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then goLookupL2 k v xorCache l + else goLookupR2 k v xorCacheMax r + | k > max = Empty + | otherwise = NonEmpty k #! combine k maxV v # Tip + where xorCacheMax = xor k max + + goLookupR2 !_ _ !_ Tip = Empty + goLookupR2 k v !xorCache (Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then goLookupR2 k v xorCache r + else goLookupL2 k v xorCacheMin l + | k < min = Empty + | otherwise = NonEmpty k #! combine k minV v # Tip + where xorCacheMin = xor min k + +-- | /O(n+m)/. An unsafe general combining function. +-- +-- WARNING: This function can produce corrupt maps and its results +-- may depend on the internal structures of its inputs. Users should +-- prefer 'merge' or 'mergeA'. This function is also significantly slower +-- than 'merge'. +-- +-- When 'mergeWithKey' is given three arguments, it is inlined to the call +-- site. You should therefore use 'mergeWithKey' only to define custom +-- combining functions. For example, you could define 'unionWithKey', +-- 'differenceWithKey' and 'intersectionWithKey' as +-- +-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 +-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 +-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 +-- +-- When calling @'mergeWithKey' combine only1 only2@, a function combining two +-- 'IntMap's is created, such that +-- +-- * if a key is present in both maps, it is passed with both corresponding +-- values to the @combine@ function. Depending on the result, the key is either +-- present in the result with specified value, or is left out; +-- +-- * a nonempty subtree present only in the first map is passed to @only1@ and +-- the output is added to the result; +-- +-- * a nonempty subtree present only in the second map is passed to @only2@ and +-- the output is added to the result. +-- +-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. +-- The values can be modified arbitrarily. Most common variants of @only1@ and +-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@, +-- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@. +mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) -> IntMap a -> IntMap b -> IntMap c +mergeWithKey matched miss1 miss2 = Merge.merge (Merge.mapMaybeMissing (single miss1)) (Merge.mapMaybeMissing (single miss2)) (Merge.zipWithMaybeMatched matched) where + single miss k v = case miss (IntMap (NonEmpty k v Tip)) of + IntMap Empty -> Nothing + IntMap (NonEmpty _ v' _) -> Just v' + +-- | /O(n)/. Map a function over all values in the map. +-- +-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] +map :: (a -> b) -> IntMap a -> IntMap b +map f = start + where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f minV # goL root) + + goL Tip = Tip + goL (Bin k v l r) = Bin k #! f v # goL l # goR r + + goR Tip = Tip + goR (Bin k v l r) = Bin k #! f v # goL l # goR r + +-- | /O(n)/. Map a function over all values in the map. +-- +-- > let f key x = (show key) ++ ":" ++ x +-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] +mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b +mapWithKey f = start + where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # goL root) + + goL Tip = Tip + goL (Bin k v l r) = Bin k #! f k v # goL l # goR r + + goR Tip = Tip + goR (Bin k v l r) = Bin k #! f k v # goL l # goR r + + +-- | /O(n)/. +-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ +-- That is, behaves exactly like a regular 'traverse' except that the traversing +-- function also has access to the key associated with a value. +-- +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) +-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) +traverseWithKey f = start + where + start (IntMap Empty) = pure (IntMap Empty) + start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f min minV <*> goL root + + goL Tip = pure Tip + goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max #! maxV' # l' # r') <$> goL l <*> goR r <*> f max maxV + + goR Tip = pure Tip + goR (Bin min minV l r) = (\minV' l' r' -> Bin min #! minV' # l' # r') <$> f min minV <*> goL l <*> goR r + +-- | /O(n)/. The function @'mapAccum'@ threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a b = (a ++ b, b ++ "X") +-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) +mapAccum :: (a -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) +mapAccum f = mapAccumWithKey (\a _ x -> f a x) + +-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") +-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) +mapAccumWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) +mapAccumWithKey f = start + where + start a (IntMap Empty) = (a, IntMap Empty) + start a (IntMap (NonEmpty min minV root)) = + let (a', !minV') = f a min minV + (a'', root') = goL root a' + in (a'', IntMap (NonEmpty min minV' root')) + + goL Tip a = (a, Tip) + goL (Bin max maxV l r) a = + let (a', l') = goL l a + (a'', r') = goR r a' + (a''', !maxV') = f a'' max maxV + in (a''', Bin max maxV' l' r') + + goR Tip a = (a, Tip) + goR (Bin min minV l r) a = + let (a', !minV') = f a min minV + (a'', l') = goL l a' + (a''', r') = goR r a'' + in (a''', Bin min minV' l' r') + +-- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating +-- argument through the map in descending order of keys. +mapAccumRWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) +mapAccumRWithKey f = start + where + start a (IntMap Empty) = (a, IntMap Empty) + start a (IntMap (NonEmpty min minV root)) = + let (a', root') = goL root a + (a'', !minV') = f a' min minV + in (a'', IntMap (NonEmpty min minV' root')) + + goL Tip a = (a, Tip) + goL (Bin max maxV l r) a = + let (a', !maxV') = f a max maxV + (a'', r') = goR r a' + (a''', l') = goL l a'' + in (a''', Bin max maxV' l' r') + + goR Tip a = (a, Tip) + goR (Bin min minV l r) a = + let (a', r') = goR r a + (a'', l') = goL l a' + (a''', !minV') = f a'' min minV + in (a''', Bin min minV' l' r') + +-- | /O(n*min(n,W))/. +-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the value at the greatest of the +-- original keys is retained. +-- +-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] +-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" +-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" +mapKeys :: (Key -> Key) -> IntMap a -> IntMap a +mapKeys f = foldlWithKey' (\m k a -> insert (f k) a m) empty + +-- | /O(n*min(n,W))/. +-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the associated values will be +-- combined using @c@. +-- +-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" +-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" +mapKeysWith :: (a -> a -> a) -> (Key -> Key) -> IntMap a -> IntMap a +mapKeysWith combine f = foldlWithKey' (\m k a -> insertWith combine (f k) a m) empty + +-- | /O(n*min(n,W))/. +-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ +-- is strictly monotonic. +-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. +-- /The precondition is not checked./ +-- Semi-formally, we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s +-- > where ls = keys s +-- +-- This means that @f@ maps distinct original keys to distinct resulting keys. +-- This function has slightly better performance than 'mapKeys'. +-- +-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] +mapKeysMonotonic :: (Key -> Key) -> IntMap a -> IntMap a +mapKeysMonotonic = mapKeys + +-- | /O(n)/. Build a map from a set of keys and a function which for each key +-- computes its value. +-- +-- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] +-- > fromSet undefined Data.IntSet.empty == empty +fromSet :: (Key -> a) -> Data.IntSet.IntSet -> IntMap a +fromSet f = fromDistinctAscList . Data.List.map (\k -> (k, f k)) . Data.IntSet.toList + +-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. +fromList :: [(Key, a)] -> IntMap a +fromList = Data.List.foldl' (\t (k, a) -> insert k a t) empty + +-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +-- +-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] +-- > fromListWith (++) [] == empty +fromListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a +fromListWith f = Data.List.foldl' (\t (k, a) -> insertWith f k a t) empty + +-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] +-- > fromListWithKey f [] == empty +fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a +fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty + +-- TODO: Use the ordering + +-- | /O(n)/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order. +-- +-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] +fromAscList :: [(Key, a)] -> IntMap a +fromAscList = start where + start [] = IntMap Empty + start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + + go !k v [] !stk = completeBuildStack k v Tip stk + go !k v ((!next, nextV) : rest) !stk + | next == k = nextV `seq` go k nextV rest stk + | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k next) k v Tip stk) + +-- | /O(n)/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order. +-- +-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] +fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a +fromAscListWith f = fromAscListWithKey (const f) + +-- | /O(n)/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order, with a combining function on equal keys. +-- /The precondition (input list is ascending) is not checked./ +-- +-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value +-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] +fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a +fromAscListWithKey f = start where + start [] = IntMap Empty + start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + + go !k v [] !stk = completeBuildStack k v Tip stk + go !k v ((!next, nextV) : rest) !stk + | next == k = let !v' = f k nextV v in go k v' rest stk + | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k next) k v Tip stk) + +-- | /O(n)/. Build a map from a list of key\/value pairs where +-- the keys are in ascending order and all distinct. +-- /The precondition (input list is strictly ascending) is not checked./ +-- +-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] +fromDistinctAscList :: [(Key, a)] -> IntMap a +fromDistinctAscList = start where + start [] = IntMap Empty + start ((!min, !minV) : rest) = IntMap (go min minV rest StackBase) + + go !k !v [] !stk = completeBuildStack k v Tip stk + go !k !v ((!next, !nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) + +-- | /O(n)/. Map values and collect the 'Just' results. +-- +-- > let f x = if x == "a" then Just "new a" else Nothing +-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" +mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b +mapMaybe f = mapMaybeWithKey (const f) + +-- | /O(n)/. Map keys\/values and collect the 'Just' results. +-- +-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing +-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" +mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b +mapMaybeWithKey f = start + where + start (IntMap Empty) = IntMap Empty + start (IntMap (NonEmpty min minV root)) = case f min minV of + Just !minV' -> IntMap (NonEmpty min minV' (goL root)) + Nothing -> IntMap (goDeleteL root) + + goL Tip = Tip + goL (Bin max maxV l r) = case f max maxV of + Just !maxV' -> Bin max maxV' (goL l) (goR r) + Nothing -> case goDeleteR r of + Empty -> goL l + NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' + + goR Tip = Tip + goR (Bin min minV l r) = case f min minV of + Just !minV' -> Bin min minV' (goL l) (goR r) + Nothing -> case goDeleteL l of + Empty -> goR r + NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) + + goDeleteL Tip = Empty + goDeleteL (Bin max maxV l r) = case f max maxV of + Just !maxV' -> case goDeleteL l of + Empty -> case goR r of + Tip -> NonEmpty max maxV' Tip + Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) + NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR r)) + Nothing -> binL (goDeleteL l) (goDeleteR r) + + goDeleteR Tip = Empty + goDeleteR (Bin min minV l r) = case f min minV of + Just !minV' -> case goDeleteR r of + Empty -> case goL l of + Tip -> NonEmpty min minV' Tip + Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) + NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL l) r') + Nothing -> binR (goDeleteL l) (goDeleteR r) + +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- +-- > let f a = if a < "c" then Left a else Right a +-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) +-- > +-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) +mapEither f = mapEitherWithKey (const f) + +-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +-- +-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) +-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) +-- > +-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) +-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) +mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) +mapEitherWithKey func = start + where + start (IntMap Empty) = (IntMap Empty, IntMap Empty) + start (IntMap (NonEmpty min minV root)) = case func min minV of + Left !v -> let t :*: f = goTrueL root + in (IntMap (NonEmpty min v t), IntMap f) + Right !v -> let t :*: f = goFalseL root + in (IntMap t, IntMap (NonEmpty min v f)) + + goTrueL Tip = Tip :*: Empty + goTrueL (Bin max maxV l r) = case func max maxV of + Left !v -> let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin max v tl tr :*: binL fl fr + Right !v -> let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r + t = case tr of + Empty -> tl + NonEmpty max' maxV' r' -> Bin max' maxV' tl r' + f = case fl of + Empty -> r2lMap $ NonEmpty max v fr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' fr) + in t :*: f + + goTrueR Tip = Tip :*: Empty + goTrueR (Bin min minV l r) = case func min minV of + Left !v -> let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin min v tl tr :*: binR fl fr + Right !v -> let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r + t = case tl of + Empty -> tr + NonEmpty min' minV' l' -> Bin min' minV' l' tr + f = case fr of + Empty -> l2rMap $ NonEmpty min v fl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v fl r') + in t :*: f + + goFalseL Tip = Empty :*: Tip + goFalseL (Bin max maxV l r) = case func max maxV of + Left !v -> let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r + t = case tl of + Empty -> r2lMap $ NonEmpty max v tr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' tr) + f = case fr of + Empty -> fl + NonEmpty max' maxV' r' -> Bin max' maxV' fl r' + in t :*: f + Right !v -> let tl :*: fl = goFalseL l + tr :*: fr = goFalseR r + in binL tl tr :*: Bin max v fl fr + + goFalseR Tip = Empty :*: Tip + goFalseR (Bin min minV l r) = case func min minV of + Left !v -> let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r + t = case tr of + Empty -> l2rMap $ NonEmpty min v tl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v tl r') + f = case fl of + Empty -> fr + NonEmpty min' minV' l' -> Bin min' minV' l' fr + in t :*: f + Right !v -> let tl :*: fl = goFalseL l + tr :*: fr = goFalseR r + in binR tl tr :*: Bin min v fl fr + +-- | /O(min(n,W))/. Update the value at the minimal key. +-- +-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] +-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a +updateMin _ (IntMap Empty) = IntMap Empty +updateMin f m = update f (fst (findMin m)) m + +-- | /O(min(n,W))/. Update the value at the maximal key. +-- +-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] +-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a +updateMax _ (IntMap Empty) = IntMap Empty +updateMax f m = update f (fst (findMax m)) m + +-- | /O(min(n,W))/. Update the value at the minimal key. +-- +-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] +-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a +updateMinWithKey _ (IntMap Empty) = IntMap Empty +updateMinWithKey f m = updateWithKey f (fst (findMin m)) m + +-- | /O(min(n,W))/. Update the value at the maximal key. +-- +-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] +-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a +updateMaxWithKey _ (IntMap Empty) = IntMap Empty +updateMaxWithKey f m = updateWithKey f (fst (findMax m)) m diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs deleted file mode 100644 index 97327eee4..000000000 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ /dev/null @@ -1,1593 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 -{-# LANGUAGE Safe #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : Data.IntMap.Strict --- Copyright : Documentation & Interface (c) Daan Leijen 2002 --- Documentation (c) Andriy Palamarchuk 2008 --- Documentation & Implementation (c) Jonathan S. 2016 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Portability : portable --- --- --- = Finite Int Maps (strict interface) --- --- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary) --- from key of type @Int@ to values of type @v@. --- --- Each function in this module is careful to force values before installing --- them in an 'IntMap'. This is usually more efficient when laziness is not --- necessary. When laziness /is/ required, use the functions in --- "Data.IntMap.Lazy". --- --- In particular, the functions in this module obey the following law: --- --- - If all values stored in all maps in the arguments are in WHNF, then all --- values stored in all maps in the results will be in WHNF once those maps --- are evaluated. --- --- For a walkthrough of the most commonly used functions see the --- . --- --- This module is intended to be imported qualified, to avoid name clashes with --- Prelude functions: --- --- > import Data.IntMap.Strict (IntMap) --- > import qualified Data.IntMap.Strict as IntMap --- --- Note that the implementation is generally /left-biased/. Functions that take --- two maps as arguments and combine them, such as `union` and `intersection`, --- prefer the values in the first argument to those in the second. --- --- --- == Detailed performance information --- --- The amortized running time is given for each operation, with /n/ referring to --- the number of entries in the map and /W/ referring to the number of bits in --- an 'Int' (32 or 64). --- --- Benchmarks comparing "Data.IntMap.Strict" with other dictionary --- implementations can be found at https://github.com/haskell-perf/dictionaries. --- --- --- == Warning --- --- The 'IntMap' type is shared between the lazy and strict modules, meaning that --- the same 'IntMap' value can be passed to functions in both modules. This --- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are --- the same as for the "Data.IntMap.Lazy" module, so if they are used the --- resulting map may contain suspended values (thunks). --- --- --- == Implementation --- --- Operation comments contain the operation time complexity in --- the Big-O notation . --- Many operations have a worst-case complexity of /O(min(n,W))/. --- This means that the operation can become linear in the number of --- elements with a maximum of /W/ -- the number of bits in an 'Int' --- (32 or 64). --- --- Be aware that the 'Functor', 'Traversable' and 'Data' instances --- are the same as for the "Data.IntMap.Lazy" module, so if they are used --- on strict maps, the resulting maps will be lazy. ------------------------------------------------------------------------------ - -module Data.IntMap.Strict ( - -- * Map type - IntMap, Key - - -- * Operators - , (!) - , (!?) - , (\\) - - -- * Query - , null - , size - , member - , notMember - , lookup - , findWithDefault - , lookupLT - , lookupGT - , lookupLE - , lookupGE - - -- * Construction - , empty - , singleton - , fromSet - - -- ** From Unordered Lists - , fromList - , fromListWith - , fromListWithKey - - -- ** From Ascending Lists - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - - -- * Insertion - , insert - , insertWith - , insertWithKey - , insertLookupWithKey - - -- * Deletion\/Update - , delete - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - , alterF - - -- * Query - -- ** Lookup - , lookup - , (!?) - , (!) - , findWithDefault - , member - , notMember - , lookupLT - , lookupGT - , lookupLE - , lookupGE - - -- ** Size - , null - , size - - -- * Combine - -- ** Union - , union - , unionWith - , unionWithKey - , unions - , unionsWith - - -- ** Difference - , difference - , (\\) - , differenceWith - , differenceWithKey - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithKey - - -- ** Deprecated, unsafe general combining function - , mergeWithKey - - -- * Traversal - -- ** Map - , map - , mapWithKey - , traverseWithKey - , traverseMaybeWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeys - , mapKeysWith - , mapKeysMonotonic - - -- * Folds - , foldr - , foldl - , foldrWithKey - , foldlWithKey - , foldMapWithKey - - -- ** Strict folds - , foldr' - , foldl' - , foldrWithKey' - , foldlWithKey' - - -- * Conversion - , elems - , keys - , assocs - , keysSet - - -- ** Lists - , toList - - -- ** Ordered Lists - , toAscList - , toDescList - - -- * Filter - , filter - , filterWithKey - , restrictKeys - , withoutKeys - , partition - , partitionWithKey - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - , split - , splitLookup - , splitRoot - - -- * Submap - , isSubmapOf - , isSubmapOfBy - , isProperSubmapOf - , isProperSubmapOfBy - - -- * Min\/Max - , lookupMin - , lookupMax - , findMin - , findMax - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax - , updateMin - , updateMax - , updateMinWithKey - , updateMaxWithKey - , minView - , maxView - , minViewWithKey - , maxViewWithKey - -#ifdef __GLASGOW_HASKELL__ - -- * Debugging - , showTree - , showTreeWith - , valid -) where - -import Data.IntMap.Internal -import qualified Data.IntMap.Merge.Strict as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) - -import Control.Applicative (Applicative(..)) -import Data.Functor ((<$>)) - -import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) - -import qualified Data.List (foldl', map) -import qualified Data.IntSet (IntSet, toList) - -import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) - -(#!), (#) :: (a -> b) -> a -> b -(#!) = ($!) -(#) = ($) - --- | /O(1)/. A map of one element. --- --- > singleton 1 'a' == fromList [(1, 'a')] --- > size (singleton 1 'a') == 1 -singleton :: Key -> a -> IntMap a -singleton k v = v `seq` IntMap (NonEmpty k v Tip) - --- | /O(min(n,W))/. Insert a new key\/value pair in the map. --- If the key is already present in the map, the associated value is --- replaced with the supplied value, i.e. 'insert' is equivalent to --- @'insertWith' 'const'@ --- --- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] --- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] --- > insert 5 'x' empty == singleton 5 'x' -insert :: Key -> a -> IntMap a -> IntMap a -insert = start - where - start !k !v (IntMap Empty) = IntMap (NonEmpty k v Tip) - start !k !v (IntMap (NonEmpty min minV root)) - | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) - | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) - | otherwise = IntMap (NonEmpty k v root) - - goL !k v !_ !_ Tip = Bin k v Tip Tip - goL !k v !xorCache !min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then Bin max maxV (goL k v xorCache min l) r - else Bin max maxV l (goR k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max v l r - where xorCacheMax = xor k max - - goR !k v !_ !_ Tip = Bin k v Tip Tip - goR !k v !xorCache !max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then Bin min minV l (goR k v xorCache max r) - else Bin min minV (goL k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min v l r - where xorCacheMin = xor min k - --- | /O(min(n,W))/. Insert with a combining function. --- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert @f new_value old_value@. --- --- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] --- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] --- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" -insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith = start - where - start _ !k v (IntMap Empty) = IntMap (NonEmpty k #! v # Tip) - start combine !k v (IntMap (NonEmpty min minV root)) - | k > min = IntMap (NonEmpty min minV (goL combine k v (xor min k) min root)) - | k < min = IntMap (NonEmpty k #! v # insertMinL (xor min k) min minV root) - | otherwise = IntMap (NonEmpty k #! combine v minV # root) - - goL _ !k v !_ !_ Tip = Bin k #! v # Tip # Tip - goL combine !k v !xorCache !min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then Bin max maxV (goL combine k v xorCache min l) r - else Bin max maxV l (goR combine k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k #! v # Bin max maxV l r # Tip - else Bin k #! v # l # insertMaxR xorCacheMax max maxV r - | otherwise = Bin max #! combine v maxV # l # r - where xorCacheMax = xor k max - - goR _ !k v !_ !_ Tip = Bin k #! v # Tip # Tip - goR combine !k v !xorCache !max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then Bin min minV l (goR combine k v xorCache max r) - else Bin min minV (goL combine k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k #! v # Tip # Bin min minV l r - else Bin k #! v # insertMinL xorCacheMin min minV l # r - | otherwise = Bin min #! combine v minV # l # r - where xorCacheMin = xor min k - --- | /O(min(n,W))/. Insert with a combining function. --- @'insertWithKey' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert @f key new_value old_value@. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] --- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] --- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" -insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWithKey f k = insertWith (f k) k - --- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) --- is a pair where the first element is equal to (@'lookup' k map@) --- and the second element equal to (@'insertWithKey' f k x map@). --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) --- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) --- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") --- --- This is how to define @insertLookup@ using @insertLookupWithKey@: --- --- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t --- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) --- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) -insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) -insertLookupWithKey combine !k v = toPair . start - where - start (IntMap Empty) = Nothing :*: IntMap (NonEmpty k #! v # Tip) - start (IntMap (NonEmpty min minV root)) - | k > min = let mv :*: root' = goL (xor min k) min root - in mv :*: IntMap (NonEmpty min minV root') - | k < min = Nothing :*: IntMap (NonEmpty k #! v # insertMinL (xor min k) min minV root) - | otherwise = Just minV :*: IntMap (NonEmpty k #! combine k v minV # root) - - goL !_ _ Tip = Nothing :*: (Bin k #! v # Tip # Tip) - goL !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then let mv :*: l' = goL xorCache min l - in mv :*: Bin max maxV l' r - else let mv :*: r' = goR xorCacheMax max r - in mv :*: Bin max maxV l r' - | k > max = if xor min max < xorCacheMax - then Nothing :*: (Bin k #! v # Bin max maxV l r # Tip) - else Nothing :*: (Bin k #! v # l # insertMaxR xorCacheMax max maxV r) - | otherwise = Just maxV :*: (Bin max #! combine k v maxV # l # r) - where xorCacheMax = xor k max - - goR !_ _ Tip = Nothing :*: (Bin k #! v # Tip # Tip) - goR !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then let mv :*: r' = goR xorCache max r - in mv :*: Bin min minV l r' - else let mv :*: l' = goL xorCacheMin min l - in mv :*: Bin min minV l' r - | k < min = if xor min max < xorCacheMin - then Nothing :*: (Bin k #! v # Tip # Bin min minV l r) - else Nothing :*: (Bin k #! v # insertMinL xorCacheMin min minV l # r) - | otherwise = Just minV :*: (Bin min #! combine k v minV # l # r) - where xorCacheMin = xor min k - --- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. --- --- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] --- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > adjust ("new " ++) 7 empty == empty -adjust :: (a -> a) -> Key -> IntMap a -> IntMap a -adjust f k = k `seq` start - where - start (IntMap Empty) = IntMap Empty - start m@(IntMap (NonEmpty min minV node)) - | k > min = IntMap (NonEmpty min minV (goL (xor min k) min node)) - | k < min = m - | otherwise = IntMap (NonEmpty min #! f minV # node) - - goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then Bin max maxV (goL xorCache min l) r - else Bin max maxV l (goR xorCacheMax max r) - | k > max = n - | otherwise = Bin max #! f maxV # l # r - where xorCacheMax = xor k max - - goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then Bin min minV l (goR xorCache max r) - else Bin min minV (goL xorCacheMin min l) r - | k < min = n - | otherwise = Bin min #! f minV # l # r - where xorCacheMin = xor min k - --- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. --- --- > let f key x = (show key) ++ ":new " ++ x --- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] --- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > adjustWithKey f 7 empty == empty -adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a -adjustWithKey f k = adjust (f k) k - --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] --- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" -update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a -update f k = k `seq` start - where - start (IntMap Empty) = IntMap Empty - start m@(IntMap (NonEmpty min minV Tip)) - | k == min = case f minV of - Nothing -> IntMap Empty - Just !minV' -> IntMap (NonEmpty min minV' Tip) - | otherwise = m - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | k < min = m - | k == min = case f minV of - Nothing -> let DR min' minV' root' = deleteMinL max maxV l r - in IntMap (NonEmpty min' minV' root') - Just !minV' -> IntMap (NonEmpty min minV' root) - | otherwise = IntMap (NonEmpty min minV (goL (xor min k) min root)) - - goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then Bin max maxV (goL xorCache min l) r - else Bin max maxV l (goR xorCacheMax max r) - | k > max = n - | otherwise = case f maxV of - Nothing -> extractBinL l r - Just !maxV' -> Bin max maxV' l r - where xorCacheMax = xor k max - - goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then Bin min minV l (goR xorCache max r) - else Bin min minV (goL xorCacheMin min l) r - | k < min = n - | otherwise = case f minV of - Nothing -> extractBinR l r - Just !minV' -> Bin min minV' l r - where xorCacheMin = xor min k - --- | /O(min(n,W))/. The expression (@'updateWithKey' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] --- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] --- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" -updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a -updateWithKey f k = update (f k) k - --- | /O(min(n,W))/. Lookup and update. --- The function returns original value, if it is updated. --- This is different behavior than 'Data.Map.updateLookupWithKey'. --- Returns the original key value if the map entry is deleted. --- --- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing --- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) --- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) --- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") -updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) -updateLookupWithKey f k = k `seq` start - where - start (IntMap Empty) = (Nothing, IntMap Empty) - start m@(IntMap (NonEmpty min minV Tip)) - | k == min = case f min minV of - Nothing -> (Just minV, IntMap Empty) - Just !minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) - | otherwise = (Nothing, m) - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | k < min = (Nothing, m) - | k == min = case f min minV of - Nothing -> let DR min' minV' root' = deleteMinL max maxV l r - in (Just minV, IntMap (NonEmpty min' minV' root')) - Just !minV' -> (Just minV, IntMap (NonEmpty min minV' root)) - | otherwise = let (mv, root') = goL (xor min k) min root - in (mv, IntMap (NonEmpty min minV root')) - - goL !_ _ Tip = (Nothing, Tip) - goL !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then let (mv, l') = goL xorCache min l - in (mv, Bin max maxV l' r) - else let (mv, r') = goR xorCacheMax max r - in (mv, Bin max maxV l r') - | k > max = (Nothing, n) - | otherwise = case f max maxV of - Nothing -> (Just maxV, extractBinL l r) - Just !maxV' -> (Just maxV, Bin max maxV' l r) - where xorCacheMax = xor k max - - goR !_ _ Tip = (Nothing, Tip) - goR !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then let (mv, r') = goR xorCache max r - in (mv, Bin min minV l r') - else let (mv, l') = goL xorCacheMin min l - in (mv, Bin min minV l' r) - | k < min = (Nothing, n) - | otherwise = case f min minV of - Nothing -> (Just minV, extractBinR l r) - Just !minV' -> (Just minV, Bin min minV' l r) - where xorCacheMin = xor min k - --- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. --- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. --- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. -alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a -alter f k m = case lookup k m of - Nothing -> case f Nothing of - Nothing -> m - Just v -> insert k v m - Just v -> case f (Just v) of - Nothing -> delete k m - Just v' -> insert k v' m - --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at --- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, --- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f --- ('lookup' k m)@. --- --- Example: --- --- @ --- interactiveAlter :: Int -> IntMap String -> IO (IntMap String) --- interactiveAlter k m = alterF f k m where --- f Nothing = do --- putStrLn $ show k ++ --- " was not found in the map. Would you like to add it?" --- getUserResponse1 :: IO (Maybe String) --- f (Just old) = do --- putStrLn $ "The key is currently bound to " ++ show old ++ --- ". Would you like to change or delete it?" --- getUserResponse2 :: IO (Maybe String) --- @ --- --- 'alterF' is the most general operation for working with an individual --- key that may or may not be in a given map. --- --- Note: 'alterF' is a flipped version of the 'at' combinator from --- 'Control.Lens.At'. --- --- @since 0.5.8 -alterF :: Functor f => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a) -alterF f k m = case lookup k m of - Nothing -> fmap (\ret -> case ret of - Nothing -> m - Just v -> insert k v m) (f Nothing) - Just v -> fmap (\ret -> case ret of - Nothing -> delete k m - Just v' -> insert k v' m) (f (Just v)) - --- | /O(n+m)/. The union with a combining function. --- --- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] -unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWith f = unionWithKey (const f) - --- | /O(n+m)/. The union with a combining function. --- --- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value --- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] -unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWithKey combine = start - where - start (IntMap Empty) m2 = m2 - start m1 (IntMap Empty) = m1 - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 minV2 min1 root1 min2 root2)) - | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) - | otherwise = IntMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 - - goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip - goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL minV1 min2 n2 min1 n1 - goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 - goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 - | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL1 minV1 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - - goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip - goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL minV2 min1 n1 min2 n2 - goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 - goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 - | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l1 # goRFused max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL2 minV2 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 - - -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same - -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' - goLFused !_ Tip n2 = n2 - goLFused !_ n1 Tip = n1 - goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of - LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 - EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goLFused min l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - - goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip - goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR maxV1 max1 n1 max2 n2 - goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR1 maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 - GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - - goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip - goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR maxV2 max2 n2 max1 n1 - goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 - goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR2 maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 - LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) - - -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same - -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' - goRFused !_ Tip n2 = n2 - goRFused !_ n1 Tip = n1 - goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of - LT -> Bin min2 minV2 l2 (goRFused max n1 r2) - EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goRFused max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 - GT -> Bin min1 minV1 l1 (goRFused max r1 n2) - - goInsertL1 k v !_ _ Tip = Bin k #! v # Tip # Tip - goInsertL1 k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL1 k v xorCache min l) r - else Bin max maxV l (goInsertR1 k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max #! combine k v maxV # l # r - where xorCacheMax = xor k max - - goInsertR1 k v !_ _ Tip = Bin k v Tip Tip - goInsertR1 k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR1 k v xorCache max r) - else Bin min minV (goInsertL1 k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min #! combine k v minV # l # r - where xorCacheMin = xor min k - - goInsertL2 k v !_ _ Tip = Bin k v Tip Tip - goInsertL2 k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL2 k v xorCache min l) r - else Bin max maxV l (goInsertR2 k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max #! combine k maxV v # l # r - where xorCacheMax = xor k max - - goInsertR2 k v !_ _ Tip = Bin k v Tip Tip - goInsertR2 k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR2 k v xorCache max r) - else Bin min minV (goInsertL2 k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min #! combine k minV v # l # r - where xorCacheMin = xor min k - --- | The union of a list of maps, with a combining operation. --- --- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] --- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] -unionsWith :: (a -> a -> a) -> [IntMap a] -> IntMap a -unionsWith f = Data.List.foldl' (unionWith f) empty - --- | /O(n+m)/. Difference with a combining function. --- --- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing --- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) --- > == singleton 3 "b:B" -differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWith f = differenceWithKey (const f) - --- | /O(n+m)/. Difference with a combining function. When two equal keys are --- encountered, the combining function is applied to the key and both values. --- If it returns 'Nothing', the element is discarded (proper set difference). --- If it returns (@'Just' y@), the element is updated with a new value @y@. --- --- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing --- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) --- > == singleton 3 "3:b|B" -differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWithKey combine = start - where - start (IntMap Empty) !_ = IntMap Empty - start !m (IntMap Empty) = m - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 min1 root1 min2 root2)) - | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) - | otherwise = case combine min1 minV1 minV2 of - Nothing -> IntMap (goLFused min1 root1 root2) - Just !minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep min1 root1 root2)) - - goL1 minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 - goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> case combine max1 maxV1 maxV2 of - Nothing -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 - Just !maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) - | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine max1 maxV1 maxV2 of - Nothing -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) - Just !maxV1' -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) - GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) - - goL2 !_ Tip !_ !_ = Tip - goL2 min1 n1 min2 Tip = deleteL min2 (xor min1 min2) n1 - goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = n1 - goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT -> goL2 min1 n1 min2 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> goL2 min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' - | otherwise -> case combine max1 maxV1 maxV2 of - Nothing -> case goRFused max1 r1 r2 of - Empty -> goL2 min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' - Just !maxV1' -> Bin max1 maxV1' (goL2 min1 l1 min2 l2) (goRFusedKeep max1 r1 r2) - GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of - Empty -> l1 - NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - | otherwise -> case combine max1 maxV1 maxV2 of - Nothing -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of - Empty -> l1 - NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - Just !maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep max1 r1 (Bin min2 dummyV l2 r2)) - - goLFused min = loop - where - loop Tip !_ = Empty - loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of - DR min' minV' n' -> NonEmpty min' minV' n' - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) - | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine max1 maxV1 maxV2 of - Nothing -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - Just !maxV1' -> binL (loop l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) - GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) - - goLFusedKeep min = loop - where - loop n1 Tip = n1 - loop Tip !_ = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (loop l1 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> case combine max1 maxV1 maxV2 of - Nothing -> case goRFused max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - Just !maxV1' -> Bin max1 maxV1' (loop l1 l2) (goRFusedKeep max1 r1 r2) - GT -> Bin max1 maxV1 (loop l1 n2) r1 - - goR1 maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 - goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) - | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> case combine min1 minV1 minV2 of - Nothing -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 - Just !minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine min1 minV1 minV2 of - Nothing -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) - Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (goR1 maxV1 max1 r1 max2 r2) - GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) - - goR2 !_ Tip !_ !_ = Tip - goR2 max1 n1 max2 Tip = deleteR max2 (xor max1 max2) n1 - goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = n1 - goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT -> goR2 max1 n1 max2 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> goR2 max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) - | otherwise -> case combine min1 minV1 minV2 of - Nothing -> case goLFused min1 l1 l2 of - Empty -> goR2 max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) - Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (goR2 max1 r1 max2 r2) - GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 - | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of - Empty -> r1 - NonEmpty min' minV' l' -> Bin min' minV' l' r1 - | otherwise -> case combine min1 minV1 minV2 of - Nothing -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of - Empty -> r1 - NonEmpty min' minV' l' -> Bin min' minV' l' r1 - Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 (Bin max2 dummyV l2 r2)) r1 - - goRFused max = loop - where - loop Tip !_ = Empty - loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of - DR max' maxV' n' -> NonEmpty max' maxV' n' - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) - | otherwise -> case combine min1 minV1 minV2 of - Nothing -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 - Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (loop r1 r2) - GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) - - goRFusedKeep max = loop - where - loop n1 Tip = n1 - loop Tip !_ = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (loop r1 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> case combine min1 minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 - Nothing -> case goLFused min1 l1 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (loop r1 r2) - GT -> Bin min1 minV1 l1 (loop r1 n2) - - goLookupL k v !_ Tip = NonEmpty k v Tip - goLookupL k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then goLookupL k v xorCache l - else goLookupR k v xorCacheMax r - | k > max = NonEmpty k v Tip - | otherwise = case combine k v maxV of - Nothing -> Empty - Just !v' -> NonEmpty k v' Tip - where xorCacheMax = xor k max - - goLookupR k v !_ Tip = NonEmpty k v Tip - goLookupR k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then goLookupR k v xorCache r - else goLookupL k v xorCacheMin l - | k < min = NonEmpty k v Tip - | otherwise = case combine k v minV of - Nothing -> Empty - Just !v' -> NonEmpty k v' Tip - where xorCacheMin = xor min k - - dummyV = error "impossible" - --- | /O(n+m)/. The intersection with a combining function. --- --- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" -intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWith f = intersectionWithKey (const f) - --- | /O(n+m)/. The intersection with a combining function. --- --- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar --- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" -intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey combine = start - where - start (IntMap Empty) !_ = IntMap Empty - start !_ (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (goL2 minV2 min1 root1 min2 root2) - | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) - | otherwise = IntMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 - - -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. - - goL1 _ !_ !_ !_ Tip = Empty - goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 - goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lMap $ goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 - EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine max1 maxV1 maxV2 # l' # goRFused max1 r1 r2) - GT -> goL1 minV1 min1 l1 min2 n2 - - goL2 _ !_ Tip !_ !_ = Empty - goL2 minV2 min1 n1 min2 Tip = goLookupL2 min2 minV2 (xor min1 min2) n1 - goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty - goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT -> goL2 minV2 min1 n1 min2 l2 - EQ | max1 > max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine max1 maxV1 maxV2 # l' # goRFused max1 r1 r2) - GT | xor min1 min2 < xor min2 max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> r2lMap $ goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 (Bin min2 minV2 l2 r2) - - goLFused min = loop - where - loop Tip !_ = Tip - loop !_ Tip = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # loop l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT -> loop l1 n2 - - goR1 _ !_ !_ !_ Tip = Empty - goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 - goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rMap $ goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 - EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # r') - GT -> goR1 maxV1 max1 r1 max2 n2 - - goR2 _ !_ Tip !_ !_ = Empty - goR2 maxV2 max1 n1 max2 Tip = goLookupR2 max2 maxV2 (xor max1 max2) n1 - goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty - goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT -> goR2 maxV2 max1 n1 max2 r2 - EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # r') - GT | xor min1 max2 > xor max2 max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> l2rMap $ goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) - - goRFused max = loop - where - loop Tip !_ = Tip - loop !_ Tip = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # loop r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT -> loop r1 n2 - - goLookupL1 !_ _ !_ Tip = Empty - goLookupL1 k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then goLookupL1 k v xorCache l - else goLookupR1 k v xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k #! combine k v maxV # Tip - where xorCacheMax = xor k max - - goLookupR1 !_ _ !_ Tip = Empty - goLookupR1 k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then goLookupR1 k v xorCache r - else goLookupL1 k v xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k #! combine k v minV # Tip - where xorCacheMin = xor min k - - goLookupL2 !_ _ !_ Tip = Empty - goLookupL2 k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then goLookupL2 k v xorCache l - else goLookupR2 k v xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k #! combine k maxV v # Tip - where xorCacheMax = xor k max - - goLookupR2 !_ _ !_ Tip = Empty - goLookupR2 k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then goLookupR2 k v xorCache r - else goLookupL2 k v xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k #! combine k minV v # Tip - where xorCacheMin = xor min k - --- | /O(n+m)/. An unsafe general combining function. --- --- WARNING: This function can produce corrupt maps and its results --- may depend on the internal structures of its inputs. Users should --- prefer 'merge' or 'mergeA'. This function is also significantly slower --- than 'merge'. --- --- When 'mergeWithKey' is given three arguments, it is inlined to the call --- site. You should therefore use 'mergeWithKey' only to define custom --- combining functions. For example, you could define 'unionWithKey', --- 'differenceWithKey' and 'intersectionWithKey' as --- --- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 --- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 --- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 --- --- When calling @'mergeWithKey' combine only1 only2@, a function combining two --- 'IntMap's is created, such that --- --- * if a key is present in both maps, it is passed with both corresponding --- values to the @combine@ function. Depending on the result, the key is either --- present in the result with specified value, or is left out; --- --- * a nonempty subtree present only in the first map is passed to @only1@ and --- the output is added to the result; --- --- * a nonempty subtree present only in the second map is passed to @only2@ and --- the output is added to the result. --- --- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. --- The values can be modified arbitrarily. Most common variants of @only1@ and --- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@, --- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@. -mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) -> IntMap a -> IntMap b -> IntMap c -mergeWithKey matched miss1 miss2 = Merge.merge (Merge.mapMaybeMissing (single miss1)) (Merge.mapMaybeMissing (single miss2)) (Merge.zipWithMaybeMatched matched) where - single miss k v = case miss (IntMap (NonEmpty k v Tip)) of - IntMap Empty -> Nothing - IntMap (NonEmpty _ v' _) -> Just v' - --- | /O(n)/. Map a function over all values in the map. --- --- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] -map :: (a -> b) -> IntMap a -> IntMap b -map f = start - where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f minV # goL root) - - goL Tip = Tip - goL (Bin k v l r) = Bin k #! f v # goL l # goR r - - goR Tip = Tip - goR (Bin k v l r) = Bin k #! f v # goL l # goR r - --- | /O(n)/. Map a function over all values in the map. --- --- > let f key x = (show key) ++ ":" ++ x --- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] -mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b -mapWithKey f = start - where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # goL root) - - goL Tip = Tip - goL (Bin k v l r) = Bin k #! f k v # goL l # goR r - - goR Tip = Tip - goR (Bin k v l r) = Bin k #! f k v # goL l # goR r - - --- | /O(n)/. --- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ --- That is, behaves exactly like a regular 'traverse' except that the traversing --- function also has access to the key associated with a value. --- --- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) --- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing -traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) -traverseWithKey f = start - where - start (IntMap Empty) = pure (IntMap Empty) - start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f min minV <*> goL root - - goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max #! maxV' # l' # r') <$> goL l <*> goR r <*> f max maxV - - goR Tip = pure Tip - goR (Bin min minV l r) = (\minV' l' r' -> Bin min #! minV' # l' # r') <$> f min minV <*> goL l <*> goR r - --- | /O(n)/. --- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ --- That is, behaves exactly like a regular 'traverse' except that the traversing --- function also has access to the key associated with a value. --- --- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) --- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing -traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b) -traverseWithKey f = go - where - go Nil = pure Nil - go (Tip k v) = (\ !v' -> Tip k v') <$> f k v - go (Bin p m l r) - | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l) - | otherwise = liftA2 (Bin p m) (go l) (go r) -{-# INLINE traverseWithKey #-} - --- | /O(n)/. Traverse keys\/values and collect the 'Just' results. -traverseMaybeWithKey - :: Applicative f => (Key -> a -> f (Maybe b)) -> IntMap a -> f (IntMap b) -traverseMaybeWithKey f = go - where - go Nil = pure Nil - go (Tip k x) = maybe Nil (Tip k $!) <$> f k x - go (Bin p m l r) - | m < 0 = liftA2 (flip (bin p m)) (go r) (go l) - | otherwise = liftA2 (bin p m) (go l) (go r) - --- | /O(n)/. The function @'mapAccum'@ threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a b = (a ++ b, b ++ "X") --- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) -mapAccum :: (a -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) -mapAccum f = mapAccumWithKey (\a _ x -> f a x) - --- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") --- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) -mapAccumWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) -mapAccumWithKey f = start - where - start a (IntMap Empty) = (a, IntMap Empty) - start a (IntMap (NonEmpty min minV root)) = - let (a', !minV') = f a min minV - (a'', root') = goL root a' - in (a'', IntMap (NonEmpty min minV' root')) - - goL Tip a = (a, Tip) - goL (Bin max maxV l r) a = - let (a', l') = goL l a - (a'', r') = goR r a' - (a''', !maxV') = f a'' max maxV - in (a''', Bin max maxV' l' r') - - goR Tip a = (a, Tip) - goR (Bin min minV l r) a = - let (a', !minV') = f a min minV - (a'', l') = goL l a' - (a''', r') = goR r a'' - in (a''', Bin min minV' l' r') - --- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating --- argument through the map in descending order of keys. -mapAccumRWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) -mapAccumRWithKey f = start - where - start a (IntMap Empty) = (a, IntMap Empty) - start a (IntMap (NonEmpty min minV root)) = - let (a', root') = goL root a - (a'', !minV') = f a' min minV - in (a'', IntMap (NonEmpty min minV' root')) - - goL Tip a = (a, Tip) - goL (Bin max maxV l r) a = - let (a', !maxV') = f a max maxV - (a'', r') = goR r a' - (a''', l') = goL l a'' - in (a''', Bin max maxV' l' r') - - goR Tip a = (a, Tip) - goR (Bin min minV l r) a = - let (a', r') = goR r a - (a'', l') = goL l a' - (a''', !minV') = f a'' min minV - in (a''', Bin min minV' l' r') - --- | /O(n*min(n,W))/. --- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the value at the greatest of the --- original keys is retained. --- --- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] --- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" --- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" -mapKeys :: (Key -> Key) -> IntMap a -> IntMap a -mapKeys f = foldlWithKey' (\m k a -> insert (f k) a m) empty - --- | /O(n*min(n,W))/. --- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the associated values will be --- combined using @c@. --- --- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" --- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" -mapKeysWith :: (a -> a -> a) -> (Key -> Key) -> IntMap a -> IntMap a -mapKeysWith combine f = foldlWithKey' (\m k a -> insertWith combine (f k) a m) empty - --- | /O(n*min(n,W))/. --- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ --- is strictly monotonic. --- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. --- /The precondition is not checked./ --- Semi-formally, we have: --- --- > and [x < y ==> f x < f y | x <- ls, y <- ls] --- > ==> mapKeysMonotonic f s == mapKeys f s --- > where ls = keys s --- --- This means that @f@ maps distinct original keys to distinct resulting keys. --- This function has slightly better performance than 'mapKeys'. --- --- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] -mapKeysMonotonic :: (Key -> Key) -> IntMap a -> IntMap a -mapKeysMonotonic = mapKeys - --- | /O(n)/. Build a map from a set of keys and a function which for each key --- computes its value. --- --- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] --- > fromSet undefined Data.IntSet.empty == empty -fromSet :: (Key -> a) -> Data.IntSet.IntSet -> IntMap a -fromSet f = fromDistinctAscList . Data.List.map (\k -> (k, f k)) . Data.IntSet.toList - --- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. -fromList :: [(Key, a)] -> IntMap a -fromList = Data.List.foldl' (\t (k, a) -> insert k a t) empty - --- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. --- --- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] --- > fromListWith (++) [] == empty -fromListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a -fromListWith f = Data.List.foldl' (\t (k, a) -> insertWith f k a t) empty - --- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] --- > fromListWithKey f [] == empty -fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a -fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty - --- TODO: Use the ordering - --- | /O(n)/. Build a map from a list of key\/value pairs where --- the keys are in ascending order. --- --- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] --- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] -fromAscList :: [(Key, a)] -> IntMap a -fromAscList = start where - start [] = IntMap Empty - start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) - - go !k v [] !stk = completeBuildStack k v Tip stk - go !k v ((!next, nextV) : rest) !stk - | next == k = nextV `seq` go k nextV rest stk - | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k next) k v Tip stk) - --- | /O(n)/. Build a map from a list of key\/value pairs where --- the keys are in ascending order. --- --- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] --- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] -fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a -fromAscListWith f = fromAscListWithKey (const f) - --- | /O(n)/. Build a map from a list of key\/value pairs where --- the keys are in ascending order, with a combining function on equal keys. --- /The precondition (input list is ascending) is not checked./ --- --- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value --- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] -fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a -fromAscListWithKey f = start where - start [] = IntMap Empty - start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) - - go !k v [] !stk = completeBuildStack k v Tip stk - go !k v ((!next, nextV) : rest) !stk - | next == k = let !v' = f k nextV v in go k v' rest stk - | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k next) k v Tip stk) - --- | /O(n)/. Build a map from a list of key\/value pairs where --- the keys are in ascending order and all distinct. --- /The precondition (input list is strictly ascending) is not checked./ --- --- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -fromDistinctAscList :: [(Key, a)] -> IntMap a -fromDistinctAscList = start where - start [] = IntMap Empty - start ((!min, !minV) : rest) = IntMap (go min minV rest StackBase) - - go !k !v [] !stk = completeBuildStack k v Tip stk - go !k !v ((!next, !nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) - --- | /O(n)/. Map values and collect the 'Just' results. --- --- > let f x = if x == "a" then Just "new a" else Nothing --- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" -mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b -mapMaybe f = mapMaybeWithKey (const f) - --- | /O(n)/. Map keys\/values and collect the 'Just' results. --- --- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing --- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" -mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b -mapMaybeWithKey f = start - where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = case f min minV of - Just !minV' -> IntMap (NonEmpty min minV' (goL root)) - Nothing -> IntMap (goDeleteL root) - - goL Tip = Tip - goL (Bin max maxV l r) = case f max maxV of - Just !maxV' -> Bin max maxV' (goL l) (goR r) - Nothing -> case goDeleteR r of - Empty -> goL l - NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' - - goR Tip = Tip - goR (Bin min minV l r) = case f min minV of - Just !minV' -> Bin min minV' (goL l) (goR r) - Nothing -> case goDeleteL l of - Empty -> goR r - NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) - - goDeleteL Tip = Empty - goDeleteL (Bin max maxV l r) = case f max maxV of - Just !maxV' -> case goDeleteL l of - Empty -> case goR r of - Tip -> NonEmpty max maxV' Tip - Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) - NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR r)) - Nothing -> binL (goDeleteL l) (goDeleteR r) - - goDeleteR Tip = Empty - goDeleteR (Bin min minV l r) = case f min minV of - Just !minV' -> case goDeleteR r of - Empty -> case goL l of - Tip -> NonEmpty min minV' Tip - Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) - NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL l) r') - Nothing -> binR (goDeleteL l) (goDeleteR r) - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. --- --- > let f a = if a < "c" then Left a else Right a --- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) --- > --- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) -mapEither f = mapEitherWithKey (const f) - --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. --- --- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) --- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) --- > --- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) --- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) -mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) -mapEitherWithKey func = start - where - start (IntMap Empty) = (IntMap Empty, IntMap Empty) - start (IntMap (NonEmpty min minV root)) = case func min minV of - Left !v -> let t :*: f = goTrueL root - in (IntMap (NonEmpty min v t), IntMap f) - Right !v -> let t :*: f = goFalseL root - in (IntMap t, IntMap (NonEmpty min v f)) - - goTrueL Tip = Tip :*: Empty - goTrueL (Bin max maxV l r) = case func max maxV of - Left !v -> let tl :*: fl = goTrueL l - tr :*: fr = goTrueR r - in Bin max v tl tr :*: binL fl fr - Right !v -> let tl :*: fl = goTrueL l - tr :*: fr = goFalseR r - t = case tr of - Empty -> tl - NonEmpty max' maxV' r' -> Bin max' maxV' tl r' - f = case fl of - Empty -> r2lMap $ NonEmpty max v fr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' fr) - in t :*: f - - goTrueR Tip = Tip :*: Empty - goTrueR (Bin min minV l r) = case func min minV of - Left !v -> let tl :*: fl = goTrueL l - tr :*: fr = goTrueR r - in Bin min v tl tr :*: binR fl fr - Right !v -> let tl :*: fl = goFalseL l - tr :*: fr = goTrueR r - t = case tl of - Empty -> tr - NonEmpty min' minV' l' -> Bin min' minV' l' tr - f = case fr of - Empty -> l2rMap $ NonEmpty min v fl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v fl r') - in t :*: f - - goFalseL Tip = Empty :*: Tip - goFalseL (Bin max maxV l r) = case func max maxV of - Left !v -> let tl :*: fl = goFalseL l - tr :*: fr = goTrueR r - t = case tl of - Empty -> r2lMap $ NonEmpty max v tr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' tr) - f = case fr of - Empty -> fl - NonEmpty max' maxV' r' -> Bin max' maxV' fl r' - in t :*: f - Right !v -> let tl :*: fl = goFalseL l - tr :*: fr = goFalseR r - in binL tl tr :*: Bin max v fl fr - - goFalseR Tip = Empty :*: Tip - goFalseR (Bin min minV l r) = case func min minV of - Left !v -> let tl :*: fl = goTrueL l - tr :*: fr = goFalseR r - t = case tr of - Empty -> l2rMap $ NonEmpty min v tl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v tl r') - f = case fl of - Empty -> fr - NonEmpty min' minV' l' -> Bin min' minV' l' fr - in t :*: f - Right !v -> let tl :*: fl = goFalseL l - tr :*: fr = goFalseR r - in binR tl tr :*: Bin min v fl fr - --- | /O(min(n,W))/. Update the value at the minimal key. --- --- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] --- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" -updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMin _ (IntMap Empty) = IntMap Empty -updateMin f m = update f (fst (findMin m)) m - --- | /O(min(n,W))/. Update the value at the maximal key. --- --- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] --- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMax _ (IntMap Empty) = IntMap Empty -updateMax f m = update f (fst (findMax m)) m - --- | /O(min(n,W))/. Update the value at the minimal key. --- --- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] --- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" -updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a -updateMinWithKey _ (IntMap Empty) = IntMap Empty -updateMinWithKey f m = updateWithKey f (fst (findMin m)) m - --- | /O(min(n,W))/. Update the value at the maximal key. --- --- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] --- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" -updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a -updateMaxWithKey _ (IntMap Empty) = IntMap Empty -updateMaxWithKey f m = updateWithKey f (fst (findMax m)) m From cddead9825a192f684db1f9c02b854580c07a789 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 17 Dec 2019 13:25:33 -0600 Subject: [PATCH 032/147] Implement disjoint based on intersection --- containers-tests/tests/intmap-properties.hs | 4 ++ containers/src/Data/IntMap/Internal.hs | 68 +++++++++++++++++++++ containers/src/Data/IntMap/Lazy.hs | 3 + containers/src/Data/IntMap/Strict.hs | 3 + 4 files changed, 78 insertions(+) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 43475b376..1d2f2a5d9 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -173,6 +173,7 @@ main = defaultMain , testProperty "lookupGT" prop_lookupGT , testProperty "lookupLE" prop_lookupLE , testProperty "lookupGE" prop_lookupGE + , testProperty "disjoint" prop_disjoint , testProperty "lookupMin" prop_lookupMin , testProperty "lookupMax" prop_lookupMax , testProperty "findMin" prop_findMin @@ -1214,6 +1215,9 @@ prop_intersectionWithKeyModel xs ys ys' = List.nubBy ((==) `on` fst) ys f k l r = k + 2 * l + 3 * r +prop_disjoint :: UMap -> UMap -> Property +prop_disjoint m1 m2 = disjoint m1 m2 === null (intersection m1 m2) + -- TODO: the second argument should be simply an 'IntSet', but that -- runs afoul of our orphan instance. prop_restrictKeys :: IMap -> IMap -> Property diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 6077e4de6..045cd13f8 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -907,6 +907,74 @@ intersection = start dummyV = error "impossible" +-- | /O(n+m)/. Check whether the key sets of two maps are disjoint +-- (i.e. their 'intersection' is empty). +-- +-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True +-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False +-- > disjoint (fromList []) (fromList []) == True +-- +-- > disjoint a b == null (intersection a b) +-- +-- @since 0.6.2.1 +disjoint :: IntMap a -> IntMap b -> Bool +disjoint = start + where + start (IntMap Empty) !_ = True + start !_ (IntMap Empty) = True + start (IntMap (NonEmpty min1 _ root1)) (IntMap (NonEmpty min2 _ root2)) + | min1 < min2 = goL min2 root2 min1 root1 + | min1 > min2 = goL min1 root1 min2 root2 + | otherwise = False + + goL :: Key -> Node L x -> Key -> Node L y -> Bool + goL !_ !_ !_ Tip = True + goL min1 Tip min2 n2 = goLookupL min1 (xor min1 min2) n2 + goL min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = True + goL min1 n1@(Bin max1 _ l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 min1 < xor min1 max2 -> goL min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> goR max2 r2 max1 (Bin min1 dummyV l1 r1) + | max1 < max2 -> goR max1 (Bin min1 dummyV l1 r1) max2 r2 + | otherwise -> False + EQ | max1 > max2 -> goL min1 l1 min2 l2 && goR max2 r2 max1 r1 + | max1 < max2 -> goL min1 l1 min2 l2 && goR max1 r1 max2 r2 + | otherwise -> False + GT -> goL min1 l1 min2 n2 + + goR :: Key -> Node R x -> Key -> Node R y -> Bool + goR !_ !_ !_ Tip = True + goR max1 Tip max2 n2 = goLookupR max1 (xor max1 max2) n2 + goR max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = True + goR max1 n1@(Bin min1 _ l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> goR max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> goL min2 l2 min1 (Bin max1 dummyV l1 r1) + | min1 > min2 -> goL min1 (Bin max1 dummyV l1 r1) min2 l2 + | otherwise -> False + EQ | min1 < min2 -> goL min2 l2 min1 l1 && goR max1 r1 max2 r2 + | min1 > min2 -> goL min1 l1 min2 l2 && goR max1 r1 max2 r2 + | otherwise -> False + GT -> goR max1 r1 max2 n2 + + goLookupL !_ !_ Tip = True + goLookupL k !xorCache (Bin max _ l r) + | k < max = if xorCache < xorCacheMax + then goLookupL k xorCache l + else goLookupR k xorCacheMax r + | k > max = True + | otherwise = False + where xorCacheMax = xor k max + + goLookupR !_ !_ Tip = True + goLookupR k !xorCache (Bin min _ l r) + | k > min = if xorCache < xorCacheMin + then goLookupR k xorCache r + else goLookupL k xorCacheMin l + | k < min = True + | otherwise = False + where xorCacheMin = xor min k + + dummyV = error "impossible" + -- | /O(n)/. Fold the values in the map using the given right-associative -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. -- diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index ef276c1b4..57b20c0ab 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -129,6 +129,9 @@ module Data.IntMap.Lazy ( , intersectionWith , intersectionWithKey + -- ** Disjoint + , disjoint + -- ** Deprecated, unsafe general combining function , mergeWithKey diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 22eb7a358..fcd432181 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -149,6 +149,9 @@ module Data.IntMap.Strict ( , intersectionWith , intersectionWithKey + -- ** Disjoint + , disjoint + -- ** Deprecated, unsafe general combining function , mergeWithKey From f523b2c2953f8e3956d30d0ade3193695e9579b0 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 17 Dec 2019 14:36:38 -0600 Subject: [PATCH 033/147] Generalize IntMap.Merge.Internal.WhenMissing in preparation for mergeA --- containers/src/Data/IntMap/Merge/Internal.hs | 282 ++++++++++--------- containers/src/Data/IntMap/Merge/Lazy.hs | 4 +- containers/src/Data/IntMap/Merge/Strict.hs | 4 +- 3 files changed, 153 insertions(+), 137 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 1e2576941..6d839359d 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -77,9 +77,9 @@ instance Applicative Identity where -- A tactic of type @ WhenMissing f a c @ is an abstract representation -- of a function of type @ Key -> a -> f (Maybe c) @. data WhenMissing f a b = WhenMissing { - missingSingle :: Key -> a -> Maybe b, - missingLeft :: Node L a -> Node L b, - missingRight :: Node R a -> Node R b, + missingSingle :: Key -> a -> f (Maybe b), + missingLeft :: Node L a -> f (Node L b), + missingRight :: Node R a -> f (Node R b), missingAll :: IntMap_ L a -> f (IntMap_ L b) } @@ -102,7 +102,7 @@ type SimpleWhenMissing = WhenMissing Identity -- but @dropMissing@ is much faster. {-# INLINE dropMissing #-} dropMissing :: Applicative f => WhenMissing f a b -dropMissing = WhenMissing (\_ _ -> Nothing) (const Tip) (const Tip) (const (pure Empty)) +dropMissing = WhenMissing (const (const (pure Nothing))) (const (pure Tip)) (const (pure Tip)) (const (pure Empty)) -- | Preserve, unchanged, the entries whose keys are missing from -- the other map. @@ -116,7 +116,7 @@ dropMissing = WhenMissing (\_ _ -> Nothing) (const Tip) (const Tip) (const (pure -- but @preserveMissing@ is much faster. {-# INLINE preserveMissing #-} preserveMissing :: Applicative f => WhenMissing f a a -preserveMissing = WhenMissing (\_ v -> Just v) id id pure +preserveMissing = WhenMissing (\_ v -> pure (Just v)) pure pure pure -- | Filter the entries whose keys are missing from the other map. -- @@ -128,7 +128,7 @@ preserveMissing = WhenMissing (\_ v -> Just v) id id pure -- -- but this should be a little faster. filterMissing :: Applicative f => (Key -> a -> Bool) -> WhenMissing f a a -filterMissing p = WhenMissing (\k v -> if p k v then Just v else Nothing) goLKeep goRKeep (pure . start) where +filterMissing p = WhenMissing (\k v -> pure (if p k v then Just v else Nothing)) (pure . goLKeep) (pure . goRKeep) (pure . start) where start Empty = Empty start (NonEmpty min minV root) | p min minV = NonEmpty min minV (goLKeep root) @@ -253,16 +253,16 @@ type SimpleWhenMatched = WhenMatched Identity merge :: SimpleWhenMissing a c -> SimpleWhenMissing b c -> SimpleWhenMatched a b c -> IntMap a -> IntMap b -> IntMap c merge miss1 miss2 match = start where start (IntMap Empty) (IntMap Empty) = IntMap Empty - start (IntMap Empty) (IntMap !m2) = IntMap (runIdentity (missingAll miss2 m2)) - start (IntMap !m1) (IntMap Empty) = IntMap (runIdentity (missingAll miss1 m1)) + start (IntMap Empty) (IntMap !m2) = IntMap (missAll miss2 m2) + start (IntMap !m1) (IntMap Empty) = IntMap (missAll miss1 m1) start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = case missingSingle miss1 min1 minV1 of + | min1 < min2 = case missSingle miss1 min1 minV1 of Nothing -> IntMap (goL2 minV2 min1 root1 min2 root2) Just minV' -> IntMap (NonEmpty min1 minV' (goL2Keep minV2 min1 root1 min2 root2)) - | min1 > min2 = case missingSingle miss2 min2 minV2 of + | min1 > min2 = case missSingle miss2 min2 minV2 of Nothing -> IntMap (goL1 minV1 min1 root1 min2 root2) Just minV' -> IntMap (NonEmpty min2 minV' (goL1Keep minV1 min1 root1 min2 root2)) - | otherwise = case runIdentity (matchedSingle match min1 minV1 minV2) of + | otherwise = case matchSingle match min1 minV1 minV2 of Nothing -> IntMap (goLFused min1 root1 root2) Just minV' -> IntMap (NonEmpty min1 minV' (goLFusedKeep min1 root1 root2)) @@ -283,22 +283,22 @@ merge miss1 miss2 match = start where -- goL1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c -- We special case merging two empty nodes because the last time I checked it was faster than falling through to the next case - goL1Keep minV1 !min1 Tip !_ Tip = case missingSingle miss1 min1 minV1 of + goL1Keep minV1 !min1 Tip !_ Tip = case missSingle miss1 min1 minV1 of Nothing -> Tip Just minV' -> Bin min1 minV' Tip Tip -- If the second node is empty, then we basically need a copy of the first node. However, the presence of minV1 complicates things, -- so we need to insert it - goL1Keep minV1 !min1 n1 !min2 Tip = case missingSingle miss1 min1 minV1 of - Nothing -> missingLeft miss1 n1 - Just minV' -> insertMinL (xor min1 min2) min1 minV' (missingLeft miss1 n1) + goL1Keep minV1 !min1 n1 !min2 Tip = case missSingle miss1 min1 minV1 of + Nothing -> missLeft miss1 n1 + Just minV' -> insertMinL (xor min1 min2) min1 minV' (missLeft miss1 n1) -- We handle the case of nodes that cover disjoint ranges separately. The property of being disjoint, unlike a lot of things, remains -- constant as we recurse into subnodes, and this representation is particularly good at efficiently detecting it. By assumption, -- min1 > min2, so we don't need to handle the case of min2 > max1. - goL1Keep minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = case runIdentity (missingAll miss1 (NonEmpty min1 minV1 n1)) of - Empty -> missingLeft miss2 n2 - NonEmpty min1' minV1' n1' -> case missingLeft miss2 n2 of + goL1Keep minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = case missAll miss1 (NonEmpty min1 minV1 n1) of + Empty -> missLeft miss2 n2 + NonEmpty min1' minV1' n1' -> case missLeft miss2 n2 of Tip -> insertMinL (xor min1' min2) min1' minV1' n1' n2'@(Bin _ _ _ _) -> unionDisjointL minV1' min2 n2' min1' n1' @@ -317,12 +317,12 @@ merge miss1 miss2 match = start where -- -- In the specific case of merging n1 with l2, we don't have to do any more comparisons: we already know that min1 > min2, -- so we should be calling an L1 function - LT | xor min1 min2 < xor min1 max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missingRight miss2 r2) + LT | xor min1 min2 < xor min1 max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missRight miss2 r2) -- At this point, we know that we need to merge n1 with r2. There are two things needed to do this: -- * n1 needs to be converted to a right node to match r2. -- * We need to compare max1 and max2 to figure out which will be the maximum of the combined node and to -- decide which (R1, R2, or RFused) function to recurse to. - | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + | max1 > max2 -> case missSingle miss1 max1 maxV1 of -- If we had an optimized goR2 (no keep), then calling using it is more efficient than -- calling goR2Keep and having to extract a new maximum from the result. Therefore, we -- first check if we can keep our existing maximum, and if not, call goR2. @@ -330,34 +330,34 @@ merge miss1 miss2 match = start where Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 max2 maxV2 of Nothing -> case goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + | otherwise -> case matchSingle match max1 maxV1 maxV2 of Nothing -> case goRFused max1 (Bin min1 minV1 l1 r1) r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) where {-# INLINE l' #-} - l' = missingLeft miss2 l2 + l' = missLeft miss2 l2 -- The two nodes split at the same time. In this case we need to merge l1 and l2 and r1 and r2. We already know that -- min1 > min2, so merging the left nodes is easy, but we need to branch to figure out which right merging function to call -- and which maximum to keep. - EQ | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + EQ | max1 > max2 -> case missSingle miss1 max1 maxV1 of Nothing -> case goR2 maxV2 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) - | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 max2 maxV2 of Nothing -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) - | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + | otherwise -> case matchSingle match max1 maxV1 maxV2 of Nothing -> case goRFused max1 r1 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' @@ -368,55 +368,55 @@ merge miss1 miss2 match = start where -- The simplest case is when node 1 splits first, meaning that we need to merge n2 and l1 or r1. However, since we already know -- that min1 > min2, n2 must be merged with l1 instead of r1, and we already know the correct method to call. - GT -> binL1 max1 maxV1 (goL1Keep minV1 min1 l1 min2 n2) (missingRight miss1 r1) + GT -> binL1 max1 maxV1 (goL1Keep minV1 min1 l1 min2 n2) (missRight miss1 r1) -- Merge two left nodes and a minimum value for the second node into a new left node -- Precondition: min2 > min1 -- goL2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c - goL2Keep minV2 !_ Tip !min2 Tip = case missingSingle miss2 min2 minV2 of + goL2Keep minV2 !_ Tip !min2 Tip = case missSingle miss2 min2 minV2 of Nothing -> Tip Just minV' -> Bin min2 minV' Tip Tip - goL2Keep minV2 !min1 Tip !min2 n2 = case missingSingle miss2 min2 minV2 of - Nothing -> missingLeft miss2 n2 - Just minV' -> insertMinL (xor min1 min2) min2 minV' (missingLeft miss2 n2) - goL2Keep minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = case runIdentity (missingAll miss2 (NonEmpty min2 minV2 n2)) of - Empty -> missingLeft miss1 n1 - NonEmpty min2' minV2' n2' -> case missingLeft miss1 n1 of + goL2Keep minV2 !min1 Tip !min2 n2 = case missSingle miss2 min2 minV2 of + Nothing -> missLeft miss2 n2 + Just minV' -> insertMinL (xor min1 min2) min2 minV' (missLeft miss2 n2) + goL2Keep minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = case missAll miss2 (NonEmpty min2 minV2 n2) of + Empty -> missLeft miss1 n1 + NonEmpty min2' minV2' n2' -> case missLeft miss1 n1 of Tip -> insertMinL (xor min1 min2') min2' minV2' n2' n1'@(Bin _ _ _ _) -> unionDisjointL minV2' min1 n1' min2' n2' goL2Keep minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 goL2Keep minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 min2 < xor min2 max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missingRight miss1 r1) - | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + GT | xor min1 min2 < xor min2 max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missRight miss1 r1) + | max1 > max2 -> case missSingle miss1 max1 maxV1 of Nothing -> case goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 max2 maxV2 of Nothing -> case goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + | otherwise -> case matchSingle match max1 maxV1 maxV2 of Nothing -> case goRFused max1 r1 (Bin min2 minV2 l2 r2) of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 (Bin min2 minV2 l2 r2)) where {-# INLINE l' #-} - l' = missingLeft miss1 l1 - EQ | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + l' = missLeft miss1 l1 + EQ | max1 > max2 -> case missSingle miss1 max1 maxV1 of Nothing -> case goR2 maxV2 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) - | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 max2 maxV2 of Nothing -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) - | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + | otherwise -> case matchSingle match max1 maxV1 maxV2 of Nothing -> case goRFused max1 r1 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' @@ -424,7 +424,7 @@ merge miss1 miss2 match = start where where {-# INLINE l' #-} l' = goL2Keep minV2 min1 l1 min2 l2 - LT -> binL2 max2 maxV2 (goL2Keep minV2 min1 n1 min2 l2) (missingRight miss2 r2) + LT -> binL2 max2 maxV2 (goL2Keep minV2 min1 n1 min2 l2) (missRight miss2 r2) -- | Merge two left nodes that share a minimum bound. @@ -435,25 +435,25 @@ merge miss1 miss2 match = start where -- If one of the nodes is empty, we can just use the other one. Unlike the case of misaligned nodes, we don't have an -- extra value to insert - goLFusedKeep !_ Tip n2 = missingLeft miss2 n2 - goLFusedKeep !_ n1 Tip = missingLeft miss1 n1 + goLFusedKeep !_ Tip n2 = missLeft miss2 n2 + goLFusedKeep !_ n1 Tip = missLeft miss1 n1 -- Since the two nodes are joined at the left, the choices are considerable limited in comparison to the misaligned case. -- If node 1 splits first, n2 must be merged with l1 and if node 2 splits first, n1 must be merged with l2. The equal case -- is still the same as in the misaligned case, since we need to determine which maximum to use and which goR to call. goLFusedKeep !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of - LT -> binL2 max2 maxV2 (goLFusedKeep min n1 l2) (missingRight miss2 r2) - EQ | max1 > max2 -> case missingSingle miss1 max1 maxV1 of + LT -> binL2 max2 maxV2 (goLFusedKeep min n1 l2) (missRight miss2 r2) + EQ | max1 > max2 -> case missSingle miss1 max1 maxV1 of Nothing -> case goR2 maxV2 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) - | max1 < max2 -> case missingSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 max2 maxV2 of Nothing -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) - | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of + | otherwise -> case matchSingle match max1 maxV1 maxV2 of Nothing -> case goRFused max1 r1 r2 of Empty -> l' NonEmpty max' maxV' r' -> Bin max' maxV' l' r' @@ -461,54 +461,54 @@ merge miss1 miss2 match = start where where {-# INLINE l' #-} l' = goLFusedKeep min l1 l2 - GT -> binL1 max1 maxV1 (goLFusedKeep min l1 n2) (missingRight miss1 r1) + GT -> binL1 max1 maxV1 (goLFusedKeep min l1 n2) (missRight miss1 r1) -- Merge two right nodes and a maximum value for the first node into a new right node -- Precondition: max1 < max2 -- goR1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c - goR1Keep maxV1 !max1 Tip !_ Tip = case missingSingle miss1 max1 maxV1 of + goR1Keep maxV1 !max1 Tip !_ Tip = case missSingle miss1 max1 maxV1 of Nothing -> Tip Just maxV' -> Bin max1 maxV' Tip Tip - goR1Keep maxV1 !max1 !n1 !max2 Tip = case missingSingle miss1 max1 maxV1 of - Nothing -> missingRight miss1 n1 - Just maxV' -> insertMaxR (xor max1 max2) max1 maxV' (missingRight miss1 n1) - goR1Keep maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = case l2rMap (runIdentity (missingAll miss1 (r2lMap (NonEmpty max1 maxV1 n1)))) of - Empty -> missingRight miss2 n2 - NonEmpty max1' maxV1' n1' -> case missingRight miss2 n2 of + goR1Keep maxV1 !max1 !n1 !max2 Tip = case missSingle miss1 max1 maxV1 of + Nothing -> missRight miss1 n1 + Just maxV' -> insertMaxR (xor max1 max2) max1 maxV' (missRight miss1 n1) + goR1Keep maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = case l2rMap (missAll miss1 (r2lMap (NonEmpty max1 maxV1 n1))) of + Empty -> missRight miss2 n2 + NonEmpty max1' maxV1' n1' -> case missRight miss2 n2 of Tip -> insertMaxR (xor max1' max2) max1' maxV1' n1' n2'@(Bin _ _ _ _) -> unionDisjointR maxV1' max1' n1' max2 n2' goR1Keep maxV1 !max1 Tip !max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 goR1Keep maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> binR2 min2 minV2 (missingLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) - | min1 < min2 -> case missingSingle miss1 min1 minV1 of + LT | xor min2 max1 > xor max1 max2 -> binR2 min2 minV2 (missLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) + | min1 < min2 -> case missSingle miss1 min1 minV1 of Nothing -> case goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' - | min1 > min2 -> case missingSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 min2 minV2 of Nothing -> case goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' - | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + | otherwise -> case matchSingle match min1 minV1 minV2 of Nothing -> case goLFused min1 (Bin max1 maxV1 l1 r1) l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) r' where {-# INLINE r' #-} - r' = missingRight miss2 r2 - EQ | min1 < min2 -> case missingSingle miss1 min1 minV1 of + r' = missRight miss2 r2 + EQ | min1 < min2 -> case missSingle miss1 min1 minV1 of Nothing -> case goL2 minV2 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' - | min1 > min2 -> case missingSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 min2 minV2 of Nothing -> case goL1 minV1 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' - | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + | otherwise -> case matchSingle match min1 minV1 minV2 of Nothing -> case goLFused min1 l1 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' @@ -516,54 +516,54 @@ merge miss1 miss2 match = start where where {-# INLINE r' #-} r' = goR1Keep maxV1 max1 r1 max2 r2 - GT -> binR1 min1 minV1 (missingLeft miss1 l1) (goR1Keep maxV1 max1 r1 max2 n2) + GT -> binR1 min1 minV1 (missLeft miss1 l1) (goR1Keep maxV1 max1 r1 max2 n2) -- Merge two left nodes and a minimum value for the second node into a new left node -- Precondition: max2 < max1 -- goR2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c - goR2Keep maxV2 !_ Tip !max2 Tip = case missingSingle miss2 max2 maxV2 of + goR2Keep maxV2 !_ Tip !max2 Tip = case missSingle miss2 max2 maxV2 of Nothing -> Tip Just maxV' -> Bin max2 maxV' Tip Tip - goR2Keep maxV2 !max1 Tip !max2 n2 = case missingSingle miss2 max2 maxV2 of - Nothing -> missingRight miss2 n2 - Just maxV' -> insertMaxR (xor max1 max2) max2 maxV' (missingRight miss2 n2) - goR2Keep maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = case l2rMap (runIdentity (missingAll miss2 (r2lMap (NonEmpty max2 maxV2 n2)))) of - Empty -> missingRight miss1 n1 - NonEmpty max2' maxV2' n2' -> case missingRight miss1 n1 of + goR2Keep maxV2 !max1 Tip !max2 n2 = case missSingle miss2 max2 maxV2 of + Nothing -> missRight miss2 n2 + Just maxV' -> insertMaxR (xor max1 max2) max2 maxV' (missRight miss2 n2) + goR2Keep maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = case l2rMap (missAll miss2 (r2lMap (NonEmpty max2 maxV2 n2))) of + Empty -> missRight miss1 n1 + NonEmpty max2' maxV2' n2' -> case missRight miss1 n1 of Tip -> insertMaxR (xor max1 max2') max2' maxV2' n2' n1'@(Bin _ _ _ _) -> unionDisjointR maxV2' max2' n2' max1 n1' goR2Keep maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 goR2Keep maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 max2 > xor max2 max1 -> binR1 min1 minV1 (missingLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) - | min1 < min2 -> case missingSingle miss1 min1 minV1 of + GT | xor min1 max2 > xor max2 max1 -> binR1 min1 minV1 (missLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) + | min1 < min2 -> case missSingle miss1 min1 minV1 of Nothing -> case goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' - | min1 > min2 -> case missingSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 min2 minV2 of Nothing -> case goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' - | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + | otherwise -> case matchSingle match min1 minV1 minV2 of Nothing -> case goLFused min1 l1 (Bin max2 maxV2 l2 r2) of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 (Bin max2 maxV2 l2 r2)) r' where {-# INLINE r' #-} - r' = missingRight miss1 r1 - EQ | min1 < min2 -> case missingSingle miss1 min1 minV1 of + r' = missRight miss1 r1 + EQ | min1 < min2 -> case missSingle miss1 min1 minV1 of Nothing -> case goL2 minV2 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' - | min1 > min2 -> case missingSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 min2 minV2 of Nothing -> case goL1 minV1 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' - | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + | otherwise -> case matchSingle match min1 minV1 minV2 of Nothing -> case goLFused min1 l1 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' @@ -571,24 +571,24 @@ merge miss1 miss2 match = start where where {-# INLINE r' #-} r' = goR2Keep maxV2 max1 r1 max2 r2 - LT -> binR2 min2 minV2 (missingLeft miss2 l2) (goR2Keep maxV2 max1 n1 max2 r2) + LT -> binR2 min2 minV2 (missLeft miss2 l2) (goR2Keep maxV2 max1 n1 max2 r2) -- goRFusedKeep !_ Tip Tip = Tip - goRFusedKeep !_ Tip n2 = missingRight miss2 n2 - goRFusedKeep !_ n1 Tip = missingRight miss1 n1 + goRFusedKeep !_ Tip n2 = missRight miss2 n2 + goRFusedKeep !_ n1 Tip = missRight miss1 n1 goRFusedKeep !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of - LT -> binR2 min2 minV2 (missingLeft miss2 l2) (goRFusedKeep max n1 r2) - EQ | min1 < min2 -> case missingSingle miss1 min1 minV1 of + LT -> binR2 min2 minV2 (missLeft miss2 l2) (goRFusedKeep max n1 r2) + EQ | min1 < min2 -> case missSingle miss1 min1 minV1 of Nothing -> case goL2 minV2 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' - | min1 > min2 -> case missingSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 min2 minV2 of Nothing -> case goL1 minV1 min1 l1 min2 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' - | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of + | otherwise -> case matchSingle match min1 minV1 minV2 of Nothing -> case goLFused min1 l1 l2 of Empty -> r' NonEmpty min' minV' l' -> Bin min' minV' l' r' @@ -596,7 +596,7 @@ merge miss1 miss2 match = start where where {-# INLINE r' #-} r' = goRFusedKeep max r1 r2 - GT -> binR1 min1 minV1 (missingLeft miss1 l1) (goRFusedKeep max r1 n2) + GT -> binR1 min1 minV1 (missLeft miss1 l1) (goRFusedKeep max r1 n2) -- TODO: These are inefficient, obviously correct implementations. See intersection -- and difference for examples of specialized implementations @@ -607,90 +607,106 @@ merge miss1 miss2 match = start where goR2 maxV2 !max1 !n1 !max2 !n2 = nodeToMapR (goR2Keep maxV2 max1 n1 max2 n2) goRFused !max !n1 !n2 = nodeToMapR (goRFusedKeep max n1 n2) - goInsertL1 !k v !_ _ Tip = case missingSingle miss1 k v of + goInsertL1 !k v !_ _ Tip = case missSingle miss1 k v of Nothing -> Tip Just v' -> Bin k v' Tip Tip goInsertL1 !k v !xorCache min (Bin max maxV l r) | k < max = if xorCache < xorCacheMax - then binL2 max maxV (goInsertL1 k v xorCache min l) (missingRight miss2 r) - else binL2 max maxV (missingLeft miss2 l) (goInsertR1 k v xorCacheMax max r) - | k > max = case missingSingle miss1 k v of - Nothing -> missingLeft miss2 (Bin max maxV l r) + then binL2 max maxV (goInsertL1 k v xorCache min l) (missRight miss2 r) + else binL2 max maxV (missLeft miss2 l) (goInsertR1 k v xorCacheMax max r) + | k > max = case missSingle miss1 k v of + Nothing -> missLeft miss2 (Bin max maxV l r) Just v' -> if xor min max < xorCacheMax - then Bin k v' (missingLeft miss2 (Bin max maxV l r)) Tip - else Bin k v' (missingLeft miss2 l) (missingRight miss2 (insertMaxR xorCacheMax max maxV r)) - | otherwise = case runIdentity (matchedSingle match max v maxV) of - Nothing -> extractBinL (missingLeft miss2 l) (missingRight miss2 r) -- TODO: do extractBin first? - Just maxV' -> Bin max maxV' (missingLeft miss2 l) (missingRight miss2 r) + then Bin k v' (missLeft miss2 (Bin max maxV l r)) Tip + else Bin k v' (missLeft miss2 l) (missRight miss2 (insertMaxR xorCacheMax max maxV r)) + | otherwise = case matchSingle match max v maxV of + Nothing -> extractBinL (missLeft miss2 l) (missRight miss2 r) -- TODO: do extractBin first? + Just maxV' -> Bin max maxV' (missLeft miss2 l) (missRight miss2 r) where xorCacheMax = xor k max - goInsertL2 !k v !_ _ Tip = case missingSingle miss2 k v of + goInsertL2 !k v !_ _ Tip = case missSingle miss2 k v of Nothing -> Tip Just v' -> Bin k v' Tip Tip goInsertL2 !k v !xorCache min (Bin max maxV l r) | k < max = if xorCache < xorCacheMax - then binL1 max maxV (goInsertL2 k v xorCache min l) (missingRight miss1 r) - else binL1 max maxV (missingLeft miss1 l) (goInsertR2 k v xorCacheMax max r) - | k > max = case missingSingle miss2 k v of - Nothing -> missingLeft miss1 (Bin max maxV l r) + then binL1 max maxV (goInsertL2 k v xorCache min l) (missRight miss1 r) + else binL1 max maxV (missLeft miss1 l) (goInsertR2 k v xorCacheMax max r) + | k > max = case missSingle miss2 k v of + Nothing -> missLeft miss1 (Bin max maxV l r) Just v' -> if xor min max < xorCacheMax - then Bin k v' (missingLeft miss1 (Bin max maxV l r)) Tip - else Bin k v' (missingLeft miss1 l) (missingRight miss1 (insertMaxR xorCacheMax max maxV r)) - | otherwise = case runIdentity (matchedSingle match max maxV v) of - Nothing -> extractBinL (missingLeft miss1 l) (missingRight miss1 r) -- TODO: do extractBin first? - Just maxV' -> Bin max maxV' (missingLeft miss1 l) (missingRight miss1 r) + then Bin k v' (missLeft miss1 (Bin max maxV l r)) Tip + else Bin k v' (missLeft miss1 l) (missRight miss1 (insertMaxR xorCacheMax max maxV r)) + | otherwise = case matchSingle match max maxV v of + Nothing -> extractBinL (missLeft miss1 l) (missRight miss1 r) -- TODO: do extractBin first? + Just maxV' -> Bin max maxV' (missLeft miss1 l) (missRight miss1 r) where xorCacheMax = xor k max - goInsertR1 k v !_ _ Tip = case missingSingle miss1 k v of + goInsertR1 k v !_ _ Tip = case missSingle miss1 k v of Nothing -> Tip Just v' -> Bin k v' Tip Tip goInsertR1 k v !xorCache max (Bin min minV l r) | k > min = if xorCache < xorCacheMin - then binR2 min minV (missingLeft miss2 l) (goInsertR1 k v xorCache max r) - else binR2 min minV (goInsertL1 k v xorCacheMin min l) (missingRight miss2 r) - | k < min = case missingSingle miss1 k v of - Nothing -> missingRight miss2 (Bin min minV l r) + then binR2 min minV (missLeft miss2 l) (goInsertR1 k v xorCache max r) + else binR2 min minV (goInsertL1 k v xorCacheMin min l) (missRight miss2 r) + | k < min = case missSingle miss1 k v of + Nothing -> missRight miss2 (Bin min minV l r) Just v' -> if xor min max < xorCacheMin - then Bin k v' Tip (missingRight miss2 (Bin min minV l r)) - else Bin k v' (missingLeft miss2 (insertMinL xorCacheMin min minV l)) (missingRight miss2 r) - | otherwise = case runIdentity (matchedSingle match min v minV) of - Nothing -> extractBinR (missingLeft miss2 l) (missingRight miss2 r) -- TODO: do extractBin first? - Just minV' -> Bin min minV' (missingLeft miss2 l) (missingRight miss2 r) + then Bin k v' Tip (missRight miss2 (Bin min minV l r)) + else Bin k v' (missLeft miss2 (insertMinL xorCacheMin min minV l)) (missRight miss2 r) + | otherwise = case matchSingle match min v minV of + Nothing -> extractBinR (missLeft miss2 l) (missRight miss2 r) -- TODO: do extractBin first? + Just minV' -> Bin min minV' (missLeft miss2 l) (missRight miss2 r) where xorCacheMin = xor k min - goInsertR2 !k v !_ _ Tip = case missingSingle miss2 k v of + goInsertR2 !k v !_ _ Tip = case missSingle miss2 k v of Nothing -> Tip Just v' -> Bin k v' Tip Tip goInsertR2 !k v !xorCache max (Bin min minV l r) | k > min = if xorCache < xorCacheMin - then binR1 min minV (missingLeft miss1 l) (goInsertR2 k v xorCache max r) - else binR1 min minV (goInsertL2 k v xorCacheMin min l) (missingRight miss1 r) - | k < min = case missingSingle miss2 k v of - Nothing -> missingRight miss1 (Bin min minV l r) + then binR1 min minV (missLeft miss1 l) (goInsertR2 k v xorCache max r) + else binR1 min minV (goInsertL2 k v xorCacheMin min l) (missRight miss1 r) + | k < min = case missSingle miss2 k v of + Nothing -> missRight miss1 (Bin min minV l r) Just v' -> if xor min max < xorCacheMin - then Bin k v' Tip (missingRight miss1 (Bin min minV l r)) - else Bin k v' (missingLeft miss1 (insertMinL xorCacheMin min minV l)) (missingRight miss1 r) - | otherwise = case runIdentity (matchedSingle match min minV v) of - Nothing -> extractBinR (missingLeft miss1 l) (missingRight miss1 r) -- TODO: do extractBin first? - Just minV' -> Bin min minV' (missingLeft miss1 l) (missingRight miss1 r) + then Bin k v' Tip (missRight miss1 (Bin min minV l r)) + else Bin k v' (missLeft miss1 (insertMinL xorCacheMin min minV l)) (missRight miss1 r) + | otherwise = case matchSingle match min minV v of + Nothing -> extractBinR (missLeft miss1 l) (missRight miss1 r) -- TODO: do extractBin first? + Just minV' -> Bin min minV' (missLeft miss1 l) (missRight miss1 r) where xorCacheMin = xor k min {-# INLINE binL1 #-} - binL1 k1 v1 l r = case missingSingle miss1 k1 v1 of + binL1 k1 v1 l r = case missSingle miss1 k1 v1 of Nothing -> extractBinL l r Just v' -> Bin k1 v' l r {-# INLINE binL2 #-} - binL2 k2 v2 l r = case missingSingle miss2 k2 v2 of + binL2 k2 v2 l r = case missSingle miss2 k2 v2 of Nothing -> extractBinL l r Just v' -> Bin k2 v' l r {-# INLINE binR1 #-} - binR1 k1 v1 l r = case missingSingle miss1 k1 v1 of + binR1 k1 v1 l r = case missSingle miss1 k1 v1 of Nothing -> extractBinR l r Just v' -> Bin k1 v' l r {-# INLINE binR2 #-} - binR2 k2 v2 l r = case missingSingle miss2 k2 v2 of + binR2 k2 v2 l r = case missSingle miss2 k2 v2 of Nothing -> extractBinR l r Just v' -> Bin k2 v' l r + + -- To avoid the messy pain of putting runIdentity everywhere, we use pure versions of the input functions. + {-# INLINE missSingle #-} + missSingle whenMiss k v = runIdentity (missingSingle whenMiss k v) + + {-# INLINE missLeft #-} + missLeft whenMiss l = runIdentity (missingLeft whenMiss l) + + {-# INLINE missRight #-} + missRight whenMiss r = runIdentity (missingRight whenMiss r) + + {-# INLINE missAll #-} + missAll whenMiss m = runIdentity (missingAll whenMiss m) + + {-# INLINE matchSingle #-} + matchSingle whenMatch k v1 v2 = runIdentity (matchedSingle whenMatch k v1 v2) diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index ad7011e46..5e6ec8f53 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -66,7 +66,7 @@ import Data.IntMap.Merge.Internal -- -- but @mapMissing@ is somewhat faster. mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b -mapMissing f = WhenMissing (\k v -> Just (f k v)) goL goR (pure . start) where +mapMissing f = WhenMissing (\k v -> pure (Just (f k v))) (pure . goL) (pure . goR) (pure . start) where start Empty = Empty start (NonEmpty min minV root) = NonEmpty min (f min minV) (goL root) @@ -88,7 +88,7 @@ mapMissing f = WhenMissing (\k v -> Just (f k v)) goL goR (pure . start) where -- -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b -mapMaybeMissing f = WhenMissing f goLKeep goRKeep (pure . start) where +mapMaybeMissing f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pure . goRKeep) (pure . start) where start Empty = Empty start (NonEmpty min minV root) = case f min minV of Just minV' -> NonEmpty min minV' (goLKeep root) diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 07470d657..9b93a284c 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -70,7 +70,7 @@ import Data.IntMap.Merge.Internal -- -- but @mapMissing@ is somewhat faster. mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b -mapMissing f = WhenMissing (\k v -> Just $! f k v) goL goR (pure . start) where +mapMissing f = WhenMissing (\k v -> pure (Just $! f k v)) (pure . goL) (pure . goR) (pure . start) where start Empty = Empty start (NonEmpty min minV root) = NonEmpty min #! f min minV # goL root @@ -92,7 +92,7 @@ mapMissing f = WhenMissing (\k v -> Just $! f k v) goL goR (pure . start) where -- -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b -mapMaybeMissing f = WhenMissing f goLKeep goRKeep (pure . start) where +mapMaybeMissing f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pure . goRKeep) (pure . start) where start Empty = Empty start (NonEmpty min minV root) = case f min minV of Just !minV' -> NonEmpty min minV' (goLKeep root) From 2e018f6bacc8e7508f142f259ba59f1aa8bfd9c9 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 17 Dec 2019 14:39:17 -0600 Subject: [PATCH 034/147] Fix strictness of IntMap.Merge.Strict.mapMaybeMissing --- containers/src/Data/IntMap/Merge/Strict.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 9b93a284c..08f226f8b 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -92,7 +92,10 @@ mapMissing f = WhenMissing (\k v -> pure (Just $! f k v)) (pure . goL) (pure . g -- -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b -mapMaybeMissing f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pure . goRKeep) (pure . start) where +mapMaybeMissing f = WhenMissing (\k v -> case f k v of + Nothing -> pure Nothing + Just !b -> pure (Just b)) (pure . goLKeep) (pure . goRKeep) (pure . start) + where start Empty = Empty start (NonEmpty min minV root) = case f min minV of Just !minV' -> NonEmpty min minV' (goLKeep root) From cae5fea082ceabeee2f8dc7cd429cde6bd238290 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 17 Dec 2019 18:33:40 -0600 Subject: [PATCH 035/147] Implement IntMap.Merge.Internal.mergeA. --- containers-tests/tests/intmap-properties.hs | 51 ++--- containers/src/Data/IntMap/Merge/Internal.hs | 218 ++++++++++++++++++- containers/src/Data/IntMap/Merge/Lazy.hs | 1 + containers/src/Data/IntMap/Merge/Strict.hs | 1 + 4 files changed, 237 insertions(+), 34 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 1d2f2a5d9..105c33ab5 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -2,11 +2,9 @@ #ifdef STRICT import Data.IntMap.Strict as Data.IntMap hiding (showTree) -import Data.IntMap.Strict.Internal (traverseMaybeWithKey) import Data.IntMap.Merge.Strict #else import Data.IntMap.Lazy as Data.IntMap hiding (showTree) -import Data.IntMap.Internal (traverseMaybeWithKey) import Data.IntMap.Merge.Lazy #endif import Data.IntMap.Internal.Debug (showTree) @@ -16,6 +14,7 @@ import Control.Applicative (Applicative(..)) import Data.Monoid import Data.Maybe hiding (mapMaybe) import qualified Data.Maybe as Maybe (mapMaybe) +import Data.Functor.Identity import Data.Ord import Data.Foldable (foldMap) import Data.Function @@ -152,8 +151,10 @@ main = defaultMain , testProperty "intersectionWith model" prop_intersectionWithModel , testProperty "intersectionWithKey model" prop_intersectionWithKeyModel , testProperty "mergeWithKey model" prop_mergeWithKeyModel - , testProperty "merge valid" prop_merge_valid - , testProperty "mergeA effects" prop_mergeA_effects + , testProperty "union==merge" prop_unionEqMerge + , testProperty "difference==merge" prop_differenceEqMerge + , testProperty "intersection==merge" prop_intersectionEqMerge + , testProperty "merge==mergeA" prop_mergeEqMergeA , testProperty "fromAscList" prop_ordered , testProperty "fromList then toList" prop_list , testProperty "toDescList" prop_descList @@ -1261,34 +1262,20 @@ prop_mergeWithKeyModel f keep_x keep_y xs ys -- warnings are issued if testMergeWithKey gets inlined. {-# NOINLINE testMergeWithKey #-} -prop_merge_valid - :: Fun (Key, A) (Maybe C) - -> Fun (Key, B) (Maybe C) - -> Fun (Key, A, B) (Maybe C) - -> IntMap A - -> IntMap B - -> Property -prop_merge_valid whenMissingA whenMissingB whenMatched xs ys - = valid m - where - m = - merge - (mapMaybeMissing (applyFun2 whenMissingA)) - (mapMaybeMissing (applyFun2 whenMissingB)) - (zipWithMaybeMatched (applyFun3 whenMatched)) - xs - ys - --- This uses the instance --- Monoid a => Applicative ((,) a) --- to test that effects are sequenced in ascending key order. -prop_mergeA_effects :: UMap -> UMap -> Property -prop_mergeA_effects xs ys - = effects === sort effects - where - (effects, _m) = mergeA whenMissing whenMissing whenMatched xs ys - whenMissing = traverseMissing (\k _ -> ([k], ())) - whenMatched = zipWithAMatched (\k _ _ -> ([k], ())) +prop_unionEqMerge :: UMap -> UMap -> Property +prop_unionEqMerge m1 m2 = union m1 m2 === merge preserveMissing preserveMissing (zipWithMatched (\_ x _ -> x)) m1 m2 + +prop_differenceEqMerge :: UMap -> UMap -> Property +prop_differenceEqMerge m1 m2 = difference m1 m2 === merge preserveMissing dropMissing (zipWithMaybeMatched (\_ _ _ -> Nothing)) m1 m2 + +prop_intersectionEqMerge :: UMap -> UMap -> Property +prop_intersectionEqMerge m1 m2 = intersection m1 m2 === merge dropMissing dropMissing (zipWithMatched (\_ x _ -> x)) m1 m2 + +prop_mergeEqMergeA :: Fun Int Bool -> Fun Int Bool -> Fun Int Bool -> UMap -> UMap -> Property +prop_mergeEqMergeA pMiss1 pMiss2 pMatch m1 m2 = merge whenMiss1 whenMiss2 whenMatch m1 m2 === runIdentity (mergeA whenMiss1 whenMiss2 whenMatch m1 m2) where + whenMiss1 = mapMaybeMissing (\k _ -> if apply pMiss1 k then Just () else Nothing) + whenMiss2 = mapMaybeMissing (\k _ -> if apply pMiss2 k then Just () else Nothing) + whenMatch = zipWithMaybeMatched (\k _ _ -> if apply pMatch k then Just () else Nothing) ---------------------------------------------------------------- diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 6d839359d..7f8f97c35 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -80,7 +80,7 @@ data WhenMissing f a b = WhenMissing { missingSingle :: Key -> a -> f (Maybe b), missingLeft :: Node L a -> f (Node L b), missingRight :: Node R a -> f (Node R b), - missingAll :: IntMap_ L a -> f (IntMap_ L b) + missingAllL :: IntMap_ L a -> f (IntMap_ L b) } -- | A tactic for dealing with keys present in one map but not the other in @@ -706,7 +706,221 @@ merge miss1 miss2 match = start where missRight whenMiss r = runIdentity (missingRight whenMiss r) {-# INLINE missAll #-} - missAll whenMiss m = runIdentity (missingAll whenMiss m) + missAll whenMiss m = runIdentity (missingAllL whenMiss m) {-# INLINE matchSingle #-} matchSingle whenMatch k v1 v2 = runIdentity (matchedSingle whenMatch k v1 v2) + +-- | An applicative version of 'merge'. Due to the necessity of performing actions +-- in order, this can be significantly slower than 'merge'. +-- +-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched' +-- tactic and two maps. It uses the tactics to merge the maps. +-- Its behavior is best understood via its fundamental tactics, +-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'. +-- +-- Consider +-- +-- @ +-- mergeA (traverseMaybeMissing g1) +-- (traverseMaybeMissing g2) +-- (zipWithMaybeAMatched f) +-- m1 m2 +-- @ +-- +-- Take, for example, +-- +-- @ +-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')] +-- m2 = [(1, "one"), (2, "two"), (4, "three")] +-- @ +-- +-- 'mergeA' will first \"align\" these maps by key: +-- +-- @ +-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')] +-- m2 = [(1, "one"), (2, "two"), (4, "three")] +-- @ +-- +-- It will then pass the individual entries and pairs of entries +-- to @g1@, @g2@, or @f@ as appropriate: +-- +-- @ +-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"] +-- @ +-- +-- Next, it will perform the actions in the @actions@ list in order from +-- left to right. +-- +-- @ +-- keys = 0 1 2 3 4 +-- results = [Nothing, Just True, Just False, Nothing, Just True] +-- @ +-- +-- Finally, the @Just@ results are collected into a map: +-- +-- @ +-- return value = [(1, True), (2, False), (4, True)] +-- @ +-- +-- The other tactics below are optimizations or simplifications of +-- 'traverseMaybeMissing' for special cases. Most importantly, +-- +-- * 'dropMissing' drops all the keys. +-- * 'preserveMissing' leaves all the entries alone. +-- * 'mapMaybeMissing' does not use the 'Applicative' context. +-- +-- When 'mergeA' is given three arguments, it is inlined at the call +-- site. To prevent excessive inlining, you should generally only use +-- 'mergeA' to define custom combining functions. +-- +-- @since 0.5.9 +mergeA :: Applicative f => WhenMissing f a c -> WhenMissing f b c -> WhenMatched f a b c -> IntMap a -> IntMap b -> f (IntMap c) +mergeA miss1 miss2 match = start where + start (IntMap Empty) (IntMap Empty) = pure (IntMap Empty) + start (IntMap Empty) (IntMap !m2) = IntMap <$> missingAllL miss2 m2 + start (IntMap !m1) (IntMap Empty) = IntMap <$> missingAllL miss1 m1 + start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = (\v m -> IntMap (maybeInsertMin min1 v m)) <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 root1 min2 root2 + | min2 < min1 = (\v m -> IntMap (maybeInsertMin min2 v m)) <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 root1 min2 root2 + | otherwise = (\v m -> IntMap (maybeInsertMin min1 v m)) <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 root1 root2 + + goL1 minV1 !min1 !n1 !_ Tip = missingAllL miss1 (NonEmpty min1 minV1 n1) + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = maybeUnionDisjointL min2 <$> missingLeft miss2 n2 <*> missingAllL miss1 (NonEmpty min1 minV1 n1) + goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min1 min2 < xor min1 max2 -> binL <$> goL1 minV1 min1 n1 min2 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) + | max1 > max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss2 l2 <*> goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 <*> missingSingle miss1 max1 maxV1 + | max1 < max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max2 v rm))) <$> missingLeft miss2 l2 <*> goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 <*> missingSingle miss2 max2 maxV2 + | otherwise -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss2 l2 <*> goRFused max1 (Bin min1 minV1 l1 r1) r2 <*> matchedSingle match max1 maxV1 maxV2 + EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 max1 maxV1 + | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 max2 maxV2 + | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match max1 maxV1 maxV2 + GT -> binL <$> goL1 minV1 min1 l1 min2 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) + + goL2 minV2 !_ Tip !min2 !n2 = missingAllL miss2 (NonEmpty min2 minV2 n2) + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = maybeUnionDisjointL min1 <$> missingLeft miss1 n1 <*> missingAllL miss2 (NonEmpty min2 minV2 n2) + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 + goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 min2 < xor min2 max1 -> binL <$> goL2 minV2 min1 l1 min2 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) + | max1 > max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss1 l1 <*> goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) <*> missingSingle miss1 max1 maxV1 + | max1 < max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max2 v rm))) <$> missingLeft miss1 l1 <*> goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) <*> missingSingle miss2 max2 maxV2 + | otherwise -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss1 l1 <*> goRFused max1 r1 (Bin min2 minV2 l2 r2) <*> matchedSingle match max1 maxV1 maxV2 + EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 max1 maxV1 + | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 max2 maxV2 + | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match max1 maxV1 maxV2 + LT -> binL <$> goL2 minV2 min1 n1 min2 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) + + goLFused !_ Tip !n2 = nodeToMapL <$> missingLeft miss2 n2 + goLFused !_ !n1 Tip = nodeToMapL <$> missingLeft miss1 n1 + goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + LT -> binL <$> goLFused min n1 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) + EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goLFused min l1 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 max1 maxV1 + | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goLFused min l1 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 max2 maxV2 + | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goLFused min l1 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match max1 maxV1 maxV2 + GT -> binL <$> goLFused min l1 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) + + goR1 maxV1 !max1 !n1 !_ Tip = missingAllR miss1 (NonEmpty max1 maxV1 n1) + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | max1 < min2 = maybeUnionDisjointR max2 <$> missingAllR miss1 (NonEmpty max1 maxV1 n1) <*> missingRight miss2 n2 + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + LT | xor min2 max1 > xor max1 max2 -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goR1 maxV1 max1 n1 max2 r2 + | min1 < min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 <*> missingRight miss2 r2 + | min1 > min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min2 v lm) r')) <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 <*> missingRight miss2 r2 + | otherwise -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 (Bin max1 maxV1 l1 r1) l2 <*> missingRight miss2 r2 + EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 + | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 + | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 l1 l2 <*> goR1 maxV1 max1 r1 max2 r2 + GT -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goR1 maxV1 max1 r1 max2 n2 + + goR2 maxV2 !_ Tip !max2 !n2 = missingAllR miss2 (NonEmpty max2 maxV2 n2) + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | max2 < min1 = maybeUnionDisjointR max1 <$> missingAllR miss2 (NonEmpty max2 maxV2 n2) <*> missingRight miss1 n1 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 + goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + GT | xor min1 max2 > xor max2 max1 -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goR2 maxV2 max1 r1 max2 n2 + | min1 < min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 + | min1 > min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min2 v lm) r')) <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 + | otherwise -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 l1 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 + EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 + | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 + | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 l1 l2 <*> goR2 maxV2 max1 r1 max2 r2 + LT -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goR2 maxV2 max1 n1 max2 r2 + + goRFused !_ Tip !n2 = nodeToMapR <$> missingRight miss2 n2 + goRFused !_ !n1 Tip = nodeToMapR <$> missingRight miss1 n1 + goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + LT -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goRFused max n1 r2 + EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goRFused max r1 r2 + | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goRFused max r1 r2 + | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 l1 l2 <*> goRFused max r1 r2 + GT -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goRFused max r1 n2 + + goInsertL1 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss1 k v + goInsertL1 !k v !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then binL <$> goInsertL1 k v xorCache min l <*> missingAllR miss2 (NonEmpty max maxV r) + else (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss2 l <*> goInsertR1 k v xorCacheMax max r <*> missingSingle miss2 max maxV + | k > max = (\n' v' -> r2lMap (maybeInsertMax k v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss2 n <*> missingSingle miss1 k v + | otherwise = (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss2 l <*> missingRight miss2 r <*> matchedSingle match max v maxV + where xorCacheMax = xor k max + + goInsertL2 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss2 k v + goInsertL2 !k v !xorCache min n@(Bin max maxV l r) + | k < max = if xorCache < xorCacheMax + then binL <$> goInsertL2 k v xorCache min l <*> missingAllR miss1 (NonEmpty max maxV r) + else (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss1 l <*> goInsertR2 k v xorCacheMax max r <*> missingSingle miss1 max maxV + | k > max = (\n' v' -> r2lMap (maybeInsertMax k v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss1 n <*> missingSingle miss2 k v + | otherwise = (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss1 l <*> missingRight miss1 r <*> matchedSingle match max maxV v + where xorCacheMax = xor k max + + goInsertR1 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss1 k v + goInsertR1 !k v !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then binR <$> missingAllL miss2 (NonEmpty min minV l) <*> goInsertR1 k v xorCache max r + else (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss2 min minV <*> goInsertL1 k v xorCacheMin min l <*> missingRight miss2 r + | k < min = (\v' n' -> l2rMap (maybeInsertMin k v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss1 k v <*> missingRight miss2 n + | otherwise = (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match min v minV <*> missingLeft miss2 l <*> missingRight miss2 r + where xorCacheMin = xor k min + + goInsertR2 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss2 k v + goInsertR2 !k v !xorCache max n@(Bin min minV l r) + | k > min = if xorCache < xorCacheMin + then binR <$> missingAllL miss1 (NonEmpty min minV l) <*> goInsertR2 k v xorCache max r + else (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss1 min minV <*> goInsertL2 k v xorCacheMin min l <*> missingRight miss1 r + | k < min = (\v' n' -> l2rMap (maybeInsertMin k v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss2 k v <*> missingRight miss1 n + | otherwise = (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match min minV v <*> missingLeft miss1 l <*> missingRight miss1 r + where xorCacheMin = xor k min + + missingAllR whenMiss = fmap l2rMap . missingAllL whenMiss . r2lMap + +maybeSingleton :: Key -> Maybe v -> IntMap_ d v +maybeSingleton !_ Nothing = Empty +maybeSingleton !k (Just v) = NonEmpty k v Tip + +maybeBinL :: Node L v -> IntMap_ R v -> Node L v +maybeBinL l Empty = l +maybeBinL l (NonEmpty max maxV r) = Bin max maxV l r + +maybeBinR :: IntMap_ L v -> Node R v -> Node R v +maybeBinR Empty r = r +maybeBinR (NonEmpty min minV l) r = Bin min minV l r + +maybeInsertMin :: Key -> Maybe v -> IntMap_ L v -> IntMap_ L v +maybeInsertMin !_ Nothing !m = m +maybeInsertMin !k (Just v) Empty = NonEmpty k v Tip +maybeInsertMin !k (Just v) (NonEmpty min minV root) = NonEmpty k v (insertMinL (xor k min) min minV root) + +maybeInsertMax :: Key -> Maybe v -> IntMap_ R v -> IntMap_ R v +maybeInsertMax !_ Nothing !m = m +maybeInsertMax !k (Just v) Empty = NonEmpty k v Tip +maybeInsertMax !k (Just v) (NonEmpty max maxV root) = NonEmpty k v (insertMaxR (xor k max) max maxV root) + +maybeUnionDisjointL :: Key -> Node L v -> IntMap_ L v -> IntMap_ L v +maybeUnionDisjointL !_ Tip !m2 = m2 +maybeUnionDisjointL !_ !n1 Empty = nodeToMapL n1 +maybeUnionDisjointL !min1 !n1 (NonEmpty min2 minV2 root2) = nodeToMapL (unionDisjointL minV2 min1 n1 min2 root2) + +maybeUnionDisjointR :: Key -> IntMap_ R v -> Node R v -> IntMap_ R v +maybeUnionDisjointR !_ !m1 Tip = m1 +maybeUnionDisjointR !_ Empty !n2 = nodeToMapR n2 +maybeUnionDisjointR !max2 (NonEmpty max1 maxV1 root1) !n2 = nodeToMapR (unionDisjointR maxV1 max1 root1 max2 n2) diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 5e6ec8f53..acf19103d 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -37,6 +37,7 @@ module Data.IntMap.Merge.Lazy ( -- ** General combining function , merge + , mergeA -- ** @WhenMatched@ tactics , zipWithMaybeMatched diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 08f226f8b..06fe1a477 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -37,6 +37,7 @@ module Data.IntMap.Merge.Strict ( -- ** General combining function , merge + , mergeA -- ** @WhenMatched@ tactics , zipWithMaybeMatched From c2f373a747fd77657c7fc749a1c2c302642ea433 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 17 Dec 2019 22:47:56 -0600 Subject: [PATCH 036/147] Add applicative tactics to IntMap.Merge.* --- containers/src/Data/IntMap/Merge/Internal.hs | 27 +++++ containers/src/Data/IntMap/Merge/Lazy.hs | 100 ++++++++++++++++++- containers/src/Data/IntMap/Merge/Strict.hs | 100 ++++++++++++++++++- 3 files changed, 219 insertions(+), 8 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 7f8f97c35..8e2bd54d6 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -166,6 +166,33 @@ filterMissing p = WhenMissing (\k v -> pure (if p k v then Just v else Nothing)) NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV (goLKeep l) r') | otherwise = binR (goL l) (goR r) +-- | Filter the entries whose keys are missing from the other map +-- using some 'Applicative' action. +-- +-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $ +-- > \k x -> (\b -> guard b *> Just x) <$> f k x +-- +-- but this should be a little faster. +-- +-- @since 0.5.9 +{-# INLINE filterAMissing #-} +-- TODO: Use pointer equality to speed this up? +filterAMissing :: Applicative f => (Key -> a -> f Bool) -> WhenMissing f a a +filterAMissing f = WhenMissing + { missingAllL = start + , missingLeft = goL + , missingRight = goR + , missingSingle = \k v -> fmap (\keep -> if keep then Just v else Nothing) (f k v) } + where + start Empty = pure Empty + start (NonEmpty min minV root) = (\keepV root' -> if keepV then NonEmpty min minV root' else nodeToMapL root') <$> f min minV <*> goL root + + goL Tip = pure Tip + goL (Bin max maxV l r) = (\l' r' keepMax -> if keepMax then Bin max maxV l' r' else extractBinL l' r') <$> goL l <*> goR r <*> f max maxV + + goR Tip = pure Tip + goR (Bin min minV l r) = (\keepMin l' r' -> if keepMin then Bin min minV l' r' else extractBinR l' r') <$> f min minV <*> goL l <*> goR r + -- | A tactic for dealing with keys present in both -- maps in 'merge' or 'mergeA'. -- diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index acf19103d..2db46cdc0 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -32,14 +32,13 @@ module Data.IntMap.Merge.Lazy ( -- ** Simple merge tactic types - WhenMissing - , WhenMatched + SimpleWhenMissing + , SimpleWhenMatched -- ** General combining function , merge - , mergeA - -- ** @WhenMatched@ tactics + -- *** @WhenMatched@ tactics , zipWithMaybeMatched , zipWithMatched @@ -49,6 +48,28 @@ module Data.IntMap.Merge.Lazy ( , mapMissing , mapMaybeMissing , filterMissing + + -- ** Applicative merge tactic types + , WhenMissing + , WhenMatched + + -- ** Applicative general combining function + , mergeA + + -- *** @WhenMatched@ tactics + -- | The tactics described for 'merge' work for + -- 'mergeA' as well. Furthermore, the following + -- are available. + , zipWithMaybeAMatched + , zipWithAMatched + + -- *** @WhenMissing@ tactics + -- | The tactics described for 'merge' work for + -- 'mergeA' as well. Furthermore, the following + -- are available. + , traverseMaybeMissing + , traverseMissing + , filterAMissing ) where import Control.Applicative (Applicative(..)) @@ -148,3 +169,74 @@ zipWithMaybeMatched f = WhenMatched (\k a b -> pure (f k a b)) {-# INLINE zipWithMatched #-} zipWithMatched :: Applicative f => (Key -> a -> b -> c) -> WhenMatched f a b c zipWithMatched f = zipWithMaybeMatched (\k a b -> Just (f k a b)) + +-- | When a key is found in both maps, apply a function to the key +-- and values, perform the resulting action, and maybe use the +-- result in the merged map. +-- +-- This is the fundamental 'WhenMatched' tactic. +-- +-- @since 0.5.9 +{-# INLINE zipWithMaybeAMatched #-} +zipWithMaybeAMatched + :: (Key -> a -> b -> f (Maybe c)) + -> WhenMatched f a b c +zipWithMaybeAMatched f = WhenMatched (\k a b -> f k a b) + +-- | When a key is found in both maps, apply a function to the key +-- and values to produce an action and use its result in the merged +-- map. +-- +-- @since 0.5.9 +{-# INLINE zipWithAMatched #-} +zipWithAMatched + :: Applicative f + => (Key -> a -> b -> f c) + -> WhenMatched f a b c +zipWithAMatched f = zipWithMaybeAMatched (\k a b -> Just <$> f k a b) + +-- | Traverse over the entries whose keys are missing from the other +-- map, optionally producing values to put in the result. This is +-- the most powerful 'WhenMissing' tactic, but others are usually +-- more efficient. +-- +-- @since 0.5.9 +{-# INLINE traverseMaybeMissing #-} +traverseMaybeMissing + :: Applicative f => (Key -> a -> f (Maybe b)) -> WhenMissing f a b +traverseMaybeMissing f = WhenMissing + { missingAllL = start + , missingLeft = goL + , missingRight = goR + , missingSingle = f } + where + start Empty = pure Empty + start (NonEmpty min minV root) = maybe nodeToMapL (NonEmpty min) <$> f min minV <*> goL root + + goL Tip = pure Tip + goL (Bin max maxV l r) = (\l' r' maxV' -> maybe extractBinL (Bin max) maxV' l' r') <$> goL l <*> goR r <*> f max maxV + + goR Tip = pure Tip + goR (Bin min minV l r) = (\minV' l' r' -> maybe extractBinR (Bin min) minV' l' r') <$> f min minV <*> goL l <*> goR r + +-- | Traverse over the entries whose keys are missing from the other +-- map. +-- +-- @since 0.5.9 +{-# INLINE traverseMissing #-} +traverseMissing + :: Applicative f => (Key -> a -> f b) -> WhenMissing f a b +traverseMissing f = WhenMissing + { missingAllL = start + , missingLeft = goL + , missingRight = goR + , missingSingle = \k v -> Just <$> f k v } + where + start Empty = pure Empty + start (NonEmpty min minV root) = NonEmpty min <$> f min minV <*> goL root + + goL Tip = pure Tip + goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f max maxV + + goR Tip = pure Tip + goR (Bin min minV l r) = (\minV' l' r' -> Bin min minV' l' r') <$> f min minV <*> goL l <*> goR r diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 06fe1a477..b145c80bb 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -32,14 +32,13 @@ module Data.IntMap.Merge.Strict ( -- ** Simple merge tactic types - WhenMissing - , WhenMatched + SimpleWhenMissing + , SimpleWhenMatched -- ** General combining function , merge - , mergeA - -- ** @WhenMatched@ tactics + -- *** @WhenMatched@ tactics , zipWithMaybeMatched , zipWithMatched @@ -49,6 +48,28 @@ module Data.IntMap.Merge.Strict ( , mapMissing , mapMaybeMissing , filterMissing + + -- ** Applicative merge tactic types + , WhenMissing + , WhenMatched + + -- ** Applicative general combining function + , mergeA + + -- *** @WhenMatched@ tactics + -- | The tactics described for 'merge' work for + -- 'mergeA' as well. Furthermore, the following + -- are available. + , zipWithMaybeAMatched + , zipWithAMatched + + -- *** @WhenMissing@ tactics + -- | The tactics described for 'merge' work for + -- 'mergeA' as well. Furthermore, the following + -- are available. + , traverseMaybeMissing + , traverseMissing + , filterAMissing ) where import Control.Applicative (Applicative(..)) @@ -158,3 +179,74 @@ zipWithMaybeMatched f = WhenMatched (\k a b -> case f k a b of {-# INLINE zipWithMatched #-} zipWithMatched :: Applicative f => (Key -> a -> b -> c) -> WhenMatched f a b c zipWithMatched f = zipWithMaybeMatched (\k a b -> Just $! f k a b) + +-- | When a key is found in both maps, apply a function to the key +-- and values, perform the resulting action, and maybe use the +-- result in the merged map. +-- +-- This is the fundamental 'WhenMatched' tactic. +-- +-- @since 0.5.9 +{-# INLINE zipWithMaybeAMatched #-} +zipWithMaybeAMatched + :: (Key -> a -> b -> f (Maybe c)) + -> WhenMatched f a b c +zipWithMaybeAMatched f = WhenMatched (\k a b -> f k a b) + +-- | When a key is found in both maps, apply a function to the key +-- and values to produce an action and use its result in the merged +-- map. +-- +-- @since 0.5.9 +{-# INLINE zipWithAMatched #-} +zipWithAMatched + :: Applicative f + => (Key -> a -> b -> f c) + -> WhenMatched f a b c +zipWithAMatched f = zipWithMaybeAMatched (\k a b -> Just <$> f k a b) + +-- | Traverse over the entries whose keys are missing from the other +-- map, optionally producing values to put in the result. This is +-- the most powerful 'WhenMissing' tactic, but others are usually +-- more efficient. +-- +-- @since 0.5.9 +{-# INLINE traverseMaybeMissing #-} +traverseMaybeMissing + :: Applicative f => (Key -> a -> f (Maybe b)) -> WhenMissing f a b +traverseMaybeMissing f = WhenMissing + { missingAllL = start + , missingLeft = goL + , missingRight = goR + , missingSingle = f } + where + start Empty = pure Empty + start (NonEmpty min minV root) = maybe nodeToMapL (NonEmpty min $!) <$> f min minV <*> goL root + + goL Tip = pure Tip + goL (Bin max maxV l r) = (\l' r' maxV' -> maybe extractBinL (Bin max $!) maxV' l' r') <$> goL l <*> goR r <*> f max maxV + + goR Tip = pure Tip + goR (Bin min minV l r) = (\minV' l' r' -> maybe extractBinR (Bin min $!) minV' l' r') <$> f min minV <*> goL l <*> goR r + +-- | Traverse over the entries whose keys are missing from the other +-- map. +-- +-- @since 0.5.9 +{-# INLINE traverseMissing #-} +traverseMissing + :: Applicative f => (Key -> a -> f b) -> WhenMissing f a b +traverseMissing f = WhenMissing + { missingAllL = start + , missingLeft = goL + , missingRight = goR + , missingSingle = \k v -> Just <$> f k v } + where + start Empty = pure Empty + start (NonEmpty min minV root) = (NonEmpty min $!) <$> f min minV <*> goL root + + goL Tip = pure Tip + goL (Bin max maxV l r) = (\l' r' !maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f max maxV + + goR Tip = pure Tip + goR (Bin min minV l r) = (\ !minV' l' r' -> Bin min minV' l' r') <$> f min minV <*> goL l <*> goR r From 1a5c3d3d76b37f68472b2a1369b8fd4f8e6182ae Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 17 Dec 2019 22:53:33 -0600 Subject: [PATCH 037/147] Add miscellaneous functions on tactics (run*) to IntMap.Merge.* --- containers/src/Data/IntMap/Merge/Internal.hs | 16 ++++++++++++++++ containers/src/Data/IntMap/Merge/Lazy.hs | 4 ++++ containers/src/Data/IntMap/Merge/Strict.hs | 4 ++++ 3 files changed, 24 insertions(+) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 8e2bd54d6..f8b75a9cf 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -90,6 +90,14 @@ data WhenMissing f a b = WhenMissing { -- of a function of type @ Key -> a -> Maybe c @. type SimpleWhenMissing = WhenMissing Identity +-- | Along with 'traverseMaybeMissing', witnesses the isomorphism +-- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@. +-- +-- @since 0.5.9 +{-# INLINE runWhenMissing #-} +runWhenMissing :: WhenMissing f a b -> Key -> a -> f (Maybe b) +runWhenMissing = missingSingle + -- | Drop all the entries whose keys are missing from the other -- map. -- @@ -208,6 +216,14 @@ newtype WhenMatched f a b c = WhenMatched { -- of a function of type @ Key -> a -> b -> Maybe c @. type SimpleWhenMatched = WhenMatched Identity +-- | Along with 'zipWithMaybeAMatched', witnesses the isomorphism +-- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@. +-- +-- @since 0.5.9 +{-# INLINE runWhenMatched #-} +runWhenMatched :: WhenMatched f a b c -> Key -> a -> b -> f (Maybe c) +runWhenMatched = matchedSingle + -- | Merge two maps. -- -- @merge@ takes two 'WhenMissing' tactics, a 'WhenMatched' diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 2db46cdc0..15ab754d0 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -70,6 +70,10 @@ module Data.IntMap.Merge.Lazy ( , traverseMaybeMissing , traverseMissing , filterAMissing + + -- ** Miscellaneous functions on tactics + , runWhenMatched + , runWhenMissing ) where import Control.Applicative (Applicative(..)) diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index b145c80bb..5a31c14a7 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -70,6 +70,10 @@ module Data.IntMap.Merge.Strict ( , traverseMaybeMissing , traverseMissing , filterAMissing + + -- ** Miscellaneous functions on tactics + , runWhenMatched + , runWhenMissing ) where import Control.Applicative (Applicative(..)) From fd38f9bead260fea0288f27bdcfceee60a878f81 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 17 Dec 2019 23:49:42 -0600 Subject: [PATCH 038/147] Use some patterns from mergeA to simplify merge slightly --- containers/src/Data/IntMap/Merge/Internal.hs | 139 ++++++------------- 1 file changed, 41 insertions(+), 98 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index f8b75a9cf..839c7823d 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -296,8 +296,8 @@ runWhenMatched = matchedSingle merge :: SimpleWhenMissing a c -> SimpleWhenMissing b c -> SimpleWhenMatched a b c -> IntMap a -> IntMap b -> IntMap c merge miss1 miss2 match = start where start (IntMap Empty) (IntMap Empty) = IntMap Empty - start (IntMap Empty) (IntMap !m2) = IntMap (missAll miss2 m2) - start (IntMap !m1) (IntMap Empty) = IntMap (missAll miss1 m1) + start (IntMap Empty) (IntMap !m2) = IntMap (missAllL miss2 m2) + start (IntMap !m1) (IntMap Empty) = IntMap (missAllL miss1 m1) start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = case missSingle miss1 min1 minV1 of Nothing -> IntMap (goL2 minV2 min1 root1 min2 root2) @@ -339,7 +339,7 @@ merge miss1 miss2 match = start where -- We handle the case of nodes that cover disjoint ranges separately. The property of being disjoint, unlike a lot of things, remains -- constant as we recurse into subnodes, and this representation is particularly good at efficiently detecting it. By assumption, -- min1 > min2, so we don't need to handle the case of min2 > max1. - goL1Keep minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = case missAll miss1 (NonEmpty min1 minV1 n1) of + goL1Keep minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = case missAllL miss1 (NonEmpty min1 minV1 n1) of Empty -> missLeft miss2 n2 NonEmpty min1' minV1' n1' -> case missLeft miss2 n2 of Tip -> insertMinL (xor min1' min2) min1' minV1' n1' @@ -369,19 +369,13 @@ merge miss1 miss2 match = start where -- If we had an optimized goR2 (no keep), then calling using it is more efficient than -- calling goR2Keep and having to extract a new maximum from the result. Therefore, we -- first check if we can keep our existing maximum, and if not, call goR2. - Nothing -> case goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> case missSingle miss2 max2 maxV2 of - Nothing -> case goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) | otherwise -> case matchSingle match max1 maxV1 maxV2 of - Nothing -> case goRFused max1 (Bin min1 minV1 l1 r1) r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goRFused max1 (Bin min1 minV1 l1 r1) r2) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) where {-# INLINE l' #-} @@ -391,19 +385,13 @@ merge miss1 miss2 match = start where -- min1 > min2, so merging the left nodes is easy, but we need to branch to figure out which right merging function to call -- and which maximum to keep. EQ | max1 > max2 -> case missSingle miss1 max1 maxV1 of - Nothing -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 r2) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) | max1 < max2 -> case missSingle miss2 max2 maxV2 of - Nothing -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 r2) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) | otherwise -> case matchSingle match max1 maxV1 maxV2 of - Nothing -> case goRFused max1 r1 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goRFused max1 r1 r2) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) where {-# INLINE l' #-} @@ -423,7 +411,7 @@ merge miss1 miss2 match = start where goL2Keep minV2 !min1 Tip !min2 n2 = case missSingle miss2 min2 minV2 of Nothing -> missLeft miss2 n2 Just minV' -> insertMinL (xor min1 min2) min2 minV' (missLeft miss2 n2) - goL2Keep minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = case missAll miss2 (NonEmpty min2 minV2 n2) of + goL2Keep minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = case missAllL miss2 (NonEmpty min2 minV2 n2) of Empty -> missLeft miss1 n1 NonEmpty min2' minV2' n2' -> case missLeft miss1 n1 of Tip -> insertMinL (xor min1 min2') min2' minV2' n2' @@ -432,37 +420,25 @@ merge miss1 miss2 match = start where goL2Keep minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 min2 < xor min2 max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missRight miss1 r1) | max1 > max2 -> case missSingle miss1 max1 maxV1 of - Nothing -> case goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> case missSingle miss2 max2 maxV2 of - Nothing -> case goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) | otherwise -> case matchSingle match max1 maxV1 maxV2 of - Nothing -> case goRFused max1 r1 (Bin min2 minV2 l2 r2) of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goRFused max1 r1 (Bin min2 minV2 l2 r2)) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 (Bin min2 minV2 l2 r2)) where {-# INLINE l' #-} l' = missLeft miss1 l1 EQ | max1 > max2 -> case missSingle miss1 max1 maxV1 of - Nothing -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 r2) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) | max1 < max2 -> case missSingle miss2 max2 maxV2 of - Nothing -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 r2) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) | otherwise -> case matchSingle match max1 maxV1 maxV2 of - Nothing -> case goRFused max1 r1 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goRFused max1 r1 r2) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) where {-# INLINE l' #-} @@ -487,19 +463,13 @@ merge miss1 miss2 match = start where goLFusedKeep !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of LT -> binL2 max2 maxV2 (goLFusedKeep min n1 l2) (missRight miss2 r2) EQ | max1 > max2 -> case missSingle miss1 max1 maxV1 of - Nothing -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 r2) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) | max1 < max2 -> case missSingle miss2 max2 maxV2 of - Nothing -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 r2) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) | otherwise -> case matchSingle match max1 maxV1 maxV2 of - Nothing -> case goRFused max1 r1 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' + Nothing -> maybeBinL l' (goRFused max1 r1 r2) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) where {-# INLINE l' #-} @@ -515,7 +485,7 @@ merge miss1 miss2 match = start where goR1Keep maxV1 !max1 !n1 !max2 Tip = case missSingle miss1 max1 maxV1 of Nothing -> missRight miss1 n1 Just maxV' -> insertMaxR (xor max1 max2) max1 maxV' (missRight miss1 n1) - goR1Keep maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = case l2rMap (missAll miss1 (r2lMap (NonEmpty max1 maxV1 n1))) of + goR1Keep maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = case missAllR miss1 (NonEmpty max1 maxV1 n1) of Empty -> missRight miss2 n2 NonEmpty max1' maxV1' n1' -> case missRight miss2 n2 of Tip -> insertMaxR (xor max1' max2) max1' maxV1' n1' @@ -524,37 +494,25 @@ merge miss1 miss2 match = start where goR1Keep maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of LT | xor min2 max1 > xor max1 max2 -> binR2 min2 minV2 (missLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) | min1 < min2 -> case missSingle miss1 min1 minV1 of - Nothing -> case goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' | min1 > min2 -> case missSingle miss2 min2 minV2 of - Nothing -> case goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' | otherwise -> case matchSingle match min1 minV1 minV2 of - Nothing -> case goLFused min1 (Bin max1 maxV1 l1 r1) l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) r' where {-# INLINE r' #-} r' = missRight miss2 r2 EQ | min1 < min2 -> case missSingle miss1 min1 minV1 of - Nothing -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 l2) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' | min1 > min2 -> case missSingle miss2 min2 minV2 of - Nothing -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 l2) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' | otherwise -> case matchSingle match min1 minV1 minV2 of - Nothing -> case goLFused min1 l1 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goLFused min1 l1 l2) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' where {-# INLINE r' #-} @@ -570,7 +528,7 @@ merge miss1 miss2 match = start where goR2Keep maxV2 !max1 Tip !max2 n2 = case missSingle miss2 max2 maxV2 of Nothing -> missRight miss2 n2 Just maxV' -> insertMaxR (xor max1 max2) max2 maxV' (missRight miss2 n2) - goR2Keep maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = case l2rMap (missAll miss2 (r2lMap (NonEmpty max2 maxV2 n2))) of + goR2Keep maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = case missAllR miss2 (NonEmpty max2 maxV2 n2) of Empty -> missRight miss1 n1 NonEmpty max2' maxV2' n2' -> case missRight miss1 n1 of Tip -> insertMaxR (xor max1 max2') max2' maxV2' n2' @@ -579,37 +537,25 @@ merge miss1 miss2 match = start where goR2Keep maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of GT | xor min1 max2 > xor max2 max1 -> binR1 min1 minV1 (missLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) | min1 < min2 -> case missSingle miss1 min1 minV1 of - Nothing -> case goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' | min1 > min2 -> case missSingle miss2 min2 minV2 of - Nothing -> case goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' | otherwise -> case matchSingle match min1 minV1 minV2 of - Nothing -> case goLFused min1 l1 (Bin max2 maxV2 l2 r2) of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 (Bin max2 maxV2 l2 r2)) r' where {-# INLINE r' #-} r' = missRight miss1 r1 EQ | min1 < min2 -> case missSingle miss1 min1 minV1 of - Nothing -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 l2) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' | min1 > min2 -> case missSingle miss2 min2 minV2 of - Nothing -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 l2) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' | otherwise -> case matchSingle match min1 minV1 minV2 of - Nothing -> case goLFused min1 l1 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goLFused min1 l1 l2) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' where {-# INLINE r' #-} @@ -622,19 +568,13 @@ merge miss1 miss2 match = start where goRFusedKeep !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of LT -> binR2 min2 minV2 (missLeft miss2 l2) (goRFusedKeep max n1 r2) EQ | min1 < min2 -> case missSingle miss1 min1 minV1 of - Nothing -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 l2) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' | min1 > min2 -> case missSingle miss2 min2 minV2 of - Nothing -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 l2) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' | otherwise -> case matchSingle match min1 minV1 minV2 of - Nothing -> case goLFused min1 l1 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' + Nothing -> maybeBinR (goLFused min1 l1 l2) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' where {-# INLINE r' #-} @@ -748,8 +688,11 @@ merge miss1 miss2 match = start where {-# INLINE missRight #-} missRight whenMiss r = runIdentity (missingRight whenMiss r) - {-# INLINE missAll #-} - missAll whenMiss m = runIdentity (missingAllL whenMiss m) + {-# INLINE missAllL #-} + missAllL whenMiss m = runIdentity (missingAllL whenMiss m) + + {-# INLINE missAllR #-} + missAllR whenMiss m = l2rMap (missAllL whenMiss (r2lMap m)) {-# INLINE matchSingle #-} matchSingle whenMatch k v1 v2 = runIdentity (matchedSingle whenMatch k v1 v2) From 05b357fd5626d87803eea5150b1c9bfb067e6f25 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 25 Dec 2019 18:26:05 -0600 Subject: [PATCH 039/147] When testing IntMap's merge, print out the tree structure of the counterexamples on failure --- containers-tests/tests/intmap-properties.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 105c33ab5..811f57524 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -229,6 +229,13 @@ newtype NonEmptyIntMap a = NonEmptyIntMap {getNonEmptyIntMap :: IntMap a} derivi instance Arbitrary a => Arbitrary (NonEmptyIntMap a) where arbitrary = fmap (NonEmptyIntMap . fromList . getNonEmpty) arbitrary +newtype PrettyIntMap a = PIM { unPIM :: IntMap a } deriving (Eq) + +instance Arbitrary a => Arbitrary (PrettyIntMap a) where + arbitrary = fmap PIM arbitrary + +instance Show a => Show (PrettyIntMap a) where + show (PIM m) = (if valid m then "\n" else "\nINVALID:\n") ++ showTree m ------------------------------------------------------------------------ @@ -1272,7 +1279,10 @@ prop_intersectionEqMerge :: UMap -> UMap -> Property prop_intersectionEqMerge m1 m2 = intersection m1 m2 === merge dropMissing dropMissing (zipWithMatched (\_ x _ -> x)) m1 m2 prop_mergeEqMergeA :: Fun Int Bool -> Fun Int Bool -> Fun Int Bool -> UMap -> UMap -> Property -prop_mergeEqMergeA pMiss1 pMiss2 pMatch m1 m2 = merge whenMiss1 whenMiss2 whenMatch m1 m2 === runIdentity (mergeA whenMiss1 whenMiss2 whenMatch m1 m2) where +prop_mergeEqMergeA pMiss1 pMiss2 pMatch m1 m2 = PIM merged === PIM mergedA where + merged = merge whenMiss1 whenMiss2 whenMatch m1 m2 + mergedA = runIdentity (mergeA whenMiss1 whenMiss2 whenMatch m1 m2) + whenMiss1 = mapMaybeMissing (\k _ -> if apply pMiss1 k then Just () else Nothing) whenMiss2 = mapMaybeMissing (\k _ -> if apply pMiss2 k then Just () else Nothing) whenMatch = zipWithMaybeMatched (\k _ _ -> if apply pMatch k then Just () else Nothing) From b8e70a0233e82eff987476c058b79610f1d1bdd9 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 25 Dec 2019 18:29:58 -0600 Subject: [PATCH 040/147] Fix rebase errors (conflicting Identity, deleted traverseMaybeWithKey) --- containers-tests/tests/intmap-properties.hs | 38 +++------------------ 1 file changed, 5 insertions(+), 33 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 811f57524..697d34807 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -14,11 +14,15 @@ import Control.Applicative (Applicative(..)) import Data.Monoid import Data.Maybe hiding (mapMaybe) import qualified Data.Maybe as Maybe (mapMaybe) -import Data.Functor.Identity import Data.Ord import Data.Foldable (foldMap) import Data.Function import Data.Traversable (Traversable(traverse), foldMapDefault) +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity (Identity(..)) +#else +import Data.IntMap.Merge.Internal (Identity(..)) +#endif import Prelude hiding (lookup, null, map, filter, foldr, foldl) import qualified Prelude (map) @@ -205,9 +209,6 @@ main = defaultMain , testProperty "withoutKeys" prop_withoutKeys , testProperty "traverseWithKey identity" prop_traverseWithKey_identity , testProperty "traverseWithKey->mapWithKey" prop_traverseWithKey_degrade_to_mapWithKey - , testProperty "traverseMaybeWithKey identity" prop_traverseMaybeWithKey_identity - , testProperty "traverseMaybeWithKey->mapMaybeWithKey" prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey - , testProperty "traverseMaybeWithKey->traverseWithKey" prop_traverseMaybeWithKey_degrade_to_traverseWithKey ] apply2 :: Fun (a, b) c -> a -> b -> c @@ -1540,16 +1541,6 @@ prop_fromSet ys = let xs = List.nubBy ((==) `on` fst) ys in fromSet (\k -> fromJust $ List.lookup k xs) (IntSet.fromList $ List.map fst xs) == fromList xs -newtype Identity a = Identity a - deriving (Eq, Show) - -instance Functor Identity where - fmap f (Identity a) = Identity (f a) - -instance Applicative Identity where - pure a = Identity a - Identity f <*> Identity a = Identity (f a) - prop_traverseWithKey_identity :: IntMap A -> Property prop_traverseWithKey_identity mp = mp === newMap where Identity newMap = traverseWithKey (\_ -> Identity) mp @@ -1560,22 +1551,3 @@ prop_traverseWithKey_degrade_to_mapWithKey fun mp = where f = applyFun2 fun g k v = Identity $ f k v Identity newMap = traverseWithKey g mp - -prop_traverseMaybeWithKey_identity :: IntMap A -> Property -prop_traverseMaybeWithKey_identity mp = mp === newMap - where Identity newMap = traverseMaybeWithKey (\_ -> Identity . Just) mp - -prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey :: Fun (Int, A) (Maybe B) -> IntMap A -> Property -prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey fun mp = - mapMaybeWithKey f mp === newMap - where f = applyFun2 fun - g k v = Identity $ f k v - Identity newMap = traverseMaybeWithKey g mp - -prop_traverseMaybeWithKey_degrade_to_traverseWithKey :: Fun (Int, A) B -> IntMap A -> Property -prop_traverseMaybeWithKey_degrade_to_traverseWithKey fun mp = - traverseWithKey f mp === traverseMaybeWithKey g mp - -- used (,) since its Applicative is monoidal in the left argument, - -- so this also checks the order of traversing is the same. - where f k v = (show k, applyFun2 fun k v) - g k v = fmap Just $ f k v From fa15d439594c18252110b29af1c0066588540609 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 25 Dec 2019 18:47:39 -0600 Subject: [PATCH 041/147] Statically track whether keys in an IntMap are acting as a minimum (Bound L) or as a maximum (Bound R). This makes some things more verbose, but should catch easy-to-make programming errors. --- containers-tests/tests/IntMapValidity.hs | 20 +- containers/src/Data/IntMap/Internal.hs | 698 ++++++++++--------- containers/src/Data/IntMap/Internal/Debug.hs | 4 +- containers/src/Data/IntMap/Lazy.hs | 506 +++++++------- containers/src/Data/IntMap/Merge/Internal.hs | 398 +++++------ containers/src/Data/IntMap/Merge/Lazy.hs | 32 +- containers/src/Data/IntMap/Merge/Strict.hs | 32 +- containers/src/Data/IntMap/Strict.hs | 506 +++++++------- 8 files changed, 1120 insertions(+), 1076 deletions(-) diff --git a/containers-tests/tests/IntMapValidity.hs b/containers-tests/tests/IntMapValidity.hs index 789da2340..49b99c0fc 100644 --- a/containers-tests/tests/IntMapValidity.hs +++ b/containers-tests/tests/IntMapValidity.hs @@ -12,26 +12,26 @@ valid :: IntMap a -> Bool valid = start where start (IntMap Empty) = True - start (IntMap (NonEmpty min _ root)) = allKeys (> min) root && goL min root + start (IntMap (NonEmpty min _ root)) = allKeys (> boundKey min) root && goL min root goL _ Tip = True goL min (Bin max _ l r) = - allKeys (< max) l - && allKeys (< max) r - && allKeys (\k -> xor min k < xor k max) l - && allKeys (\k -> xor min k > xor k max) r + allKeys (< boundKey max) l + && allKeys (< boundKey max) r + && allKeys (\k -> xor k min < xor k max) l + && allKeys (\k -> xor k min > xor k max) r && goL min l && goR max r goR _ Tip = True goR max (Bin min _ l r) = - allKeys (> min) l - && allKeys (> min) r - && allKeys (\k -> xor min k < xor k max) l - && allKeys (\k -> xor min k > xor k max) r + allKeys (> boundKey min) l + && allKeys (> boundKey min) r + && allKeys (\k -> xor k min < xor k max) l + && allKeys (\k -> xor k min > xor k max) r && goL min l && goR max r allKeys :: (Key -> Bool) -> Node t a -> Bool allKeys _ Tip = True - allKeys p (Bin b _ l r) = p b && allKeys p l && allKeys p r + allKeys p (Bin b _ l r) = p (boundKey b) && allKeys p l && allKeys p r diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 045cd13f8..74714d846 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns, TypeFamilies #-} #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Safe #-} #endif @@ -72,18 +72,54 @@ i2w :: Int -> Word i2w = fromIntegral -- We need to compare xors using unsigned comparisons -xor :: Key -> Key -> Word -xor a b = Data.Bits.xor (i2w a) (i2w b) +{-# INLINE xor #-} +xor :: Key -> Bound t -> Word +xor a (Bound b) = Data.Bits.xor (i2w a) (i2w b) + +{-# INLINE xorBounds #-} +xorBounds :: Bound L -> Bound R -> Word +xorBounds (Bound min) (Bound max) = Data.Bits.xor (i2w min) (i2w max) + +{-# INLINE boundsDisjoint #-} +boundsDisjoint :: Bound L -> Bound R -> Bool +boundsDisjoint (Bound min) (Bound max) = min > max -- Phantom types used to separate the types of left and right nodes. -- They are uninhabited simply to ensure that they are only used as type parameters. newtype L = L L newtype R = R R +#if 1 +-- TODO: If we are relying on GHC features anyway, L and R could be a new kind. +newtype Bound t = Bound { boundKey :: Key } deriving (Eq, Ord, Show) + +type family Flipped t +type instance Flipped L = R +type instance Flipped R = L +#else +-- Without type families, we can't track min vs. max correctly, so we just don't by making that parameter ignored +type Bound t = Bound_ +newtype Bound_ = Bound { boundKey :: Key } deriving (Eq, Ord, Show) +-- This, like L and R, is uninhabited to ensure that it is only used as a type parameter +newtype Flipped t = Flipped (Flipped t) +#endif + +inMinBound :: Key -> Bound L -> Bool +inMinBound k (Bound min) = k > min + +inMaxBound :: Key -> Bound R -> Bool +inMaxBound k (Bound max) = k < max + +outOfMinBound :: Key -> Bound L -> Bool +outOfMinBound k (Bound min) = k < min + +outOfMaxBound :: Key -> Bound R -> Bool +outOfMaxBound k (Bound max) = k > max + -- | A map of integers to values @a@. newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) -data IntMap_ t a = NonEmpty {-# UNPACK #-} !Key a !(Node t a) | Empty deriving (Eq) -data Node t a = Bin {-# UNPACK #-} !Key a !(Node L a) !(Node R a) | Tip deriving (Eq, Show) +data IntMap_ t a = NonEmpty {-# UNPACK #-} !(Bound t) a !(Node t a) | Empty deriving (Eq) +data Node t a = Bin {-# UNPACK #-} !(Bound (Flipped t)) a !(Node L a) !(Node R a) | Tip deriving (Eq, Show) instance Show a => Show (IntMap a) where show m = "fromList " ++ show (toList m) @@ -199,27 +235,27 @@ member k = k `seq` start where start (IntMap Empty) = False start (IntMap (NonEmpty min _ node)) - | k < min = False - | k == min = True - | otherwise = goL (xor min k) node + | outOfMinBound k min = False + | k == boundKey min = True + | otherwise = goL (xor k min) node goL !_ Tip = False goL !xorCache (Bin max _ l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goL xorCache l else goR xorCacheMax r - | k > max = False + | outOfMaxBound k max = False | otherwise = True where xorCacheMax = xor k max goR !_ Tip = False goR !xorCache (Bin min _ l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goR xorCache r else goL xorCacheMin l - | k < min = False + | outOfMinBound k min = False | otherwise = True - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Is the key not a member of the map? -- @@ -230,27 +266,27 @@ notMember k = k `seq` start where start (IntMap Empty) = True start (IntMap (NonEmpty min _ node)) - | k < min = True - | k == min = False - | otherwise = goL (xor min k) node + | outOfMinBound k min = True + | k == boundKey min = False + | otherwise = goL (xor k min) node goL !_ Tip = True goL !xorCache (Bin max _ l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goL xorCache l else goR xorCacheMax r - | k > max = True + | outOfMaxBound k max = True | otherwise = False where xorCacheMax = xor k max goR !_ Tip = True goR !xorCache (Bin min _ l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goR xorCache r else goL xorCacheMin l - | k < min = True + | outOfMinBound k min = True | otherwise = False - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'. lookup :: Key -> IntMap a -> Maybe a @@ -258,27 +294,27 @@ lookup k = k `seq` start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV node)) - | k < min = Nothing - | k == min = Just minV - | otherwise = goL (xor min k) node + | outOfMinBound k min = Nothing + | k == boundKey min = Just minV + | otherwise = goL (xor k min) node goL !_ Tip = Nothing goL !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goL xorCache l else goR xorCacheMax r - | k > max = Nothing + | outOfMaxBound k max = Nothing | otherwise = Just maxV where xorCacheMax = xor k max goR !_ Tip = Nothing goR !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goR xorCache r else goL xorCacheMin l - | k < min = Nothing + | outOfMinBound k min = Nothing | otherwise = Just minV - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. The expression @'findWithDefault' def k map@ -- returns the value at key @k@ or returns @def@ when the key is not an @@ -291,27 +327,27 @@ findWithDefault def k = k `seq` start where start (IntMap Empty) = def start (IntMap (NonEmpty min minV node)) - | k < min = def - | k == min = minV - | otherwise = goL (xor min k) node + | outOfMinBound k min = def + | k == boundKey min = minV + | otherwise = goL (xor k min) node goL !_ Tip = def goL !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goL xorCache l else goR xorCacheMax r - | k > max = def + | outOfMaxBound k max = def | otherwise = maxV where xorCacheMax = xor k max goR !_ Tip = def goR !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goR xorCache r else goL xorCacheMin l - | k < min = def + | outOfMinBound k min = def | otherwise = minV - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(log n)/. Find largest key smaller than the given one and return the -- corresponding (key, value) pair. @@ -323,12 +359,12 @@ lookupLT k = k `seq` start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV node)) - | min >= k = Nothing - | otherwise = Just (goL (xor min k) min minV node) + | boundKey min >= k = Nothing + | otherwise = Just (goL (xor k min) min minV node) - goL !_ min minV Tip = (min, minV) + goL !_ min minV Tip = (boundKey min, minV) goL !xorCache min minV (Bin max maxV l r) - | max < k = (max, maxV) + | boundKey max < k = (boundKey max, maxV) | xorCache < xorCacheMax = goL xorCache min minV l | otherwise = goR xorCacheMax r min minV l where @@ -336,14 +372,14 @@ lookupLT k = k `seq` start goR !_ Tip fMin fMinV fallback = getMax fMin fMinV fallback goR !xorCache (Bin min minV l r) fMin fMinV fallback - | min >= k = getMax fMin fMinV fallback + | boundKey min >= k = getMax fMin fMinV fallback | xorCache < xorCacheMin = goR xorCache r min minV l | otherwise = goL xorCacheMin min minV l where - xorCacheMin = xor min k + xorCacheMin = xor k min - getMax min minV Tip = (min, minV) - getMax _ _ (Bin max maxV _ _) = (max, maxV) + getMax min minV Tip = (boundKey min, minV) + getMax _ _ (Bin max maxV _ _) = (boundKey max, maxV) -- | /O(log n)/. Find largest key smaller or equal to the given one and return -- the corresponding (key, value) pair. @@ -356,12 +392,12 @@ lookupLE k = k `seq` start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV node)) - | min > k = Nothing - | otherwise = Just (goL (xor min k) min minV node) + | boundKey min > k = Nothing + | otherwise = Just (goL (xor k min) min minV node) - goL !_ min minV Tip = (min, minV) + goL !_ min minV Tip = (boundKey min, minV) goL !xorCache min minV (Bin max maxV l r) - | max <= k = (max, maxV) + | boundKey max <= k = (boundKey max, maxV) | xorCache < xorCacheMax = goL xorCache min minV l | otherwise = goR xorCacheMax r min minV l where @@ -369,14 +405,14 @@ lookupLE k = k `seq` start goR !_ Tip fMin fMinV fallback = getMax fMin fMinV fallback goR !xorCache (Bin min minV l r) fMin fMinV fallback - | min > k = getMax fMin fMinV fallback + | boundKey min > k = getMax fMin fMinV fallback | xorCache < xorCacheMin = goR xorCache r min minV l | otherwise = goL xorCacheMin min minV l where - xorCacheMin = xor min k + xorCacheMin = xor k min - getMax min minV Tip = (min, minV) - getMax _ _ (Bin max maxV _ _) = (max, maxV) + getMax min minV Tip = (boundKey min, minV) + getMax _ _ (Bin max maxV _ _) = (boundKey max, maxV) -- | /O(log n)/. Find smallest key greater than the given one and return the -- corresponding (key, value) pair. @@ -388,30 +424,30 @@ lookupGT k = k `seq` start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV Tip)) - | min <= k = Nothing - | otherwise = Just (min, minV) + | boundKey min <= k = Nothing + | otherwise = Just (boundKey min, minV) start (IntMap (NonEmpty min minV (Bin max maxV l r))) - | max <= k = Nothing + | boundKey max <= k = Nothing | otherwise = Just (goR (xor k max) max maxV (Bin min minV l r)) goL !_ Tip fMax fMaxV fallback = getMin fMax fMaxV fallback goL !xorCache (Bin max maxV l r) fMax fMaxV fallback - | max <= k = getMin fMax fMaxV fallback + | boundKey max <= k = getMin fMax fMaxV fallback | xorCache < xorCacheMax = goL xorCache l max maxV r | otherwise = goR xorCacheMax max maxV r where xorCacheMax = xor k max - goR !_ max maxV Tip = (max, maxV) + goR !_ max maxV Tip = (boundKey max, maxV) goR !xorCache max maxV (Bin min minV l r) - | min > k = (min, minV) + | boundKey min > k = (boundKey min, minV) | xorCache < xorCacheMin = goR xorCache max maxV r | otherwise = goL xorCacheMin l max maxV r where - xorCacheMin = xor min k + xorCacheMin = xor k min - getMin max maxV Tip = (max, maxV) - getMin _ _ (Bin min minV _ _) = (min, minV) + getMin max maxV Tip = (boundKey max, maxV) + getMin _ _ (Bin min minV _ _) = (boundKey min, minV) -- | /O(log n)/. Find smallest key greater or equal to the given one and return -- the corresponding (key, value) pair. @@ -424,30 +460,30 @@ lookupGE k = k `seq` start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV Tip)) - | min < k = Nothing - | otherwise = Just (min, minV) + | boundKey min < k = Nothing + | otherwise = Just (boundKey min, minV) start (IntMap (NonEmpty min minV (Bin max maxV l r))) - | max < k = Nothing + | boundKey max < k = Nothing | otherwise = Just (goR (xor k max) max maxV (Bin min minV l r)) goL !_ Tip fMax fMaxV fallback = getMin fMax fMaxV fallback goL !xorCache (Bin max maxV l r) fMax fMaxV fallback - | max < k = getMin fMax fMaxV fallback + | boundKey max < k = getMin fMax fMaxV fallback | xorCache < xorCacheMax = goL xorCache l max maxV r | otherwise = goR xorCacheMax max maxV r where xorCacheMax = xor k max - goR !_ max maxV Tip = (max, maxV) + goR !_ max maxV Tip = (boundKey max, maxV) goR !xorCache max maxV (Bin min minV l r) - | min >= k = (min, minV) + | boundKey min >= k = (boundKey min, minV) | xorCache < xorCacheMin = goR xorCache max maxV r | otherwise = goL xorCacheMin l max maxV r where - xorCacheMin = xor min k + xorCacheMin = xor k min - getMin max maxV Tip = (max, maxV) - getMin _ _ (Bin min minV _ _) = (min, minV) + getMin max maxV Tip = (boundKey max, maxV) + getMin _ _ (Bin min minV _ _) = (boundKey min, minV) -- | /O(1)/. The empty map. -- @@ -463,19 +499,19 @@ delete k = k `seq` start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min _ Tip)) - | k == min = IntMap Empty + | k == boundKey min = IntMap Empty | otherwise = m start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | k < min = m - | k == min = let DR min' minV' root' = deleteMinL max maxV l r in IntMap (NonEmpty min' minV' root') - | otherwise = IntMap (NonEmpty min minV (deleteL k (xor min k) root)) + | outOfMinBound k min = m + | k == boundKey min = let DR min' minV' root' = deleteMinL max maxV l r in IntMap (NonEmpty min' minV' root') + | otherwise = IntMap (NonEmpty min minV (deleteL k (xor k min) root)) -- TODO: Does a strict pair work? My guess is not, as GHC was already -- unboxing the tuple, but it would be simpler to use one of those. -- | Without this specialized type (I was just using a tuple), GHC's -- CPR correctly unboxed the tuple, but it couldn't unbox the returned -- Key, leading to lots of inefficiency (3x slower than stock Data.IntMap) -data DeleteResult t a = DR {-# UNPACK #-} !Key a !(Node t a) +data DeleteResult t a = DR {-# UNPACK #-} !(Bound t) a !(Node t a) -- | /O(n+m)/. The (left-biased) union of two maps. -- It prefers the first map when duplicate keys are encountered, @@ -492,12 +528,12 @@ union = start | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) | otherwise = IntMap (NonEmpty min1 minV1 (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 - goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip - goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL minV1 min2 n2 min1 n1 - goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 - goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min1 min2 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + goL1 minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip + goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = unionDisjointL minV1 min2 n2 min1 n1 + goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) | otherwise -> Bin max1 maxV1 l2 (goRFused max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 @@ -506,12 +542,12 @@ union = start | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip - goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL minV2 min1 n1 min2 n2 - goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 - goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + goL2 minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip + goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor (boundKey min2) min1) min2 minV2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = unionDisjointL minV2 min1 n1 min2 n2 + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 + goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) | otherwise -> Bin max1 maxV1 l1 (goRFused max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 @@ -524,19 +560,19 @@ union = start -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' goLFused !_ Tip !n2 = n2 goLFused !_ !n1 Tip = n1 - goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> Bin max1 maxV1 (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip - goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR maxV1 max1 n1 max2 n2 - goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + goR1 maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip + goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor (boundKey max1) max2) max1 maxV1 n1 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = unionDisjointR maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | otherwise -> Bin min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 @@ -545,12 +581,12 @@ union = start | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip - goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR maxV2 max2 n2 max1 n1 - goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 - goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + goR2 maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip + goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor (boundKey max2) max1) max2 maxV2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = unionDisjointR maxV2 max2 n2 max1 n1 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 + goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | otherwise -> Bin min1 minV1 (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 @@ -563,75 +599,75 @@ union = start -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' goRFused !_ Tip n2 = n2 goRFused !_ n1 Tip = n1 - goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> Bin min2 minV2 l2 (goRFused max n1 r2) EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goRFused max r1 n2) - goInsertL1 k v !_ _ Tip = Bin k v Tip Tip + goInsertL1 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertL1 k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goInsertL1 k v xorCache min l) r else Bin max maxV l (goInsertR1 k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v (Bin max maxV l r) Tip + else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max v l r where xorCacheMax = xor k max - goInsertR1 k v !_ _ Tip = Bin k v Tip Tip + goInsertR1 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertR1 k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goInsertR1 k v xorCache max r) else Bin min minV (goInsertL1 k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v Tip (Bin min minV l r) + else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min v l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min - goInsertL2 k v !_ _ Tip = Bin k v Tip Tip + goInsertL2 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertL2 k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goInsertL2 k v xorCache min l) r else Bin max maxV l (goInsertR2 k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v (Bin max maxV l r) Tip + else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max maxV l r where xorCacheMax = xor k max - goInsertR2 k v !_ _ Tip = Bin k v Tip Tip + goInsertR2 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertR2 k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goInsertR2 k v xorCache max r) else Bin min minV (goInsertL2 k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v Tip (Bin min minV l r) + else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min minV l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -unionDisjointL :: a -> Key -> Node L a -> Key -> Node L a -> Node L a +unionDisjointL :: a -> Bound L -> Node L a -> Bound L -> Node L a -> Node L a unionDisjointL _ !_ Tip !_ !_ = error "Data.IntMap.unionDisjoint: impossible" unionDisjointL minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 Tip - | xor min1 max1 < xor min2 max1 = Bin min2 minV2 n1 Tip - | otherwise = Bin min2 minV2 l1 (insertMaxR (xor min2 max1) max1 maxV1 r1) + | xorBounds min1 max1 < xorBounds min2 max1 = Bin (minToMax min2) minV2 n1 Tip + | otherwise = Bin (minToMax min2) minV2 l1 (insertMaxR (xor (boundKey max1) min2) max1 maxV1 r1) unionDisjointL minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 (Bin max2 maxV2 l2 r2) - | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin max2 maxV2 l1 (unionDisjointR maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin max2 maxV2 (unionDisjointL minV2 min1 n1 min2 l2) r2 + | not (xorBounds min1 max1 `ltMSB` xorBounds min1 max2) = Bin max2 maxV2 l1 (unionDisjointR maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | not (xorBounds min2 max2 `ltMSB` xorBounds min1 max2) = Bin max2 maxV2 (unionDisjointL minV2 min1 n1 min2 l2) r2 | otherwise = Bin max2 maxV2 n1 (Bin min2 minV2 l2 r2) -unionDisjointR :: a -> Key -> Node R a -> Key -> Node R a -> Node R a +unionDisjointR :: a -> Bound R -> Node R a -> Bound R -> Node R a -> Node R a unionDisjointR _ !_ !_ !_ Tip = error "Data.IntMap.unionDisjoint: impossible" unionDisjointR maxV1 !max1 Tip !max2 n2@(Bin min2 minV2 l2 r2) - | xor min2 max2 < xor min2 max1 = Bin max1 maxV1 Tip n2 - | otherwise = Bin max1 maxV1 (insertMinL (xor min2 max1) min2 minV2 l2) r2 + | xorBounds min2 max2 < xorBounds min2 max1 = Bin (maxToMin max1) maxV1 Tip n2 + | otherwise = Bin (maxToMin max1) maxV1 (insertMinL (xor (boundKey min2) max1) min2 minV2 l2) r2 unionDisjointR maxV1 !max1 (Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) - | not (xor min2 max2 `ltMSB` xor min1 max2) = Bin min1 minV1 (unionDisjointL minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | not (xor min1 max1 `ltMSB` xor min1 max2) = Bin min1 minV1 l1 (unionDisjointR maxV1 max1 r1 max2 n2) + | not (xorBounds min2 max2 `ltMSB` xorBounds min1 max2) = Bin min1 minV1 (unionDisjointL minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | not (xorBounds min1 max1 `ltMSB` xorBounds min1 max2) = Bin min1 minV1 l1 (unionDisjointR maxV1 max1 r1 max2 n2) | otherwise = Bin min1 minV1 (Bin max1 maxV1 l1 r1) n2 -- | The union of a list of maps. @@ -656,11 +692,11 @@ difference = start | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) | otherwise = IntMap (goLFused min1 root1 root2) - goL1 minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL1 minV1 min1 Tip min2 n2 = goLookupL (boundKey min1) minV1 (xor (boundKey min1) min2) n2 goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 | otherwise -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 @@ -670,9 +706,9 @@ difference = start GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) goL2 !_ Tip !_ !_ = Tip - goL2 min1 n1 min2 Tip = deleteL min2 (xor min1 min2) n1 - goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = n1 - goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goL2 min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 + goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 min1 n1 min2 l2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of @@ -681,7 +717,7 @@ difference = start | otherwise -> case goRFused max1 r1 r2 of Empty -> goL2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' - GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of Empty -> l1 @@ -693,18 +729,18 @@ difference = start goLFused !_ Tip !_ = Empty goLFused !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of DR min' minV' n' -> NonEmpty min' minV' n' - goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of + goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFused min n1 l2 EQ | max1 > max2 -> binL (goLFused min l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) | max1 < max2 -> binL (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> binL (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> binL (goLFused min l1 n2) (NonEmpty max1 maxV1 r1) - goR1 maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR1 maxV1 max1 Tip max2 n2 = goLookupR (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 | otherwise -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 @@ -714,9 +750,9 @@ difference = start GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) goR2 !_ Tip !_ !_ = Tip - goR2 max1 n1 max2 Tip = deleteR max2 (xor max1 max2) n1 - goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = n1 - goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goR2 max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 + goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 max1 n1 max2 r2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of @@ -725,7 +761,7 @@ difference = start | otherwise -> case goLFused min1 l1 l2 of Empty -> goR2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) - GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of Empty -> r1 @@ -737,30 +773,30 @@ difference = start goRFused !_ Tip !_ = Empty goRFused !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of DR max' maxV' n' -> NonEmpty max' maxV' n' - goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFused max n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goRFused max r1 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) | otherwise -> binR (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> binR (NonEmpty min1 minV1 l1) (goRFused max r1 n2) - goLookupL k v !_ Tip = NonEmpty k v Tip + goLookupL k v !_ Tip = NonEmpty (Bound k) v Tip goLookupL k v !xorCache (Bin max _ l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL k v xorCache l else goLookupR k v xorCacheMax r - | k > max = NonEmpty k v Tip + | outOfMaxBound k max = NonEmpty (Bound k) v Tip | otherwise = Empty where xorCacheMax = xor k max - goLookupR k v !_ Tip = NonEmpty k v Tip + goLookupR k v !_ Tip = NonEmpty (Bound k) v Tip goLookupR k v !xorCache (Bin min _ l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR k v xorCache r else goLookupL k v xorCacheMin l - | k < min = NonEmpty k v Tip + | outOfMinBound k min = NonEmpty (Bound k) v Tip | otherwise = Empty - where xorCacheMin = xor min k + where xorCacheMin = xor k min dummyV = error "impossible" @@ -780,10 +816,10 @@ intersection = start -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. goL1 _ !_ !_ !_ Tip = Empty - goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 - goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + goL1 minV1 min1 Tip min2 n2 = goLookupL1 (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = Empty + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ goR2 max1 (Bin min1 minV1 l1 r1) max2 r2 | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 (Bin min1 minV1 l1 r1) r2) @@ -795,23 +831,23 @@ intersection = start GT -> goL1 minV1 min1 l1 min2 n2 goL2 !_ Tip !_ !_ = Empty - goL2 min1 n1 min2 Tip = goLookupL2 min2 (xor min1 min2) n1 - goL2 _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty - goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goL2 min1 n1 min2 Tip = goLookupL2 (boundKey min2) (xor (boundKey min2) min1) n1 + goL2 _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = Empty + goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 min1 n1 min2 l2 EQ | max1 > max2 -> binL (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | max1 < max2 -> binL (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> case goL2 min1 l1 min2 l2 of Empty -> r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2)) - GT | xor min1 min2 < xor min2 max1 -> goL2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> r2lMap $ goR2 max1 r1 max2 (Bin min2 dummyV l2 r2) | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 r1 (Bin min2 dummyV l2 r2)) goLFused !_ Tip !_ = Tip goLFused !_ !_ Tip = Tip - goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xor min max1) (xor min max2) of + goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFused min n1 l2 EQ | max1 > max2 -> case goR2 max1 r1 max2 r2 of Empty -> l' @@ -825,10 +861,10 @@ intersection = start GT -> goLFused min l1 n2 goR1 _ !_ !_ !_ Tip = Empty - goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 - goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + goR1 maxV1 max1 Tip max2 n2 = goLookupR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = Empty + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2 | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) @@ -840,23 +876,23 @@ intersection = start GT -> goR1 maxV1 max1 r1 max2 n2 goR2 !_ Tip !_ !_ = Empty - goR2 max1 n1 max2 Tip = goLookupR2 max2 (xor max1 max2) n1 - goR2 _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty - goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goR2 max1 n1 max2 Tip = goLookupR2 (boundKey max2) (xor (boundKey max2) max1) n1 + goR2 _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = Empty + goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 max1 n1 max2 r2 EQ | min1 < min2 -> binR (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | otherwise -> case goR2 max1 r1 max2 r2 of Empty -> l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') - GT | xor min1 max2 > xor max2 max1 -> goR2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> l2rMap $ goL2 min1 l1 min2 (Bin max2 dummyV l2 r2) | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 l1 (Bin max2 dummyV l2 r2)) goRFused !_ Tip !_ = Tip goRFused !_ !_ Tip = Tip - goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFused max n1 r2 EQ | min1 < min2 -> case goL2 min1 l1 min2 l2 of Empty -> r' @@ -871,39 +907,39 @@ intersection = start goLookupL1 !_ _ !_ Tip = Empty goLookupL1 k v !xorCache (Bin max _ l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL1 k v xorCache l else goLookupR1 k v xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k v Tip + | outOfMaxBound k max = Empty + | otherwise = NonEmpty (Bound k) v Tip where xorCacheMax = xor k max goLookupR1 !_ _ !_ Tip = Empty goLookupR1 k v !xorCache (Bin min _ l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR1 k v xorCache r else goLookupL1 k v xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k v Tip - where xorCacheMin = xor min k + | outOfMinBound k min = Empty + | otherwise = NonEmpty (Bound k) v Tip + where xorCacheMin = xor k min goLookupL2 !_ !_ Tip = Empty goLookupL2 k !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL2 k xorCache l else goLookupR2 k xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k maxV Tip + | outOfMaxBound k max = Empty + | otherwise = NonEmpty (Bound k) maxV Tip where xorCacheMax = xor k max goLookupR2 !_ !_ Tip = Empty goLookupR2 k !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR2 k xorCache r else goLookupL2 k xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k minV Tip - where xorCacheMin = xor min k + | outOfMinBound k min = Empty + | otherwise = NonEmpty (Bound k) minV Tip + where xorCacheMin = xor k min dummyV = error "impossible" @@ -927,12 +963,12 @@ disjoint = start | min1 > min2 = goL min1 root1 min2 root2 | otherwise = False - goL :: Key -> Node L x -> Key -> Node L y -> Bool + goL :: Bound L -> Node L x -> Bound L -> Node L y -> Bool goL !_ !_ !_ Tip = True - goL min1 Tip min2 n2 = goLookupL min1 (xor min1 min2) n2 - goL min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = True - goL min1 n1@(Bin max1 _ l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> goL min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + goL min1 Tip min2 n2 = goLookupL (boundKey min1) (xor (boundKey min1) min2) n2 + goL min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = True + goL min1 n1@(Bin max1 _ l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> goR max2 r2 max1 (Bin min1 dummyV l1 r1) | max1 < max2 -> goR max1 (Bin min1 dummyV l1 r1) max2 r2 | otherwise -> False @@ -941,12 +977,12 @@ disjoint = start | otherwise -> False GT -> goL min1 l1 min2 n2 - goR :: Key -> Node R x -> Key -> Node R y -> Bool + goR :: Bound R -> Node R x -> Bound R -> Node R y -> Bool goR !_ !_ !_ Tip = True - goR max1 Tip max2 n2 = goLookupR max1 (xor max1 max2) n2 - goR max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = True - goR max1 n1@(Bin min1 _ l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> goR max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + goR max1 Tip max2 n2 = goLookupR (boundKey max1) (xor (boundKey max1) max2) n2 + goR max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = True + goR max1 n1@(Bin min1 _ l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> goL min2 l2 min1 (Bin max1 dummyV l1 r1) | min1 > min2 -> goL min1 (Bin max1 dummyV l1 r1) min2 l2 | otherwise -> False @@ -957,21 +993,21 @@ disjoint = start goLookupL !_ !_ Tip = True goLookupL k !xorCache (Bin max _ l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL k xorCache l else goLookupR k xorCacheMax r - | k > max = True + | outOfMaxBound k max = True | otherwise = False where xorCacheMax = xor k max goLookupR !_ !_ Tip = True goLookupR k !xorCache (Bin min _ l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR k xorCache r else goLookupL k xorCacheMin l - | k < min = True + | outOfMinBound k min = True | otherwise = False - where xorCacheMin = xor min k + where xorCacheMin = xor k min dummyV = error "impossible" @@ -1031,13 +1067,13 @@ foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b foldrWithKey f z = start where start (IntMap Empty) = z - start (IntMap (NonEmpty min minV root)) = f min minV (goL root z) + start (IntMap (NonEmpty min minV root)) = f (boundKey min) minV (goL root z) goL Tip acc = acc - goL (Bin max maxV l r) acc = goL l (goR r (f max maxV acc)) + goL (Bin max maxV l r) acc = goL l (goR r (f (boundKey max) maxV acc)) goR Tip acc = acc - goR (Bin min minV l r) acc = f min minV (goL l (goR r acc)) + goR (Bin min minV l r) acc = f (boundKey min) minV (goL l (goR r acc)) -- | /O(n)/. Fold the keys and values in the map using the given left-associative -- binary operator, such that @@ -1053,13 +1089,13 @@ foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a foldlWithKey f z = start where start (IntMap Empty) = z - start (IntMap (NonEmpty min minV root)) = goL (f z min minV) root + start (IntMap (NonEmpty min minV root)) = goL (f z (boundKey min) minV) root goL acc Tip = acc - goL acc (Bin max maxV l r) = f (goR (goL acc l) r) max maxV + goL acc (Bin max maxV l r) = f (goR (goL acc l) r) (boundKey max) maxV goR acc Tip = acc - goR acc (Bin min minV l r) = goR (goL (f acc min minV) l) r + goR acc (Bin min minV l r) = goR (goL (f acc (boundKey min) minV) l) r -- | /O(n)/. Fold the keys and values in the map using the given monoid, such that -- @@ -1070,13 +1106,13 @@ foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m foldMapWithKey f = start where start (IntMap Empty) = mempty - start (IntMap (NonEmpty min minV root)) = f min minV `mappend` goL root + start (IntMap (NonEmpty min minV root)) = f (boundKey min) minV `mappend` goL root goL Tip = mempty - goL (Bin max maxV l r) = goL l `mappend` goR r `mappend` f max maxV + goL (Bin max maxV l r) = goL l `mappend` goR r `mappend` f (boundKey max) maxV goR Tip = mempty - goR (Bin min minV l r) = f min minV `mappend` goL l `mappend` goR r + goR (Bin min minV l r) = f (boundKey min) minV `mappend` goL l `mappend` goR r -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is -- evaluated before using the result in the next application. This @@ -1117,13 +1153,13 @@ foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b foldrWithKey' f z = start where start (IntMap Empty) = z - start (IntMap (NonEmpty min minV root)) = f min minV $! goL root $! z + start (IntMap (NonEmpty min minV root)) = f (boundKey min) minV $! goL root $! z goL Tip acc = acc - goL (Bin max maxV l r) acc = goL l $! goR r $! f max maxV $! acc + goL (Bin max maxV l r) acc = goL l $! goR r $! f (boundKey max) maxV $! acc goR Tip acc = acc - goR (Bin min minV l r) acc = f min minV $! goL l $! goR r $! acc + goR (Bin min minV l r) acc = f (boundKey min) minV $! goL l $! goR r $! acc -- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This @@ -1132,13 +1168,13 @@ foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a foldlWithKey' f z = start where start (IntMap Empty) = z - start (IntMap (NonEmpty min minV root)) = s goL (s f z min minV) root + start (IntMap (NonEmpty min minV root)) = s goL (s f z (boundKey min) minV) root goL acc Tip = acc - goL acc (Bin max maxV l r) = s f (s goR (s goL acc l) r) max maxV + goL acc (Bin max maxV l r) = s f (s goR (s goL acc l) r) (boundKey max) maxV goR acc Tip = acc - goR acc (Bin min minV l r) = s goR (s goL (s f acc min minV) l) r + goR acc (Bin min minV l r) = s goR (s goL (s f acc (boundKey min) minV) l) r s = ($!) @@ -1195,15 +1231,15 @@ toDescList :: IntMap a -> [(Key, a)] toDescList = foldlWithKey (\l k v -> (k, v) : l) [] -- | A stack used in the in-order building of IntMaps. -data BuildStack a = Push {-# UNPACK #-} !Key a !(Node L a) !(BuildStack a) | StackBase +data BuildStack a = Push {-# UNPACK #-} !(Bound L) a !(Node L a) !(BuildStack a) | StackBase pushBuildStack :: Word -> Key -> a -> Node R a -> BuildStack a -> BuildStack a pushBuildStack !xorCache !k v !r (Push min minV l stk) - | xor min k < xorCache = pushBuildStack xorCache k v (Bin min minV l r) stk -pushBuildStack !_ !k v Tip !stk = Push k v Tip stk -pushBuildStack !_ !k v (Bin min minV l r) !stk = Push min minV (Bin k v l r) stk + | xor k min < xorCache = pushBuildStack xorCache k v (Bin min minV l r) stk +pushBuildStack !_ !k v Tip !stk = Push (Bound k) v Tip stk +pushBuildStack !_ !k v (Bin min minV l r) !stk = Push min minV (Bin (Bound k) v l r) stk -completeBuildStack :: Key -> a -> Node R a -> BuildStack a -> IntMap_ L a +completeBuildStack :: Bound R -> a -> Node R a -> BuildStack a -> IntMap_ L a completeBuildStack !max maxV !r StackBase = r2lMap (NonEmpty max maxV r) completeBuildStack !max maxV !r (Push min minV l stk) = completeBuildStack max maxV (Bin min minV l r) stk @@ -1223,37 +1259,37 @@ filterWithKey p = start where start (IntMap Empty) = IntMap Empty start (IntMap (NonEmpty min minV root)) - | p min minV = IntMap (NonEmpty min minV (goL root)) + | p (boundKey min) minV = IntMap (NonEmpty min minV (goL root)) | otherwise = IntMap (goDeleteL root) goL Tip = Tip goL (Bin max maxV l r) - | p max maxV = Bin max maxV (goL l) (goR r) + | p (boundKey max) maxV = Bin max maxV (goL l) (goR r) | otherwise = case goDeleteR r of Empty -> goL l NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' goR Tip = Tip goR (Bin min minV l r) - | p min minV = Bin min minV (goL l) (goR r) + | p (boundKey min) minV = Bin min minV (goL l) (goR r) | otherwise = case goDeleteL l of Empty -> goR r NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) goDeleteL Tip = Empty goDeleteL (Bin max maxV l r) - | p max maxV = case goDeleteL l of + | p (boundKey max) maxV = case goDeleteL l of Empty -> case goR r of - Tip -> NonEmpty max maxV Tip + Tip -> NonEmpty (maxToMin max) maxV Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV l' (goR r)) | otherwise = binL (goDeleteL l) (goDeleteR r) goDeleteR Tip = Empty goDeleteR (Bin min minV l r) - | p min minV = case goDeleteR r of + | p (boundKey min) minV = case goDeleteR r of Empty -> case goL l of - Tip -> NonEmpty min minV Tip + Tip -> NonEmpty (minToMax min) minV Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV (goL l) r') | otherwise = binR (goDeleteL l) (goDeleteR r) @@ -1300,16 +1336,16 @@ partitionWithKey p = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) start (IntMap (NonEmpty min minV root)) - | p min minV = let t :*: f = goTrueL root - in (IntMap (NonEmpty min minV t), IntMap f) + | p (boundKey min) minV = let t :*: f = goTrueL root + in (IntMap (NonEmpty min minV t), IntMap f) | otherwise = let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min minV f)) goTrueL Tip = Tip :*: Empty goTrueL (Bin max maxV l r) - | p max maxV = let tl :*: fl = goTrueL l - tr :*: fr = goTrueR r - in Bin max maxV tl tr :*: binL fl fr + | p (boundKey max) maxV = let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin max maxV tl tr :*: binL fl fr | otherwise = let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of @@ -1322,9 +1358,9 @@ partitionWithKey p = start goTrueR Tip = Tip :*: Empty goTrueR (Bin min minV l r) - | p min minV = let tl :*: fl = goTrueL l - tr :*: fr = goTrueR r - in Bin min minV tl tr :*: binR fl fr + | p (boundKey min) minV = let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin min minV tl tr :*: binR fl fr | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -1337,30 +1373,30 @@ partitionWithKey p = start goFalseL Tip = Empty :*: Tip goFalseL (Bin max maxV l r) - | p max maxV = let tl :*: fl = goFalseL l - tr :*: fr = goTrueR r - t = case tl of - Empty -> r2lMap $ NonEmpty max maxV tr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' tr) - f = case fr of - Empty -> fl - NonEmpty max' maxV' r' -> Bin max' maxV' fl r' - in t :*: f + | p (boundKey max) maxV = let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r + t = case tl of + Empty -> r2lMap $ NonEmpty max maxV tr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' tr) + f = case fr of + Empty -> fl + NonEmpty max' maxV' r' -> Bin max' maxV' fl r' + in t :*: f | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binL tl tr :*: Bin max maxV fl fr goFalseR Tip = Empty :*: Tip goFalseR (Bin min minV l r) - | p min minV = let tl :*: fl = goTrueL l - tr :*: fr = goFalseR r - t = case tr of - Empty -> l2rMap $ NonEmpty min minV tl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV tl r') - f = case fl of - Empty -> fr - NonEmpty min' minV' l' -> Bin min' minV' l' fr - in t :*: f + | p (boundKey min) minV = let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r + t = case tr of + Empty -> l2rMap $ NonEmpty min minV tl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV tl r') + f = case fl of + Empty -> fr + NonEmpty min' minV' l' -> Bin min' minV' l' fr + in t :*: f | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binR tl tr :*: Bin min minV fl fr @@ -1402,15 +1438,15 @@ splitLookup k = k `seq` start where start (IntMap Empty) = (IntMap Empty, Nothing, IntMap Empty) start m@(IntMap (NonEmpty min minV root)) - | k > min = case root of + | inMinBound k min = case root of Tip -> (m, Nothing, IntMap Empty) - Bin max maxV l r | k < max -> let (DR glb glbV lt, eq, DR lub lubV gt) = go (xor min k) min minV (xor k max) max maxV l r + Bin max maxV l r | inMaxBound k max -> let (DR glb glbV lt, eq, DR lub lubV gt) = go (xor k min) min minV (xor k max) max maxV l r in (IntMap (r2lMap (NonEmpty glb glbV lt)), eq, IntMap (NonEmpty lub lubV gt)) - | k > max -> (m, Nothing, IntMap Empty) + | outOfMaxBound k max -> (m, Nothing, IntMap Empty) | otherwise -> let DR max' maxV' root' = deleteMaxR min minV l r in (IntMap (r2lMap (NonEmpty max' maxV' root')), Just maxV, IntMap Empty) - | k < min = (IntMap Empty, Nothing, m) + | outOfMinBound k min = (IntMap Empty, Nothing, m) | otherwise = case root of Tip -> (IntMap Empty, Just minV, IntMap Empty) Bin max maxV l r -> let DR min' minV' root' = deleteMinL max maxV l r @@ -1418,18 +1454,18 @@ splitLookup k = k `seq` start go xorCacheMin min minV xorCacheMax max maxV l r | xorCacheMin < xorCacheMax = case l of - Tip -> (DR min minV Tip, Nothing, r2lDR (DR max maxV r)) + Tip -> (DR (minToMax min) minV Tip, Nothing, r2lDR (DR max maxV r)) Bin maxI maxVI lI rI - | k < maxI -> let (lt, eq, DR minI minVI gt) = go xorCacheMin min minV (xor k maxI) maxI maxVI lI rI + | inMaxBound k maxI -> let (lt, eq, DR minI minVI gt) = go xorCacheMin min minV (xor k maxI) maxI maxVI lI rI in (lt, eq, DR minI minVI (Bin max maxV gt r)) - | k > maxI -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) + | outOfMaxBound k maxI -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) | otherwise -> (deleteMaxR min minV lI rI, Just maxVI, r2lDR (DR max maxV r)) | otherwise = case r of - Tip -> (l2rDR (DR min minV l), Nothing, DR max maxV Tip) + Tip -> (l2rDR (DR min minV l), Nothing, DR (maxToMin max) maxV Tip) Bin minI minVI lI rI - | k > minI -> let (DR maxI maxVI lt, eq, gt) = go (xor minI k) minI minVI xorCacheMax max maxV lI rI + | inMinBound k minI -> let (DR maxI maxVI lt, eq, gt) = go (xor k minI) minI minVI xorCacheMax max maxV lI rI in (DR maxI maxVI (Bin min minV l lt), eq, gt) - | k < minI -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) + | outOfMinBound k minI -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) | otherwise -> (l2rDR (DR min minV l), Just minVI, deleteMinL max maxV lI rI) -- | /O(1)/. Decompose a map into pieces based on the structure of the underlying @@ -1487,15 +1523,15 @@ isSubmapOfBy p = start | min1 > min2 = goL minV1 min1 root1 min2 root2 | otherwise = p minV1 minV2 && goLFused min1 root1 root2 - goL minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL minV1 min1 Tip min2 n2 = goLookupL (boundKey min1) minV1 (xor (boundKey min1) min2) n2 goL _ _ _ _ Tip = False goL minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 (Bin max2 maxV2 l2 r2) | max1 > max2 = False - | max1 < max2 = case xor min1 max1 `ltMSB` xor min2 max2 of - True | xor min2 min1 < xor min1 max2 -> goL minV1 min1 n1 min2 l2 -- LT + | max1 < max2 = case xorBounds min1 max1 `ltMSB` xorBounds min2 max2 of + True | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL minV1 min1 n1 min2 l2 -- LT | otherwise -> goR maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ - | otherwise = p maxV1 maxV2 && case xor min1 max1 `ltMSB` xor min2 max1 of + | otherwise = p maxV1 maxV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max1 of True -> goRFused max1 (Bin min1 minV1 l1 r1) r2 -- LT False -> goL minV1 min1 l1 min2 l2 && goRFused max1 r1 r2 -- EQ @@ -1503,20 +1539,20 @@ isSubmapOfBy p = start goLFused _ _ Tip = False goLFused min n1@(Bin max1 maxV1 l1 r1) (Bin max2 maxV2 l2 r2) | max1 > max2 = False - | max1 < max2 = case xor min max1 `ltMSB` xor min max2 of + | max1 < max2 = case xorBounds min max1 `ltMSB` xorBounds min max2 of True -> goLFused min n1 l2 False -> goLFused min l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ | otherwise = p maxV1 maxV2 && goLFused min l1 l2 && goRFused max1 r1 r2 - goR maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR maxV1 max1 Tip max2 n2 = goLookupR (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 goR _ _ _ _ Tip = False goR maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 (Bin min2 minV2 l2 r2) | min1 < min2 = False - | min1 > min2 = case xor min1 max1 `ltMSB` xor min2 max2 of - True | xor min2 max1 > xor max1 max2 -> goR maxV1 max1 n1 max2 r2 -- LT + | min1 > min2 = case xorBounds min1 max1 `ltMSB` xorBounds min2 max2 of + True | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR maxV1 max1 n1 max2 r2 -- LT | otherwise -> goL minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ - | otherwise = p minV1 minV2 && case xor min1 max1 `ltMSB` xor min2 max1 of + | otherwise = p minV1 minV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max1 of True -> goLFused min1 (Bin max1 maxV1 l1 r1) l2 -- LT False -> goLFused min1 l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ @@ -1524,28 +1560,28 @@ isSubmapOfBy p = start goRFused _ _ Tip = False goRFused max n1@(Bin min1 minV1 l1 r1) (Bin min2 minV2 l2 r2) | min1 < min2 = False - | min1 > min2 = case xor min1 max `ltMSB` xor min2 max of + | min1 > min2 = case xorBounds min1 max `ltMSB` xorBounds min2 max of True -> goRFused max n1 r2 False -> goL minV1 min1 l1 min2 l2 && goRFused max r1 r2 -- EQ | otherwise = p minV1 minV2 && goLFused min1 l1 l2 && goRFused max r1 r2 goLookupL _ _ !_ Tip = False goLookupL k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL k v xorCache l else goLookupR k v xorCacheMax r - | k > max = False + | outOfMaxBound k max = False | otherwise = p v maxV where xorCacheMax = xor k max goLookupR _ _ !_ Tip = False goLookupR k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR k v xorCache r else goLookupL k v xorCacheMin l - | k < min = False + | outOfMinBound k min = False | otherwise = p v minV - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). @@ -1583,15 +1619,15 @@ submapCmp p = start | p minV1 minV2 = goLFused min1 root1 root2 | otherwise = GT - goL minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL minV1 min1 Tip min2 n2 = goLookupL (boundKey min1) minV1 (xor (boundKey min1) min2) n2 goL _ _ _ _ Tip = False goL minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 (Bin max2 maxV2 l2 r2) | max1 > max2 = False - | max1 < max2 = case xor min1 max1 `ltMSB` xor min2 max2 of - True | xor min2 min1 < xor min1 max2 -> goL minV1 min1 n1 min2 l2 -- LT + | max1 < max2 = case xorBounds min1 max1 `ltMSB` xorBounds min2 max2 of + True | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL minV1 min1 n1 min2 l2 -- LT | otherwise -> goR maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ - | otherwise = p maxV1 maxV2 && case xor min1 max1 `ltMSB` xor min2 max1 of + | otherwise = p maxV1 maxV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max1 of True -> goRFusedBool max1 (Bin min1 minV1 l1 r1) r2 -- LT False -> goL minV1 min1 l1 min2 l2 && goRFusedBool max1 r1 r2 -- EQ @@ -1600,7 +1636,7 @@ submapCmp p = start goLFused _ _ Tip = GT goLFused min n1@(Bin max1 maxV1 l1 r1) (Bin max2 maxV2 l2 r2) | max1 > max2 = GT - | max1 < max2 = fromBool $ case xor min max1 `ltMSB` xor min max2 of + | max1 < max2 = fromBool $ case xorBounds min max1 `ltMSB` xorBounds min max2 of True -> goLFusedBool min n1 l2 False -> goLFusedBool min l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ | p maxV1 maxV2 = goLFused min l1 l2 `combine` goRFused max1 r1 r2 @@ -1610,20 +1646,20 @@ submapCmp p = start goLFusedBool _ _ Tip = False goLFusedBool min n1@(Bin max1 maxV1 l1 r1) (Bin max2 maxV2 l2 r2) | max1 > max2 = False - | max1 < max2 = case xor min max1 `ltMSB` xor min max2 of + | max1 < max2 = case xorBounds min max1 `ltMSB` xorBounds min max2 of True -> goLFusedBool min n1 l2 False -> goLFusedBool min l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ | otherwise = p maxV1 maxV2 && goLFusedBool min l1 l2 && goRFusedBool max1 r1 r2 - goR maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR maxV1 max1 Tip max2 n2 = goLookupR (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 goR _ _ _ _ Tip = False goR maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 (Bin min2 minV2 l2 r2) | min1 < min2 = False - | min1 > min2 = case xor min1 max1 `ltMSB` xor min2 max2 of - True | xor min2 max1 > xor max1 max2 -> goR maxV1 max1 n1 max2 r2 -- LT + | min1 > min2 = case xorBounds min1 max1 `ltMSB` xorBounds min2 max2 of + True | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR maxV1 max1 n1 max2 r2 -- LT | otherwise -> goL minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ - | otherwise = p minV1 minV2 && case xor min1 max1 `ltMSB` xor min2 max1 of + | otherwise = p minV1 minV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max1 of True -> goLFusedBool min1 (Bin max1 maxV1 l1 r1) l2 -- LT False -> goLFusedBool min1 l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ @@ -1632,7 +1668,7 @@ submapCmp p = start goRFused _ _ Tip = GT goRFused max n1@(Bin min1 minV1 l1 r1) (Bin min2 minV2 l2 r2) | min1 < min2 = GT - | min1 > min2 = fromBool $ case xor min1 max `ltMSB` xor min2 max of + | min1 > min2 = fromBool $ case xorBounds min1 max `ltMSB` xorBounds min2 max of True -> goRFusedBool max n1 r2 False -> goL minV1 min1 l1 min2 l2 && goRFusedBool max r1 r2 -- EQ | p minV1 minV2 = goLFused min1 l1 l2 `combine` goRFused max r1 r2 @@ -1642,28 +1678,28 @@ submapCmp p = start goRFusedBool _ _ Tip = False goRFusedBool max n1@(Bin min1 minV1 l1 r1) (Bin min2 minV2 l2 r2) | min1 < min2 = False - | min1 > min2 = case xor min1 max `ltMSB` xor min2 max of + | min1 > min2 = case xorBounds min1 max `ltMSB` xorBounds min2 max of True -> goRFusedBool max n1 r2 False -> goL minV1 min1 l1 min2 l2 && goRFusedBool max r1 r2 -- EQ | otherwise = p minV1 minV2 && goLFusedBool min1 l1 l2 && goRFusedBool max r1 r2 goLookupL _ _ !_ Tip = False goLookupL k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL k v xorCache l else goLookupR k v xorCacheMax r - | k > max = False + | outOfMaxBound k max = False | otherwise = p v maxV where xorCacheMax = xor k max goLookupR _ _ !_ Tip = False goLookupR k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR k v xorCache r else goLookupL k v xorCacheMin l - | k < min = False + | outOfMinBound k min = False | otherwise = p v minV - where xorCacheMin = xor min k + where xorCacheMin = xor k min fromBool True = LT fromBool False = GT @@ -1677,26 +1713,26 @@ submapCmp p = start -- | /O(1)/. The minimal key of the map. Returns 'Nothing' if the map is empty. lookupMin :: IntMap a -> Maybe (Key, a) lookupMin (IntMap Empty) = Nothing -lookupMin (IntMap (NonEmpty min minV _)) = Just (min, minV) +lookupMin (IntMap (NonEmpty min minV _)) = Just (boundKey min, minV) -- | /O(1)/. The maximal key of the map. Returns 'Nothing' if the map is empty. lookupMax :: IntMap a -> Maybe (Key, a) lookupMax (IntMap Empty) = Nothing lookupMax (IntMap (NonEmpty min minV root)) = case root of - Tip -> Just (min, minV) - Bin max maxV _ _ -> Just (max, maxV) + Tip -> Just (boundKey min, minV) + Bin max maxV _ _ -> Just (boundKey max, maxV) -- | /O(1)/. The minimal key of the map. findMin :: IntMap a -> (Key, a) findMin (IntMap Empty) = error "findMin: empty map has no minimal element" -findMin (IntMap (NonEmpty min minV _)) = (min, minV) +findMin (IntMap (NonEmpty min minV _)) = (boundKey min, minV) -- | /O(1)/. The maximal key of the map. findMax :: IntMap a -> (Key, a) findMax (IntMap Empty) = error "findMin: empty map has no minimal element" findMax (IntMap (NonEmpty min minV root)) = case root of - Tip -> (min, minV) - Bin max maxV _ _ -> (max, maxV) + Tip -> (boundKey min, minV) + Bin max maxV _ _ -> (boundKey max, maxV) -- | /O(min(n,W))/. Delete the minimal key. Returns an empty map if the map is empty. -- @@ -1784,33 +1820,41 @@ binR Empty r = r binR l Empty = l2rMap l binR (NonEmpty min minV l) (NonEmpty max maxV r) = NonEmpty max maxV (Bin min minV l r) +{-# INLINE minToMax #-} +minToMax :: Bound L -> Bound R +minToMax = Bound . boundKey + +{-# INLINE maxToMin #-} +maxToMin :: Bound R -> Bound L +maxToMin = Bound . boundKey + {-# INLINE l2rMap #-} l2rMap :: IntMap_ L a -> IntMap_ R a l2rMap Empty = Empty -l2rMap (NonEmpty min minV Tip) = NonEmpty min minV Tip +l2rMap (NonEmpty min minV Tip) = NonEmpty (minToMax min) minV Tip l2rMap (NonEmpty min minV (Bin max maxV l r)) = NonEmpty max maxV (Bin min minV l r) {-# INLINE r2lMap #-} r2lMap :: IntMap_ R a -> IntMap_ L a r2lMap Empty = Empty -r2lMap (NonEmpty max maxV Tip) = NonEmpty max maxV Tip +r2lMap (NonEmpty max maxV Tip) = NonEmpty (maxToMin max) maxV Tip r2lMap (NonEmpty max maxV (Bin min minV l r)) = NonEmpty min minV (Bin max maxV l r) {-# INLINE l2rDR #-} l2rDR :: DeleteResult L a -> DeleteResult R a -l2rDR (DR min minV Tip) = DR min minV Tip +l2rDR (DR min minV Tip) = DR (minToMax min) minV Tip l2rDR (DR min minV (Bin max maxV l r)) = DR max maxV (Bin min minV l r) {-# INLINE r2lDR #-} -r2lDR :: DeleteResult t a -> DeleteResult t' a -r2lDR (DR max maxV Tip) = DR max maxV Tip +r2lDR :: DeleteResult R a -> DeleteResult L a +r2lDR (DR max maxV Tip) = DR (maxToMin max) maxV Tip r2lDR (DR max maxV (Bin min minV l r)) = DR min minV (Bin max maxV l r) -- | Insert a key/value pair to a left node where the key is smaller than -- any present in that node. Requires the xor of the inserted key and the -- key immediately prior to it (the minimum bound of the node). -insertMinL :: Word -> Key -> a -> Node L a -> Node L a -insertMinL !_ !min minV Tip = Bin min minV Tip Tip +insertMinL :: Word -> Bound L -> a -> Node L a -> Node L a +insertMinL !_ !min minV Tip = Bin (minToMax min) minV Tip Tip insertMinL !xorCache !min minV (Bin max maxV l r) -- Although the new minimum is not directly passed into 'insertMinL', -- it is captured in the 'xorCache'. We use standard navigation to @@ -1818,22 +1862,22 @@ insertMinL !xorCache !min minV (Bin max maxV l r) -- Since 'min' is, by assumption, smaller than any key in the tree, -- if 'min' is assigned to the right branch than the entire subtree -- must fit in the right branch. Otherwise, we need to continue recursing. - | xor min max < xorCache = Bin max maxV Tip (Bin min minV l r) + | xor (boundKey min) max < xorCache = Bin max maxV Tip (Bin min minV l r) | otherwise = Bin max maxV (insertMinL xorCache min minV l) r -- | Insert a key/value pair to a right node where the key is greater than -- any present in that node. Requires the xor of the inserted key and the -- key immediately following it (the maximum bound of the node). -insertMaxR :: Word -> Key -> a -> Node R a -> Node R a -insertMaxR !_ !max maxV Tip = Bin max maxV Tip Tip +insertMaxR :: Word -> Bound R -> a -> Node R a -> Node R a +insertMaxR !_ !max maxV Tip = Bin (maxToMin max) maxV Tip Tip insertMaxR !xorCache !max maxV (Bin min minV l r) - | xor min max < xorCache = Bin min minV (Bin max maxV l r) Tip + | xor (boundKey max) min < xorCache = Bin min minV (Bin max maxV l r) Tip | otherwise = Bin min minV l (insertMaxR xorCache max maxV r) -- | Delete the minimum key/value pair from an unpacked left node, returning -- a new left node in a DeleteResult. -deleteMinL :: Key -> a -> Node L a -> Node R a -> DeleteResult L a -deleteMinL !max maxV Tip Tip = DR max maxV Tip +deleteMinL :: Bound R -> a -> Node L a -> Node R a -> DeleteResult L a +deleteMinL !max maxV Tip Tip = DR (maxToMin max) maxV Tip deleteMinL !max maxV Tip (Bin min minV l r) = DR min minV (Bin max maxV l r) deleteMinL !max maxV (Bin innerMax innerMaxV innerL innerR) r = let DR min minV inner = deleteMinL innerMax innerMaxV innerL innerR @@ -1841,8 +1885,8 @@ deleteMinL !max maxV (Bin innerMax innerMaxV innerL innerR) r = -- | Delete the maximum key/value pair from an unpacked right node, returning -- a new right node in a DeleteResult. -deleteMaxR :: Key -> a -> Node L a -> Node R a -> DeleteResult R a -deleteMaxR !min minV Tip Tip = DR min minV Tip +deleteMaxR :: Bound L -> a -> Node L a -> Node R a -> DeleteResult R a +deleteMaxR !min minV Tip Tip = DR (minToMax min) minV Tip deleteMaxR !min minV (Bin max maxV l r) Tip = DR max maxV (Bin min minV l r) deleteMaxR !min minV l (Bin innerMin innerMinV innerL innerR) = let DR max maxV inner = deleteMaxR innerMin innerMinV innerL innerR @@ -1879,10 +1923,10 @@ nodeToMapR (Bin min minV innerL innerR) = deleteL :: Key -> Word -> Node L a -> Node L a deleteL !_ !_ Tip = Tip deleteL !k !xorCache n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (deleteL k xorCache l) r else Bin max maxV l (deleteR k xorCacheMax r) - | k > max = n + | outOfMaxBound k max = n | otherwise = extractBinL l r where xorCacheMax = xor k max @@ -1891,9 +1935,9 @@ deleteL !k !xorCache n@(Bin max maxV l r) deleteR :: Key -> Word -> Node R a -> Node R a deleteR !_ !_ Tip = Tip deleteR !k !xorCache n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (deleteR k xorCache r) else Bin min minV (deleteL k xorCacheMin l) r - | k < min = n + | outOfMinBound k min = n | otherwise = extractBinR l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min diff --git a/containers/src/Data/IntMap/Internal/Debug.hs b/containers/src/Data/IntMap/Internal/Debug.hs index c50e1313d..2773c376c 100644 --- a/containers/src/Data/IntMap/Internal/Debug.hs +++ b/containers/src/Data/IntMap/Internal/Debug.hs @@ -10,10 +10,10 @@ import Data.IntMap.Internal showTree :: Show a => IntMap a -> String showTree = unlines . aux where aux (IntMap Empty) = [] - aux (IntMap (NonEmpty min minV node)) = (show min ++ " " ++ show minV) : auxNode False node + aux (IntMap (NonEmpty min minV node)) = (show (boundKey min) ++ " " ++ show minV) : auxNode False node auxNode :: Show a => Bool -> Node t a -> [String] auxNode _ Tip = ["+-."] - auxNode lined (Bin bound val l r) = ["+--" ++ show bound ++ " " ++ show val, prefix : " |"] ++ fmap indent (auxNode True l) ++ [prefix : " |"] ++ fmap indent (auxNode False r) + auxNode lined (Bin bound val l r) = ["+--" ++ show (boundKey bound) ++ " " ++ show val, prefix : " |"] ++ fmap indent (auxNode True l) ++ [prefix : " |"] ++ fmap indent (auxNode False r) where prefix = if lined then '|' else ' ' indent line = prefix : " " ++ line diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 57b20c0ab..047ff4784 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -231,7 +231,7 @@ import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 singleton :: Key -> a -> IntMap a -singleton k v = IntMap (NonEmpty k v Tip) +singleton k v = IntMap (NonEmpty (Bound k) v Tip) -- | /O(min(n,W))/. Insert a new key\/value pair in the map. -- If the key is already present in the map, the associated value is @@ -244,18 +244,18 @@ singleton k v = IntMap (NonEmpty k v Tip) insert :: Key -> a -> IntMap a -> IntMap a insert = start where - start !k v (IntMap Empty) = IntMap (NonEmpty k v Tip) + start !k v (IntMap Empty) = IntMap (NonEmpty (Bound k) v Tip) start !k v (IntMap (NonEmpty min minV root)) - | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) - | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) - | otherwise = IntMap (NonEmpty k v root) + | inMinBound k min = IntMap (NonEmpty min minV (goL k v (xor k min) min root)) + | outOfMinBound k min = IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) + | otherwise = IntMap (NonEmpty (Bound k) v root) -- | Insert a key/value pair into a left node when the key is known to be larger -- than the minimum value of the tree. - goL !k v !_ !_ Tip = Bin k v Tip Tip + goL !k v !_ !_ Tip = Bin (Bound k) v Tip Tip goL !k v !xorCache !min (Bin max maxV l r) -- In the simple case, we just recurse into whichever branch is applicable. - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goL k v xorCache min l) r else Bin max maxV l (goR k v xorCacheMax max r) -- If the key is the new maximum, then we have two cases to consider. If @@ -267,22 +267,22 @@ insert = start -- 'min' is the minimum, and 'k' is the maximum. If 'max' belongs on the -- left side, then the entire old subtree belongs on the left side. If -- 'max' belongs on the right side, then we have to push it down. - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v (Bin max maxV l r) Tip + else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max v l r where xorCacheMax = xor k max - goR !k v !_ !_ Tip = Bin k v Tip Tip + goR !k v !_ !_ Tip = Bin (Bound k) v Tip Tip goR !k v !xorCache !max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goR k v xorCache max r) else Bin min minV (goL k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v Tip (Bin min minV l r) + else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min v l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWith' f key value mp@ @@ -296,33 +296,33 @@ insert = start insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWith = start where - start _ !k v (IntMap Empty) = IntMap (NonEmpty k v Tip) + start _ !k v (IntMap Empty) = IntMap (NonEmpty (Bound k) v Tip) start combine !k v (IntMap (NonEmpty min minV root)) - | k > min = IntMap (NonEmpty min minV (goL combine k v (xor min k) min root)) - | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) - | otherwise = IntMap (NonEmpty k (combine v minV) root) + | inMinBound k min = IntMap (NonEmpty min minV (goL combine k v (xor k min) min root)) + | outOfMinBound k min = IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) + | otherwise = IntMap (NonEmpty (Bound k) (combine v minV) root) - goL _ !k v !_ !_ Tip = Bin k v Tip Tip + goL _ !k v !_ !_ Tip = Bin (Bound k) v Tip Tip goL combine !k v !xorCache !min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goL combine k v xorCache min l) r else Bin max maxV l (goR combine k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v (Bin max maxV l r) Tip + else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max (combine v maxV) l r where xorCacheMax = xor k max - goR _ !k v !_ !_ Tip = Bin k v Tip Tip + goR _ !k v !_ !_ Tip = Bin (Bound k) v Tip Tip goR combine !k v !xorCache !max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goR combine k v xorCache max r) else Bin min minV (goL combine k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v Tip (Bin min minV l r) + else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min (combine v minV) l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWithKey' f key value mp@ @@ -354,38 +354,38 @@ insertWithKey f k = insertWith (f k) k insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) insertLookupWithKey combine !k !v = toPair . start where - start (IntMap Empty) = Nothing :*: IntMap (NonEmpty k v Tip) + start (IntMap Empty) = Nothing :*: IntMap (NonEmpty (Bound k) v Tip) start (IntMap (NonEmpty min minV root)) - | k > min = let mv :*: root' = goL (xor min k) min root + | inMinBound k min = let mv :*: root' = goL (xor k min) min root in mv :*: IntMap (NonEmpty min minV root') - | k < min = Nothing :*: IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) - | otherwise = Just minV :*: IntMap (NonEmpty k (combine k v minV) root) + | outOfMinBound k min = Nothing :*: IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) + | otherwise = Just minV :*: IntMap (NonEmpty (Bound k) (combine k v minV) root) - goL !_ _ Tip = Nothing :*: Bin k v Tip Tip + goL !_ _ Tip = Nothing :*: Bin (Bound k) v Tip Tip goL !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then let mv :*: l' = goL xorCache min l in mv :*: Bin max maxV l' r else let mv :*: r' = goR xorCacheMax max r in mv :*: Bin max maxV l r' - | k > max = if xor min max < xorCacheMax - then Nothing :*: Bin k v (Bin max maxV l r) Tip - else Nothing :*: Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Nothing :*: Bin (Bound k) v (Bin max maxV l r) Tip + else Nothing :*: Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Just maxV :*: Bin max (combine k v maxV) l r where xorCacheMax = xor k max - goR !_ _ Tip = Nothing :*: Bin k v Tip Tip + goR !_ _ Tip = Nothing :*: Bin (Bound k) v Tip Tip goR !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then let mv :*: r' = goR xorCache max r in mv :*: Bin min minV l r' else let mv :*: l' = goL xorCacheMin min l in mv :*: Bin min minV l' r - | k < min = if xor min max < xorCacheMin - then Nothing :*: Bin k v Tip (Bin min minV l r) - else Nothing :*: Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Nothing :*: Bin (Bound k) v Tip (Bin min minV l r) + else Nothing :*: Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Just minV :*: Bin min (combine k v minV) l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. @@ -398,27 +398,27 @@ adjust f k = k `seq` start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV node)) - | k > min = IntMap (NonEmpty min minV (goL (xor min k) min node)) - | k < min = m + | inMinBound k min = IntMap (NonEmpty min minV (goL (xor k min) min node)) + | outOfMinBound k min = m | otherwise = IntMap (NonEmpty min (f minV) node) goL !_ _ Tip = Tip goL !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goL xorCache min l) r else Bin max maxV l (goR xorCacheMax max r) - | k > max = n + | outOfMaxBound k max = n | otherwise = Bin max (f maxV) l r where xorCacheMax = xor k max goR !_ _ Tip = Tip goR !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goR xorCache max r) else Bin min minV (goL xorCacheMin min l) r - | k < min = n + | outOfMinBound k min = n | otherwise = Bin min (f minV) l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. @@ -443,24 +443,24 @@ update f k = k `seq` start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV Tip)) - | k == min = case f minV of + | k == boundKey min = case f minV of Nothing -> IntMap Empty Just minV' -> IntMap (NonEmpty min minV' Tip) | otherwise = m start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | k < min = m - | k == min = case f minV of + | outOfMinBound k min = m + | k == boundKey min = case f minV of Nothing -> let DR min' minV' root' = deleteMinL max maxV l r in IntMap (NonEmpty min' minV' root') Just minV' -> IntMap (NonEmpty min minV' root) - | otherwise = IntMap (NonEmpty min minV (goL (xor min k) min root)) + | otherwise = IntMap (NonEmpty min minV (goL (xor k min) min root)) goL !_ _ Tip = Tip goL !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goL xorCache min l) r else Bin max maxV l (goR xorCacheMax max r) - | k > max = n + | outOfMaxBound k max = n | otherwise = case f maxV of Nothing -> extractBinL l r Just maxV' -> Bin max maxV' l r @@ -468,14 +468,14 @@ update f k = k `seq` start goR !_ _ Tip = Tip goR !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goR xorCache max r) else Bin min minV (goL xorCacheMin min l) r - | k < min = n + | outOfMinBound k min = n | otherwise = case f minV of Nothing -> extractBinR l r Just minV' -> Bin min minV' l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. The expression (@'updateWithKey' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is @@ -502,44 +502,44 @@ updateLookupWithKey f k = k `seq` start where start (IntMap Empty) = (Nothing, IntMap Empty) start m@(IntMap (NonEmpty min minV Tip)) - | k == min = case f min minV of + | k == boundKey min = case f (boundKey min) minV of Nothing -> (Just minV, IntMap Empty) Just minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) | otherwise = (Nothing, m) start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | k < min = (Nothing, m) - | k == min = case f min minV of + | outOfMinBound k min = (Nothing, m) + | k == boundKey min = case f (boundKey min) minV of Nothing -> let DR min' minV' root' = deleteMinL max maxV l r in (Just minV, IntMap (NonEmpty min' minV' root')) Just minV' -> (Just minV, IntMap (NonEmpty min minV' root)) - | otherwise = let (mv, root') = goL (xor min k) min root + | otherwise = let (mv, root') = goL (xor k min) min root in (mv, IntMap (NonEmpty min minV root')) goL !_ _ Tip = (Nothing, Tip) goL !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then let (mv, l') = goL xorCache min l in (mv, Bin max maxV l' r) else let (mv, r') = goR xorCacheMax max r in (mv, Bin max maxV l r') - | k > max = (Nothing, n) - | otherwise = case f max maxV of + | outOfMaxBound k max = (Nothing, n) + | otherwise = case f (boundKey max) maxV of Nothing -> (Just maxV, extractBinL l r) Just maxV' -> (Just maxV, Bin max maxV' l r) where xorCacheMax = xor k max goR !_ _ Tip = (Nothing, Tip) goR !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then let (mv, r') = goR xorCache max r in (mv, Bin min minV l r') else let (mv, l') = goL xorCacheMin min l in (mv, Bin min minV l' r) - | k < min = (Nothing, n) - | otherwise = case f min minV of + | outOfMinBound k min = (Nothing, n) + | otherwise = case f (boundKey min) minV of Nothing -> (Just minV, extractBinR l r) Just minV' -> (Just minV, Bin min minV' l r) - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. @@ -607,129 +607,129 @@ unionWithKey combine = start start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) - | otherwise = IntMap (NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 - - goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip - goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL minV1 min2 n2 min1 n1 - goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 - goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + | otherwise = IntMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + + goL1 minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip + goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = unionDisjointL minV1 min2 n2 min1 n1 + goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> Bin max1 (combine max1 maxV1 maxV2) l2 (goRFused max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) l2 (goRFused max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip - goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL minV2 min1 n1 min2 n2 - goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 - goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + goL2 minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip + goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor (boundKey min2) min1) min2 minV2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = unionDisjointL minV2 min1 n1 min2 n2 + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 + goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> Bin max1 (combine max1 maxV1 maxV2) l1 (goRFused max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) l1 (goRFused max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' goLFused !_ Tip n2 = n2 goLFused !_ n1 Tip = n1 - goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip - goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR maxV1 max1 n1 max2 n2 - goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + goR1 maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip + goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor (boundKey max1) max2) max1 maxV1 n1 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = unionDisjointR maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip - goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR maxV2 max2 n2 max1 n1 - goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 - goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + goR2 maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip + goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor (boundKey max2) max1) max2 maxV2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = unionDisjointR maxV2 max2 n2 max1 n1 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 + goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' goRFused !_ Tip n2 = n2 goRFused !_ n1 Tip = n1 - goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> Bin min2 minV2 l2 (goRFused max n1 r2) EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) - | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goRFused max r1 n2) - goInsertL1 k v !_ _ Tip = Bin k v Tip Tip + goInsertL1 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertL1 k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goInsertL1 k v xorCache min l) r else Bin max maxV l (goInsertR1 k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v (Bin max maxV l r) Tip + else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max (combine k v maxV) l r where xorCacheMax = xor k max - goInsertR1 k v !_ _ Tip = Bin k v Tip Tip + goInsertR1 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertR1 k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goInsertR1 k v xorCache max r) else Bin min minV (goInsertL1 k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v Tip (Bin min minV l r) + else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min (combine k v minV) l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min - goInsertL2 k v !_ _ Tip = Bin k v Tip Tip + goInsertL2 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertL2 k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goInsertL2 k v xorCache min l) r else Bin max maxV l (goInsertR2 k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v (Bin max maxV l r) Tip + else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max (combine k maxV v) l r where xorCacheMax = xor k max - goInsertR2 k v !_ _ Tip = Bin k v Tip Tip + goInsertR2 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertR2 k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goInsertR2 k v xorCache max r) else Bin min minV (goInsertL2 k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v Tip (Bin min minV l r) + else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min (combine k minV v) l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | The union of a list of maps, with a combining operation. -- @@ -762,47 +762,47 @@ differenceWithKey combine = start start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 min1 root1 min2 root2)) | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) - | otherwise = case combine min1 minV1 minV2 of + | otherwise = case combine (boundKey min1) minV1 minV2 of Nothing -> IntMap (goLFused min1 root1 root2) Just minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep min1 root1 root2)) - goL1 minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL1 minV1 min1 Tip min2 n2 = goLookupL (boundKey min1) minV1 (xor (boundKey min1) min2) n2 goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 Just maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) Just maxV1' -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) goL2 !_ Tip !_ !_ = Tip - goL2 min1 n1 min2 Tip = deleteL min2 (xor min1 min2) n1 - goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = n1 - goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goL2 min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 + goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 min1 n1 min2 l2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> goL2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> case goRFused max1 r1 r2 of Empty -> goL2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' Just maxV1' -> Bin max1 maxV1' (goL2 min1 l1 min2 l2) (goRFusedKeep max1 r1 r2) - GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' @@ -813,11 +813,11 @@ differenceWithKey combine = start loop Tip !_ = Empty loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of DR min' minV' n' -> NonEmpty min' minV' n' - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> loop n1 l2 EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 Just maxV1' -> binL (loop l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) @@ -826,56 +826,56 @@ differenceWithKey combine = start where loop n1 Tip = n1 loop Tip !_ = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> loop n1 l2 EQ | max1 > max2 -> Bin max1 maxV1 (loop l1 l2) (goR2 max1 r1 max2 r2) | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> loop l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> case goRFused max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 Empty -> loop l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' Just maxV1' -> Bin max1 maxV1' (loop l1 l2) (goRFusedKeep max1 r1 r2) GT -> Bin max1 maxV1 (loop l1 n2) r1 - goR1 maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR1 maxV1 max1 Tip max2 n2 = goLookupR (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 Just minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (goR1 maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) goR2 !_ Tip !_ !_ = Tip - goR2 max1 n1 max2 Tip = deleteR max2 (xor max1 max2) n1 - goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = n1 - goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goR2 max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 + goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 max1 n1 max2 r2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of Empty -> goR2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> case goLFused min1 l1 l2 of Empty -> goR2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) Just minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (goR2 max1 r1 max2 r2) - GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 @@ -886,11 +886,11 @@ differenceWithKey combine = start loop Tip !_ = Empty loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of DR max' maxV' n' -> NonEmpty max' maxV' n' - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> loop n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (loop r1 r2) GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) @@ -899,40 +899,40 @@ differenceWithKey combine = start where loop n1 Tip = n1 loop Tip !_ = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> loop n1 r2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (loop r1 r2) | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of Empty -> loop r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> case combine min1 minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> case combine (boundKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 Nothing -> case goLFused min1 l1 l2 of Empty -> loop r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) Just minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (loop r1 r2) GT -> Bin min1 minV1 l1 (loop r1 n2) - goLookupL k v !_ Tip = NonEmpty k v Tip + goLookupL k v !_ Tip = NonEmpty (Bound k) v Tip goLookupL k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL k v xorCache l else goLookupR k v xorCacheMax r - | k > max = NonEmpty k v Tip + | outOfMaxBound k max = NonEmpty (Bound k) v Tip | otherwise = case combine k v maxV of Nothing -> Empty - Just v' -> NonEmpty k v' Tip + Just v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max - goLookupR k v !_ Tip = NonEmpty k v Tip + goLookupR k v !_ Tip = NonEmpty (Bound k) v Tip goLookupR k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR k v xorCache r else goLookupL k v xorCacheMin l - | k < min = NonEmpty k v Tip + | outOfMinBound k min = NonEmpty (Bound k) v Tip | otherwise = case combine k v minV of Nothing -> Empty - Just v' -> NonEmpty k v' Tip - where xorCacheMin = xor min k + Just v' -> NonEmpty (Bound k) v' Tip + where xorCacheMin = xor k min dummyV = error "impossible" @@ -954,45 +954,45 @@ intersectionWithKey combine = start start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (goL2 minV2 min1 root1 min2 root2) | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) - | otherwise = IntMap (NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. goL1 _ !_ !_ !_ Tip = Empty - goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 - goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + goL1 minV1 min1 Tip min2 n2 = goLookupL1 (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = Empty + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 (combine max1 maxV1 maxV2) (goRFused max1 (Bin min1 minV1 l1 r1) r2) + | otherwise -> r2lMap $ NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 (combine max1 maxV1 maxV2) (goRFused max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine max1 maxV1 maxV2) l' (goRFused max1 r1 r2)) + Empty -> r2lMap (NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundKey max1) maxV1 maxV2) l' (goRFused max1 r1 r2)) GT -> goL1 minV1 min1 l1 min2 n2 goL2 _ !_ Tip !_ !_ = Empty - goL2 minV2 min1 n1 min2 Tip = goLookupL2 min2 minV2 (xor min1 min2) n1 - goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty - goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goL2 minV2 min1 n1 min2 Tip = goLookupL2 (boundKey min2) minV2 (xor (boundKey min2) min1) n1 + goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = Empty + goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 minV2 min1 n1 min2 l2 EQ | max1 > max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 (combine max1 maxV1 maxV2) (goRFused max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine max1 maxV1 maxV2) l' (goRFused max1 r1 r2)) - GT | xor min1 min2 < xor min2 max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 + Empty -> r2lMap (NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundKey max1) maxV1 maxV2) l' (goRFused max1 r1 r2)) + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> r2lMap $ goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 (combine max1 maxV1 maxV2) (goRFused max1 r1 (Bin min2 minV2 l2 r2)) + | otherwise -> r2lMap $ NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused max1 r1 (Bin min2 minV2 l2 r2)) goLFused min = loop where loop Tip !_ = Tip loop !_ Tip = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> loop n1 l2 EQ | max1 > max2 -> case goR2 maxV2 max1 r1 max2 r2 of Empty -> loop l1 l2 @@ -1000,44 +1000,44 @@ intersectionWithKey combine = start | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> loop l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> Bin max1 (combine max1 maxV1 maxV2) (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> loop l1 n2 goR1 _ !_ !_ !_ Tip = Empty - goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 - goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + goR1 maxV1 max1 Tip max2 n2 = goLookupR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = Empty + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) + | otherwise -> l2rMap $ NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) r') + Empty -> l2rMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) r') GT -> goR1 maxV1 max1 r1 max2 n2 goR2 _ !_ Tip !_ !_ = Empty - goR2 maxV2 max1 n1 max2 Tip = goLookupR2 max2 maxV2 (xor max1 max2) n1 - goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty - goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goR2 maxV2 max1 n1 max2 Tip = goLookupR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 + goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = Empty + goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 maxV2 max1 n1 max2 r2 EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | otherwise -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) r') - GT | xor min1 max2 > xor max2 max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 + Empty -> l2rMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) r') + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> l2rMap $ goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 (combine min1 minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) + | otherwise -> l2rMap $ NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) goRFused max = loop where loop Tip !_ = Tip loop !_ Tip = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> loop n1 r2 EQ | min1 < min2 -> case goL2 minV2 min1 l1 min2 l2 of Empty -> loop r1 r2 @@ -1045,44 +1045,44 @@ intersectionWithKey combine = start | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of Empty -> loop r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> Bin min1 (combine min1 minV1 minV2) (goLFused min1 l1 l2) (loop r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (loop r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> loop r1 n2 goLookupL1 !_ _ !_ Tip = Empty goLookupL1 k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL1 k v xorCache l else goLookupR1 k v xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k (combine k v maxV) Tip + | outOfMaxBound k max = Empty + | otherwise = NonEmpty (Bound k) (combine k v maxV) Tip where xorCacheMax = xor k max goLookupR1 !_ _ !_ Tip = Empty goLookupR1 k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR1 k v xorCache r else goLookupL1 k v xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k (combine k v minV) Tip - where xorCacheMin = xor min k + | outOfMinBound k min = Empty + | otherwise = NonEmpty (Bound k) (combine k v minV) Tip + where xorCacheMin = xor k min goLookupL2 !_ _ !_ Tip = Empty goLookupL2 k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL2 k v xorCache l else goLookupR2 k v xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k (combine k maxV v) Tip + | outOfMaxBound k max = Empty + | otherwise = NonEmpty (Bound k) (combine k maxV v) Tip where xorCacheMax = xor k max goLookupR2 !_ _ !_ Tip = Empty goLookupR2 k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR2 k v xorCache r else goLookupL2 k v xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k (combine k minV v) Tip - where xorCacheMin = xor min k + | outOfMinBound k min = Empty + | otherwise = NonEmpty (Bound k) (combine k minV v) Tip + where xorCacheMin = xor k min -- | /O(n+m)/. An unsafe general combining function. -- @@ -1119,7 +1119,7 @@ intersectionWithKey combine = start -- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@. mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) -> IntMap a -> IntMap b -> IntMap c mergeWithKey matched miss1 miss2 = Merge.merge (Merge.mapMaybeMissing (single miss1)) (Merge.mapMaybeMissing (single miss2)) (Merge.zipWithMaybeMatched matched) where - single miss k v = case miss (IntMap (NonEmpty k v Tip)) of + single miss k v = case miss (IntMap (NonEmpty (Bound k) v Tip)) of IntMap Empty -> Nothing IntMap (NonEmpty _ v' _) -> Just v' @@ -1137,13 +1137,13 @@ mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b mapWithKey f = start where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f min minV) (goL root)) + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f (boundKey min) minV) (goL root)) goL Tip = Tip - goL (Bin k v l r) = Bin k (f k v) (goL l) (goR r) + goL (Bin k v l r) = Bin k (f (boundKey k) v) (goL l) (goR r) goR Tip = Tip - goR (Bin k v l r) = Bin k (f k v) (goL l) (goR r) + goR (Bin k v l r) = Bin k (f (boundKey k) v) (goL l) (goR r) -- | /O(n)/. @@ -1157,13 +1157,13 @@ traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b traverseWithKey f = start where start (IntMap Empty) = pure (IntMap Empty) - start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f min minV <*> goL root + start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f (boundKey min) minV <*> goL root goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f max maxV + goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV goR Tip = pure Tip - goR (Bin min minV l r) = Bin min <$> f min minV <*> goL l <*> goR r + goR (Bin min minV l r) = Bin min <$> f (boundKey min) minV <*> goL l <*> goR r -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. @@ -1183,7 +1183,7 @@ mapAccumWithKey f = start where start a (IntMap Empty) = (a, IntMap Empty) start a (IntMap (NonEmpty min minV root)) = - let (a', minV') = f a min minV + let (a', minV') = f a (boundKey min) minV (a'', root') = goL root a' in (a'', IntMap (NonEmpty min minV' root')) @@ -1191,12 +1191,12 @@ mapAccumWithKey f = start goL (Bin max maxV l r) a = let (a', l') = goL l a (a'', r') = goR r a' - (a''', maxV') = f a'' max maxV + (a''', maxV') = f a'' (boundKey max) maxV in (a''', Bin max maxV' l' r') goR Tip a = (a, Tip) goR (Bin min minV l r) a = - let (a', minV') = f a min minV + let (a', minV') = f a (boundKey min) minV (a'', l') = goL l a' (a''', r') = goR r a'' in (a''', Bin min minV' l' r') @@ -1209,12 +1209,12 @@ mapAccumRWithKey f = start start a (IntMap Empty) = (a, IntMap Empty) start a (IntMap (NonEmpty min minV root)) = let (a', root') = goL root a - (a'', minV') = f a' min minV + (a'', minV') = f a' (boundKey min) minV in (a'', IntMap (NonEmpty min minV' root')) goL Tip a = (a, Tip) goL (Bin max maxV l r) a = - let (a', maxV') = f a max maxV + let (a', maxV') = f a (boundKey max) maxV (a'', r') = goR r a' (a''', l') = goL l a'' in (a''', Bin max maxV' l' r') @@ -1223,7 +1223,7 @@ mapAccumRWithKey f = start goR (Bin min minV l r) a = let (a', r') = goR r a (a'', l') = goL l a' - (a''', minV') = f a'' min minV + (a''', minV') = f a'' (boundKey min) minV in (a''', Bin min minV' l' r') -- | /O(n*min(n,W))/. @@ -1308,10 +1308,10 @@ fromAscList = start where start [] = IntMap Empty start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) - go !k v [] !stk = completeBuildStack k v Tip stk + go !k v [] !stk = completeBuildStack (Bound k) v Tip stk go !k v ((!next, nextV) : rest) !stk | next == k = go k nextV rest stk - | otherwise = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) + | otherwise = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order. @@ -1332,10 +1332,10 @@ fromAscListWithKey f = start where start [] = IntMap Empty start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) - go !k v [] !stk = completeBuildStack k v Tip stk + go !k v [] !stk = completeBuildStack (Bound k) v Tip stk go !k v ((!next, nextV) : rest) !stk | next == k = go k (f k nextV v) rest stk - | otherwise = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) + | otherwise = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. @@ -1347,8 +1347,8 @@ fromDistinctAscList = start where start [] = IntMap Empty start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) - go !k v [] !stk = completeBuildStack k v Tip stk - go !k v ((!next, nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) + go !k v [] !stk = completeBuildStack (Bound k) v Tip stk + go !k v ((!next, nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) -- | /O(n)/. Map values and collect the 'Just' results. -- @@ -1365,38 +1365,38 @@ mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b mapMaybeWithKey f = start where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = case f min minV of + start (IntMap (NonEmpty min minV root)) = case f (boundKey min) minV of Just minV' -> IntMap (NonEmpty min minV' (goL root)) Nothing -> IntMap (goDeleteL root) goL Tip = Tip - goL (Bin max maxV l r) = case f max maxV of + goL (Bin max maxV l r) = case f (boundKey max) maxV of Just maxV' -> Bin max maxV' (goL l) (goR r) Nothing -> case goDeleteR r of Empty -> goL l NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' goR Tip = Tip - goR (Bin min minV l r) = case f min minV of + goR (Bin min minV l r) = case f (boundKey min) minV of Just minV' -> Bin min minV' (goL l) (goR r) Nothing -> case goDeleteL l of Empty -> goR r NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) goDeleteL Tip = Empty - goDeleteL (Bin max maxV l r) = case f max maxV of + goDeleteL (Bin max maxV l r) = case f (boundKey max) maxV of Just maxV' -> case goDeleteL l of Empty -> case goR r of - Tip -> NonEmpty max maxV' Tip + Tip -> NonEmpty (maxToMin max) maxV' Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR r)) Nothing -> binL (goDeleteL l) (goDeleteR r) goDeleteR Tip = Empty - goDeleteR (Bin min minV l r) = case f min minV of + goDeleteR (Bin min minV l r) = case f (boundKey min) minV of Just minV' -> case goDeleteR r of Empty -> case goL l of - Tip -> NonEmpty min minV' Tip + Tip -> NonEmpty (minToMax min) minV' Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL l) r') Nothing -> binR (goDeleteL l) (goDeleteR r) @@ -1424,14 +1424,14 @@ mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) mapEitherWithKey func = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) - start (IntMap (NonEmpty min minV root)) = case func min minV of + start (IntMap (NonEmpty min minV root)) = case func (boundKey min) minV of Left v -> let t :*: f = goTrueL root in (IntMap (NonEmpty min v t), IntMap f) Right v -> let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min v f)) goTrueL Tip = Tip :*: Empty - goTrueL (Bin max maxV l r) = case func max maxV of + goTrueL (Bin max maxV l r) = case func (boundKey max) maxV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin max v tl tr :*: binL fl fr @@ -1446,7 +1446,7 @@ mapEitherWithKey func = start in t :*: f goTrueR Tip = Tip :*: Empty - goTrueR (Bin min minV l r) = case func min minV of + goTrueR (Bin min minV l r) = case func (boundKey min) minV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin min v tl tr :*: binR fl fr @@ -1461,7 +1461,7 @@ mapEitherWithKey func = start in t :*: f goFalseL Tip = Empty :*: Tip - goFalseL (Bin max maxV l r) = case func max maxV of + goFalseL (Bin max maxV l r) = case func (boundKey max) maxV of Left v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -1476,7 +1476,7 @@ mapEitherWithKey func = start in binL tl tr :*: Bin max v fl fr goFalseR Tip = Empty :*: Tip - goFalseR (Bin min minV l r) = case func min minV of + goFalseR (Bin min minV l r) = case func (boundKey min) minV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 839c7823d..b4a7f8729 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -139,37 +139,37 @@ filterMissing :: Applicative f => (Key -> a -> Bool) -> WhenMissing f a a filterMissing p = WhenMissing (\k v -> pure (if p k v then Just v else Nothing)) (pure . goLKeep) (pure . goRKeep) (pure . start) where start Empty = Empty start (NonEmpty min minV root) - | p min minV = NonEmpty min minV (goLKeep root) + | p (boundKey min) minV = NonEmpty min minV (goLKeep root) | otherwise = goL root goLKeep Tip = Tip goLKeep (Bin max maxV l r) - | p max maxV = Bin max maxV (goLKeep l) (goRKeep r) + | p (boundKey max) maxV = Bin max maxV (goLKeep l) (goRKeep r) | otherwise = case goR r of Empty -> goLKeep l NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' goRKeep Tip = Tip goRKeep (Bin min minV l r) - | p min minV = Bin min minV (goLKeep l) (goRKeep r) + | p (boundKey min) minV = Bin min minV (goLKeep l) (goRKeep r) | otherwise = case goL l of Empty -> goRKeep r NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) goL Tip = Empty goL (Bin max maxV l r) - | p max maxV = case goL l of + | p (boundKey max) maxV = case goL l of Empty -> case goRKeep r of - Tip -> NonEmpty max maxV Tip + Tip -> NonEmpty (maxToMin max) maxV Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV l' (goRKeep r)) | otherwise = binL (goL l) (goR r) goR Tip = Empty goR (Bin min minV l r) - | p min minV = case goR r of + | p (boundKey min) minV = case goR r of Empty -> case goLKeep l of - Tip -> NonEmpty min minV Tip + Tip -> NonEmpty (minToMax min) minV Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV (goLKeep l) r') | otherwise = binR (goL l) (goR r) @@ -193,13 +193,13 @@ filterAMissing f = WhenMissing , missingSingle = \k v -> fmap (\keep -> if keep then Just v else Nothing) (f k v) } where start Empty = pure Empty - start (NonEmpty min minV root) = (\keepV root' -> if keepV then NonEmpty min minV root' else nodeToMapL root') <$> f min minV <*> goL root + start (NonEmpty min minV root) = (\keepV root' -> if keepV then NonEmpty min minV root' else nodeToMapL root') <$> f (boundKey min) minV <*> goL root goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' keepMax -> if keepMax then Bin max maxV l' r' else extractBinL l' r') <$> goL l <*> goR r <*> f max maxV + goL (Bin max maxV l r) = (\l' r' keepMax -> if keepMax then Bin max maxV l' r' else extractBinL l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV goR Tip = pure Tip - goR (Bin min minV l r) = (\keepMin l' r' -> if keepMin then Bin min minV l' r' else extractBinR l' r') <$> f min minV <*> goL l <*> goR r + goR (Bin min minV l r) = (\keepMin l' r' -> if keepMin then Bin min minV l' r' else extractBinR l' r') <$> f (boundKey min) minV <*> goL l <*> goR r -- | A tactic for dealing with keys present in both -- maps in 'merge' or 'mergeA'. @@ -299,13 +299,13 @@ merge miss1 miss2 match = start where start (IntMap Empty) (IntMap !m2) = IntMap (missAllL miss2 m2) start (IntMap !m1) (IntMap Empty) = IntMap (missAllL miss1 m1) start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = case missSingle miss1 min1 minV1 of + | min1 < min2 = case missSingle miss1 (boundKey min1) minV1 of Nothing -> IntMap (goL2 minV2 min1 root1 min2 root2) Just minV' -> IntMap (NonEmpty min1 minV' (goL2Keep minV2 min1 root1 min2 root2)) - | min1 > min2 = case missSingle miss2 min2 minV2 of + | min1 > min2 = case missSingle miss2 (boundKey min2) minV2 of Nothing -> IntMap (goL1 minV1 min1 root1 min2 root2) Just minV' -> IntMap (NonEmpty min2 minV' (goL1Keep minV1 min1 root1 min2 root2)) - | otherwise = case matchSingle match min1 minV1 minV2 of + | otherwise = case matchSingle match (boundKey min1) minV1 minV2 of Nothing -> IntMap (goLFused min1 root1 root2) Just minV' -> IntMap (NonEmpty min1 minV' (goLFusedKeep min1 root1 root2)) @@ -326,33 +326,33 @@ merge miss1 miss2 match = start where -- goL1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c -- We special case merging two empty nodes because the last time I checked it was faster than falling through to the next case - goL1Keep minV1 !min1 Tip !_ Tip = case missSingle miss1 min1 minV1 of + goL1Keep minV1 !min1 Tip !_ Tip = case missSingle miss1 (boundKey min1) minV1 of Nothing -> Tip - Just minV' -> Bin min1 minV' Tip Tip + Just minV' -> Bin (minToMax min1) minV' Tip Tip -- If the second node is empty, then we basically need a copy of the first node. However, the presence of minV1 complicates things, -- so we need to insert it - goL1Keep minV1 !min1 n1 !min2 Tip = case missSingle miss1 min1 minV1 of + goL1Keep minV1 !min1 n1 !min2 Tip = case missSingle miss1 (boundKey min1) minV1 of Nothing -> missLeft miss1 n1 - Just minV' -> insertMinL (xor min1 min2) min1 minV' (missLeft miss1 n1) + Just minV' -> insertMinL (xor (boundKey min1) min2) min1 minV' (missLeft miss1 n1) -- We handle the case of nodes that cover disjoint ranges separately. The property of being disjoint, unlike a lot of things, remains -- constant as we recurse into subnodes, and this representation is particularly good at efficiently detecting it. By assumption, -- min1 > min2, so we don't need to handle the case of min2 > max1. - goL1Keep minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = case missAllL miss1 (NonEmpty min1 minV1 n1) of + goL1Keep minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = case missAllL miss1 (NonEmpty min1 minV1 n1) of Empty -> missLeft miss2 n2 NonEmpty min1' minV1' n1' -> case missLeft miss2 n2 of - Tip -> insertMinL (xor min1' min2) min1' minV1' n1' + Tip -> insertMinL (xor (boundKey min1') min2) min1' minV1' n1' n2'@(Bin _ _ _ _) -> unionDisjointL minV1' min2 n2' min1' n1' -- If the first node is empty, we still need to insert minV1 - goL1Keep minV1 !min1 Tip !min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 + goL1Keep minV1 !min1 Tip !min2 n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 -- This is the meat of the method. Since we already know that the two nodes cover overlapping ranges, there are three possibilities: -- * Node 2 splits first, so we need to merge n1 with either l2 or r2 -- * Both nodes split at the same time, so we need to merge l1 with l2 and r1 with r2 -- * Node 1 splits first, so we need to merge n2 with either l1 or r1 - goL1Keep minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goL1Keep minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of -- Node 2 splits first. Knowing that min1 < min2 doesn't really help here, so our first job is to determine if we need -- to merge n1 with l2 or with r2. We do this with the same navigational test used in, e.g., lookup, using an arbirary key -- from node 1 (in this case we chose min1). If that key would be on the left side of node 2, then (since node 1 covers a smaller @@ -360,21 +360,21 @@ merge miss1 miss2 match = start where -- -- In the specific case of merging n1 with l2, we don't have to do any more comparisons: we already know that min1 > min2, -- so we should be calling an L1 function - LT | xor min1 min2 < xor min1 max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missRight miss2 r2) + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missRight miss2 r2) -- At this point, we know that we need to merge n1 with r2. There are two things needed to do this: -- * n1 needs to be converted to a right node to match r2. -- * We need to compare max1 and max2 to figure out which will be the maximum of the combined node and to -- decide which (R1, R2, or RFused) function to recurse to. - | max1 > max2 -> case missSingle miss1 max1 maxV1 of + | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of -- If we had an optimized goR2 (no keep), then calling using it is more efficient than -- calling goR2Keep and having to extract a new maximum from the result. Therefore, we -- first check if we can keep our existing maximum, and if not, call goR2. Nothing -> maybeBinL l' (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> case missSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of Nothing -> maybeBinL l' (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> case matchSingle match max1 maxV1 maxV2 of + | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of Nothing -> maybeBinL l' (goRFused max1 (Bin min1 minV1 l1 r1) r2) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) where @@ -384,13 +384,13 @@ merge miss1 miss2 match = start where -- The two nodes split at the same time. In this case we need to merge l1 and l2 and r1 and r2. We already know that -- min1 > min2, so merging the left nodes is easy, but we need to branch to figure out which right merging function to call -- and which maximum to keep. - EQ | max1 > max2 -> case missSingle miss1 max1 maxV1 of + EQ | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 r2) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) - | max1 < max2 -> case missSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 r2) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) - | otherwise -> case matchSingle match max1 maxV1 maxV2 of + | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of Nothing -> maybeBinL l' (goRFused max1 r1 r2) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) where @@ -405,39 +405,39 @@ merge miss1 miss2 match = start where -- Merge two left nodes and a minimum value for the second node into a new left node -- Precondition: min2 > min1 -- goL2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c - goL2Keep minV2 !_ Tip !min2 Tip = case missSingle miss2 min2 minV2 of + goL2Keep minV2 !_ Tip !min2 Tip = case missSingle miss2 (boundKey min2) minV2 of Nothing -> Tip - Just minV' -> Bin min2 minV' Tip Tip - goL2Keep minV2 !min1 Tip !min2 n2 = case missSingle miss2 min2 minV2 of + Just minV' -> Bin (minToMax min2) minV' Tip Tip + goL2Keep minV2 !min1 Tip !min2 n2 = case missSingle miss2 (boundKey min2) minV2 of Nothing -> missLeft miss2 n2 - Just minV' -> insertMinL (xor min1 min2) min2 minV' (missLeft miss2 n2) - goL2Keep minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = case missAllL miss2 (NonEmpty min2 minV2 n2) of + Just minV' -> insertMinL (xor (boundKey min2) min1) min2 minV' (missLeft miss2 n2) + goL2Keep minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = case missAllL miss2 (NonEmpty min2 minV2 n2) of Empty -> missLeft miss1 n1 NonEmpty min2' minV2' n2' -> case missLeft miss1 n1 of - Tip -> insertMinL (xor min1 min2') min2' minV2' n2' + Tip -> insertMinL (xor (boundKey min2') min1) min2' minV2' n2' n1'@(Bin _ _ _ _) -> unionDisjointL minV2' min1 n1' min2' n2' - goL2Keep minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 - goL2Keep minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 min2 < xor min2 max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missRight miss1 r1) - | max1 > max2 -> case missSingle miss1 max1 maxV1 of + goL2Keep minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 + goL2Keep minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missRight miss1 r1) + | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | max1 < max2 -> case missSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> case matchSingle match max1 maxV1 maxV2 of + | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of Nothing -> maybeBinL l' (goRFused max1 r1 (Bin min2 minV2 l2 r2)) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 (Bin min2 minV2 l2 r2)) where {-# INLINE l' #-} l' = missLeft miss1 l1 - EQ | max1 > max2 -> case missSingle miss1 max1 maxV1 of + EQ | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 r2) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) - | max1 < max2 -> case missSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 r2) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) - | otherwise -> case matchSingle match max1 maxV1 maxV2 of + | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of Nothing -> maybeBinL l' (goRFused max1 r1 r2) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) where @@ -460,15 +460,15 @@ merge miss1 miss2 match = start where -- Since the two nodes are joined at the left, the choices are considerable limited in comparison to the misaligned case. -- If node 1 splits first, n2 must be merged with l1 and if node 2 splits first, n1 must be merged with l2. The equal case -- is still the same as in the misaligned case, since we need to determine which maximum to use and which goR to call. - goLFusedKeep !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + goLFusedKeep !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> binL2 max2 maxV2 (goLFusedKeep min n1 l2) (missRight miss2 r2) - EQ | max1 > max2 -> case missSingle miss1 max1 maxV1 of + EQ | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 r2) Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) - | max1 < max2 -> case missSingle miss2 max2 maxV2 of + | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 r2) Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) - | otherwise -> case matchSingle match max1 maxV1 maxV2 of + | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of Nothing -> maybeBinL l' (goRFused max1 r1 r2) Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) where @@ -479,39 +479,39 @@ merge miss1 miss2 match = start where -- Merge two right nodes and a maximum value for the first node into a new right node -- Precondition: max1 < max2 -- goR1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c - goR1Keep maxV1 !max1 Tip !_ Tip = case missSingle miss1 max1 maxV1 of + goR1Keep maxV1 !max1 Tip !_ Tip = case missSingle miss1 (boundKey max1) maxV1 of Nothing -> Tip - Just maxV' -> Bin max1 maxV' Tip Tip - goR1Keep maxV1 !max1 !n1 !max2 Tip = case missSingle miss1 max1 maxV1 of + Just maxV' -> Bin (maxToMin max1) maxV' Tip Tip + goR1Keep maxV1 !max1 !n1 !max2 Tip = case missSingle miss1 (boundKey max1) maxV1 of Nothing -> missRight miss1 n1 - Just maxV' -> insertMaxR (xor max1 max2) max1 maxV' (missRight miss1 n1) - goR1Keep maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = case missAllR miss1 (NonEmpty max1 maxV1 n1) of + Just maxV' -> insertMaxR (xor (boundKey max1) max2) max1 maxV' (missRight miss1 n1) + goR1Keep maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = case missAllR miss1 (NonEmpty max1 maxV1 n1) of Empty -> missRight miss2 n2 NonEmpty max1' maxV1' n1' -> case missRight miss2 n2 of - Tip -> insertMaxR (xor max1' max2) max1' maxV1' n1' + Tip -> insertMaxR (xor (boundKey max1') max2) max1' maxV1' n1' n2'@(Bin _ _ _ _) -> unionDisjointR maxV1' max1' n1' max2 n2' - goR1Keep maxV1 !max1 Tip !max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1Keep maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> binR2 min2 minV2 (missLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) - | min1 < min2 -> case missSingle miss1 min1 minV1 of + goR1Keep maxV1 !max1 Tip !max2 n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 + goR1Keep maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> binR2 min2 minV2 (missLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) + | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of Nothing -> maybeBinR (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' - | min1 > min2 -> case missSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of Nothing -> maybeBinR (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' - | otherwise -> case matchSingle match min1 minV1 minV2 of + | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of Nothing -> maybeBinR (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) r' where {-# INLINE r' #-} r' = missRight miss2 r2 - EQ | min1 < min2 -> case missSingle miss1 min1 minV1 of + EQ | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 l2) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' - | min1 > min2 -> case missSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 l2) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' - | otherwise -> case matchSingle match min1 minV1 minV2 of + | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of Nothing -> maybeBinR (goLFused min1 l1 l2) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' where @@ -522,39 +522,39 @@ merge miss1 miss2 match = start where -- Merge two left nodes and a minimum value for the second node into a new left node -- Precondition: max2 < max1 -- goR2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c - goR2Keep maxV2 !_ Tip !max2 Tip = case missSingle miss2 max2 maxV2 of + goR2Keep maxV2 !_ Tip !max2 Tip = case missSingle miss2 (boundKey max2) maxV2 of Nothing -> Tip - Just maxV' -> Bin max2 maxV' Tip Tip - goR2Keep maxV2 !max1 Tip !max2 n2 = case missSingle miss2 max2 maxV2 of + Just maxV' -> Bin (maxToMin max2) maxV' Tip Tip + goR2Keep maxV2 !max1 Tip !max2 n2 = case missSingle miss2 (boundKey max2) maxV2 of Nothing -> missRight miss2 n2 - Just maxV' -> insertMaxR (xor max1 max2) max2 maxV' (missRight miss2 n2) - goR2Keep maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = case missAllR miss2 (NonEmpty max2 maxV2 n2) of + Just maxV' -> insertMaxR (xor (boundKey max2) max1) max2 maxV' (missRight miss2 n2) + goR2Keep maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = case missAllR miss2 (NonEmpty max2 maxV2 n2) of Empty -> missRight miss1 n1 NonEmpty max2' maxV2' n2' -> case missRight miss1 n1 of - Tip -> insertMaxR (xor max1 max2') max2' maxV2' n2' + Tip -> insertMaxR (xor (boundKey max2') max1) max2' maxV2' n2' n1'@(Bin _ _ _ _) -> unionDisjointR maxV2' max2' n2' max1 n1' - goR2Keep maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 - goR2Keep maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 max2 > xor max2 max1 -> binR1 min1 minV1 (missLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) - | min1 < min2 -> case missSingle miss1 min1 minV1 of + goR2Keep maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 + goR2Keep maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> binR1 min1 minV1 (missLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) + | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' - | min1 > min2 -> case missSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' - | otherwise -> case matchSingle match min1 minV1 minV2 of + | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of Nothing -> maybeBinR (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 (Bin max2 maxV2 l2 r2)) r' where {-# INLINE r' #-} r' = missRight miss1 r1 - EQ | min1 < min2 -> case missSingle miss1 min1 minV1 of + EQ | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 l2) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' - | min1 > min2 -> case missSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 l2) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' - | otherwise -> case matchSingle match min1 minV1 minV2 of + | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of Nothing -> maybeBinR (goLFused min1 l1 l2) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' where @@ -565,15 +565,15 @@ merge miss1 miss2 match = start where -- goRFusedKeep !_ Tip Tip = Tip goRFusedKeep !_ Tip n2 = missRight miss2 n2 goRFusedKeep !_ n1 Tip = missRight miss1 n1 - goRFusedKeep !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + goRFusedKeep !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> binR2 min2 minV2 (missLeft miss2 l2) (goRFusedKeep max n1 r2) - EQ | min1 < min2 -> case missSingle miss1 min1 minV1 of + EQ | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 l2) r' Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' - | min1 > min2 -> case missSingle miss2 min2 minV2 of + | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 l2) r' Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' - | otherwise -> case matchSingle match min1 minV1 minV2 of + | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of Nothing -> maybeBinR (goLFused min1 l1 l2) r' Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' where @@ -592,89 +592,89 @@ merge miss1 miss2 match = start where goInsertL1 !k v !_ _ Tip = case missSingle miss1 k v of Nothing -> Tip - Just v' -> Bin k v' Tip Tip + Just v' -> Bin (Bound k) v' Tip Tip goInsertL1 !k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then binL2 max maxV (goInsertL1 k v xorCache min l) (missRight miss2 r) - else binL2 max maxV (missLeft miss2 l) (goInsertR1 k v xorCacheMax max r) - | k > max = case missSingle miss1 k v of + | inMaxBound k max = if xorCache < xorCacheMax + then binL2 max maxV (goInsertL1 k v xorCache min l) (missRight miss2 r) + else binL2 max maxV (missLeft miss2 l) (goInsertR1 k v xorCacheMax max r) + | outOfMaxBound k max = case missSingle miss1 k v of Nothing -> missLeft miss2 (Bin max maxV l r) - Just v' -> if xor min max < xorCacheMax - then Bin k v' (missLeft miss2 (Bin max maxV l r)) Tip - else Bin k v' (missLeft miss2 l) (missRight miss2 (insertMaxR xorCacheMax max maxV r)) - | otherwise = case matchSingle match max v maxV of + Just v' -> if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v' (missLeft miss2 (Bin max maxV l r)) Tip + else Bin (Bound k) v' (missLeft miss2 l) (missRight miss2 (insertMaxR xorCacheMax max maxV r)) + | otherwise = case matchSingle match k v maxV of Nothing -> extractBinL (missLeft miss2 l) (missRight miss2 r) -- TODO: do extractBin first? Just maxV' -> Bin max maxV' (missLeft miss2 l) (missRight miss2 r) where xorCacheMax = xor k max goInsertL2 !k v !_ _ Tip = case missSingle miss2 k v of Nothing -> Tip - Just v' -> Bin k v' Tip Tip + Just v' -> Bin (Bound k) v' Tip Tip goInsertL2 !k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then binL1 max maxV (goInsertL2 k v xorCache min l) (missRight miss1 r) - else binL1 max maxV (missLeft miss1 l) (goInsertR2 k v xorCacheMax max r) - | k > max = case missSingle miss2 k v of + | inMaxBound k max = if xorCache < xorCacheMax + then binL1 max maxV (goInsertL2 k v xorCache min l) (missRight miss1 r) + else binL1 max maxV (missLeft miss1 l) (goInsertR2 k v xorCacheMax max r) + | outOfMaxBound k max = case missSingle miss2 k v of Nothing -> missLeft miss1 (Bin max maxV l r) - Just v' -> if xor min max < xorCacheMax - then Bin k v' (missLeft miss1 (Bin max maxV l r)) Tip - else Bin k v' (missLeft miss1 l) (missRight miss1 (insertMaxR xorCacheMax max maxV r)) - | otherwise = case matchSingle match max maxV v of + Just v' -> if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v' (missLeft miss1 (Bin max maxV l r)) Tip + else Bin (Bound k) v' (missLeft miss1 l) (missRight miss1 (insertMaxR xorCacheMax max maxV r)) + | otherwise = case matchSingle match k maxV v of Nothing -> extractBinL (missLeft miss1 l) (missRight miss1 r) -- TODO: do extractBin first? Just maxV' -> Bin max maxV' (missLeft miss1 l) (missRight miss1 r) where xorCacheMax = xor k max goInsertR1 k v !_ _ Tip = case missSingle miss1 k v of Nothing -> Tip - Just v' -> Bin k v' Tip Tip + Just v' -> Bin (Bound k) v' Tip Tip goInsertR1 k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then binR2 min minV (missLeft miss2 l) (goInsertR1 k v xorCache max r) - else binR2 min minV (goInsertL1 k v xorCacheMin min l) (missRight miss2 r) - | k < min = case missSingle miss1 k v of + | inMinBound k min = if xorCache < xorCacheMin + then binR2 min minV (missLeft miss2 l) (goInsertR1 k v xorCache max r) + else binR2 min minV (goInsertL1 k v xorCacheMin min l) (missRight miss2 r) + | outOfMinBound k min = case missSingle miss1 k v of Nothing -> missRight miss2 (Bin min minV l r) - Just v' -> if xor min max < xorCacheMin - then Bin k v' Tip (missRight miss2 (Bin min minV l r)) - else Bin k v' (missLeft miss2 (insertMinL xorCacheMin min minV l)) (missRight miss2 r) - | otherwise = case matchSingle match min v minV of + Just v' -> if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v' Tip (missRight miss2 (Bin min minV l r)) + else Bin (Bound k) v' (missLeft miss2 (insertMinL xorCacheMin min minV l)) (missRight miss2 r) + | otherwise = case matchSingle match k v minV of Nothing -> extractBinR (missLeft miss2 l) (missRight miss2 r) -- TODO: do extractBin first? Just minV' -> Bin min minV' (missLeft miss2 l) (missRight miss2 r) where xorCacheMin = xor k min goInsertR2 !k v !_ _ Tip = case missSingle miss2 k v of Nothing -> Tip - Just v' -> Bin k v' Tip Tip + Just v' -> Bin (Bound k) v' Tip Tip goInsertR2 !k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then binR1 min minV (missLeft miss1 l) (goInsertR2 k v xorCache max r) - else binR1 min minV (goInsertL2 k v xorCacheMin min l) (missRight miss1 r) - | k < min = case missSingle miss2 k v of + | inMinBound k min = if xorCache < xorCacheMin + then binR1 min minV (missLeft miss1 l) (goInsertR2 k v xorCache max r) + else binR1 min minV (goInsertL2 k v xorCacheMin min l) (missRight miss1 r) + | outOfMinBound k min = case missSingle miss2 k v of Nothing -> missRight miss1 (Bin min minV l r) - Just v' -> if xor min max < xorCacheMin - then Bin k v' Tip (missRight miss1 (Bin min minV l r)) - else Bin k v' (missLeft miss1 (insertMinL xorCacheMin min minV l)) (missRight miss1 r) - | otherwise = case matchSingle match min minV v of + Just v' -> if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v' Tip (missRight miss1 (Bin min minV l r)) + else Bin (Bound k) v' (missLeft miss1 (insertMinL xorCacheMin min minV l)) (missRight miss1 r) + | otherwise = case matchSingle match k minV v of Nothing -> extractBinR (missLeft miss1 l) (missRight miss1 r) -- TODO: do extractBin first? Just minV' -> Bin min minV' (missLeft miss1 l) (missRight miss1 r) where xorCacheMin = xor k min {-# INLINE binL1 #-} - binL1 k1 v1 l r = case missSingle miss1 k1 v1 of + binL1 k1 v1 l r = case missSingle miss1 (boundKey k1) v1 of Nothing -> extractBinL l r Just v' -> Bin k1 v' l r {-# INLINE binL2 #-} - binL2 k2 v2 l r = case missSingle miss2 k2 v2 of + binL2 k2 v2 l r = case missSingle miss2 (boundKey k2) v2 of Nothing -> extractBinL l r Just v' -> Bin k2 v' l r {-# INLINE binR1 #-} - binR1 k1 v1 l r = case missSingle miss1 k1 v1 of + binR1 k1 v1 l r = case missSingle miss1 (boundKey k1) v1 of Nothing -> extractBinR l r Just v' -> Bin k1 v' l r {-# INLINE binR2 #-} - binR2 k2 v2 l r = case missSingle miss2 k2 v2 of + binR2 k2 v2 l r = case missSingle miss2 (boundKey k2) v2 of Nothing -> extractBinR l r Just v' -> Bin k2 v' l r @@ -767,121 +767,121 @@ mergeA miss1 miss2 match = start where start (IntMap Empty) (IntMap !m2) = IntMap <$> missingAllL miss2 m2 start (IntMap !m1) (IntMap Empty) = IntMap <$> missingAllL miss1 m1 start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = (\v m -> IntMap (maybeInsertMin min1 v m)) <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 root1 min2 root2 - | min2 < min1 = (\v m -> IntMap (maybeInsertMin min2 v m)) <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 root1 min2 root2 - | otherwise = (\v m -> IntMap (maybeInsertMin min1 v m)) <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 root1 root2 + | min1 < min2 = (\v m -> IntMap (maybeInsertMin min1 v m)) <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 root1 min2 root2 + | min2 < min1 = (\v m -> IntMap (maybeInsertMin min2 v m)) <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 root1 min2 root2 + | otherwise = (\v m -> IntMap (maybeInsertMin min1 v m)) <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 root1 root2 goL1 minV1 !min1 !n1 !_ Tip = missingAllL miss1 (NonEmpty min1 minV1 n1) - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = maybeUnionDisjointL min2 <$> missingLeft miss2 n2 <*> missingAllL miss1 (NonEmpty min1 minV1 n1) - goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 - goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min1 min2 < xor min1 max2 -> binL <$> goL1 minV1 min1 n1 min2 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) - | max1 > max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss2 l2 <*> goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 <*> missingSingle miss1 max1 maxV1 - | max1 < max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max2 v rm))) <$> missingLeft miss2 l2 <*> goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 <*> missingSingle miss2 max2 maxV2 - | otherwise -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss2 l2 <*> goRFused max1 (Bin min1 minV1 l1 r1) r2 <*> matchedSingle match max1 maxV1 maxV2 - EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 max1 maxV1 - | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 max2 maxV2 - | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match max1 maxV1 maxV2 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = maybeUnionDisjointL min2 <$> missingLeft miss2 n2 <*> missingAllL miss1 (NonEmpty min1 minV1 n1) + goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> binL <$> goL1 minV1 min1 n1 min2 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) + | max1 > max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss2 l2 <*> goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 <*> missingSingle miss1 (boundKey max1) maxV1 + | max1 < max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max2 v rm))) <$> missingLeft miss2 l2 <*> goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 <*> missingSingle miss2 (boundKey max2) maxV2 + | otherwise -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss2 l2 <*> goRFused max1 (Bin min1 minV1 l1 r1) r2 <*> matchedSingle match (boundKey max1) maxV1 maxV2 + EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 (boundKey max1) maxV1 + | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 (boundKey max2) maxV2 + | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match (boundKey max1) maxV1 maxV2 GT -> binL <$> goL1 minV1 min1 l1 min2 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) goL2 minV2 !_ Tip !min2 !n2 = missingAllL miss2 (NonEmpty min2 minV2 n2) - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = maybeUnionDisjointL min1 <$> missingLeft miss1 n1 <*> missingAllL miss2 (NonEmpty min2 minV2 n2) - goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 - goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 min2 < xor min2 max1 -> binL <$> goL2 minV2 min1 l1 min2 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) - | max1 > max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss1 l1 <*> goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) <*> missingSingle miss1 max1 maxV1 - | max1 < max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max2 v rm))) <$> missingLeft miss1 l1 <*> goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) <*> missingSingle miss2 max2 maxV2 - | otherwise -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss1 l1 <*> goRFused max1 r1 (Bin min2 minV2 l2 r2) <*> matchedSingle match max1 maxV1 maxV2 - EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 max1 maxV1 - | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 max2 maxV2 - | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match max1 maxV1 maxV2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = maybeUnionDisjointL min1 <$> missingLeft miss1 n1 <*> missingAllL miss2 (NonEmpty min2 minV2 n2) + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 + goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> binL <$> goL2 minV2 min1 l1 min2 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) + | max1 > max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss1 l1 <*> goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) <*> missingSingle miss1 (boundKey max1) maxV1 + | max1 < max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max2 v rm))) <$> missingLeft miss1 l1 <*> goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) <*> missingSingle miss2 (boundKey max2) maxV2 + | otherwise -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss1 l1 <*> goRFused max1 r1 (Bin min2 minV2 l2 r2) <*> matchedSingle match (boundKey max1) maxV1 maxV2 + EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 (boundKey max1) maxV1 + | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 (boundKey max2) maxV2 + | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match (boundKey max1) maxV1 maxV2 LT -> binL <$> goL2 minV2 min1 n1 min2 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) goLFused !_ Tip !n2 = nodeToMapL <$> missingLeft miss2 n2 goLFused !_ !n1 Tip = nodeToMapL <$> missingLeft miss1 n1 - goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> binL <$> goLFused min n1 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) - EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goLFused min l1 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 max1 maxV1 - | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goLFused min l1 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 max2 maxV2 - | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goLFused min l1 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match max1 maxV1 maxV2 + EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goLFused min l1 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 (boundKey max1) maxV1 + | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goLFused min l1 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 (boundKey max2) maxV2 + | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goLFused min l1 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match (boundKey max1) maxV1 maxV2 GT -> binL <$> goLFused min l1 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) goR1 maxV1 !max1 !n1 !_ Tip = missingAllR miss1 (NonEmpty max1 maxV1 n1) - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | max1 < min2 = maybeUnionDisjointR max2 <$> missingAllR miss1 (NonEmpty max1 maxV1 n1) <*> missingRight miss2 n2 - goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goR1 maxV1 max1 n1 max2 r2 - | min1 < min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 <*> missingRight miss2 r2 - | min1 > min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min2 v lm) r')) <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 <*> missingRight miss2 r2 - | otherwise -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 (Bin max1 maxV1 l1 r1) l2 <*> missingRight miss2 r2 - EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 - | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 - | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 l1 l2 <*> goR1 maxV1 max1 r1 max2 r2 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = maybeUnionDisjointR max2 <$> missingAllR miss1 (NonEmpty max1 maxV1 n1) <*> missingRight miss2 n2 + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goR1 maxV1 max1 n1 max2 r2 + | min1 < min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 <*> missingRight miss2 r2 + | min1 > min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min2 v lm) r')) <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 <*> missingRight miss2 r2 + | otherwise -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 (Bin max1 maxV1 l1 r1) l2 <*> missingRight miss2 r2 + EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 + | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 + | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 l1 l2 <*> goR1 maxV1 max1 r1 max2 r2 GT -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goR1 maxV1 max1 r1 max2 n2 goR2 maxV2 !_ Tip !max2 !n2 = missingAllR miss2 (NonEmpty max2 maxV2 n2) - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | max2 < min1 = maybeUnionDisjointR max1 <$> missingAllR miss2 (NonEmpty max2 maxV2 n2) <*> missingRight miss1 n1 - goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 - goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 max2 > xor max2 max1 -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goR2 maxV2 max1 r1 max2 n2 - | min1 < min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 - | min1 > min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min2 v lm) r')) <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 - | otherwise -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 l1 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 - EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 - | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 - | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 l1 l2 <*> goR2 maxV2 max1 r1 max2 r2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = maybeUnionDisjointR max1 <$> missingAllR miss2 (NonEmpty max2 maxV2 n2) <*> missingRight miss1 n1 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max1) max2) max1 n1 + goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goR2 maxV2 max1 r1 max2 n2 + | min1 < min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 + | min1 > min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min2 v lm) r')) <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 + | otherwise -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 l1 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 + EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 + | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 + | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 l1 l2 <*> goR2 maxV2 max1 r1 max2 r2 LT -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goR2 maxV2 max1 n1 max2 r2 goRFused !_ Tip !n2 = nodeToMapR <$> missingRight miss2 n2 goRFused !_ !n1 Tip = nodeToMapR <$> missingRight miss1 n1 - goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goRFused max n1 r2 - EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 min1 minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goRFused max r1 r2 - | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 min2 minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goRFused max r1 r2 - | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match min1 minV1 minV2 <*> goLFused min1 l1 l2 <*> goRFused max r1 r2 + EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goRFused max r1 r2 + | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goRFused max r1 r2 + | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 l1 l2 <*> goRFused max r1 r2 GT -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goRFused max r1 n2 goInsertL1 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss1 k v goInsertL1 !k v !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then binL <$> goInsertL1 k v xorCache min l <*> missingAllR miss2 (NonEmpty max maxV r) - else (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss2 l <*> goInsertR1 k v xorCacheMax max r <*> missingSingle miss2 max maxV - | k > max = (\n' v' -> r2lMap (maybeInsertMax k v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss2 n <*> missingSingle miss1 k v - | otherwise = (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss2 l <*> missingRight miss2 r <*> matchedSingle match max v maxV + | inMaxBound k max = if xorCache < xorCacheMax + then binL <$> goInsertL1 k v xorCache min l <*> missingAllR miss2 (NonEmpty max maxV r) + else (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss2 l <*> goInsertR1 k v xorCacheMax max r <*> missingSingle miss2 (boundKey max) maxV + | outOfMaxBound k max = (\n' v' -> r2lMap (maybeInsertMax (Bound k) v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss2 n <*> missingSingle miss1 k v + | otherwise = (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss2 l <*> missingRight miss2 r <*> matchedSingle match k v maxV where xorCacheMax = xor k max goInsertL2 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss2 k v goInsertL2 !k v !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax - then binL <$> goInsertL2 k v xorCache min l <*> missingAllR miss1 (NonEmpty max maxV r) - else (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss1 l <*> goInsertR2 k v xorCacheMax max r <*> missingSingle miss1 max maxV - | k > max = (\n' v' -> r2lMap (maybeInsertMax k v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss1 n <*> missingSingle miss2 k v - | otherwise = (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss1 l <*> missingRight miss1 r <*> matchedSingle match max maxV v + | inMaxBound k max = if xorCache < xorCacheMax + then binL <$> goInsertL2 k v xorCache min l <*> missingAllR miss1 (NonEmpty max maxV r) + else (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss1 l <*> goInsertR2 k v xorCacheMax max r <*> missingSingle miss1 (boundKey max) maxV + | outOfMaxBound k max = (\n' v' -> r2lMap (maybeInsertMax (Bound k) v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss1 n <*> missingSingle miss2 k v + | otherwise = (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss1 l <*> missingRight miss1 r <*> matchedSingle match k maxV v where xorCacheMax = xor k max goInsertR1 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss1 k v goInsertR1 !k v !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then binR <$> missingAllL miss2 (NonEmpty min minV l) <*> goInsertR1 k v xorCache max r - else (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss2 min minV <*> goInsertL1 k v xorCacheMin min l <*> missingRight miss2 r - | k < min = (\v' n' -> l2rMap (maybeInsertMin k v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss1 k v <*> missingRight miss2 n - | otherwise = (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match min v minV <*> missingLeft miss2 l <*> missingRight miss2 r + | inMinBound k min = if xorCache < xorCacheMin + then binR <$> missingAllL miss2 (NonEmpty min minV l) <*> goInsertR1 k v xorCache max r + else (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss2 (boundKey min) minV <*> goInsertL1 k v xorCacheMin min l <*> missingRight miss2 r + | outOfMinBound k min = (\v' n' -> l2rMap (maybeInsertMin (Bound k) v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss1 k v <*> missingRight miss2 n + | otherwise = (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match k v minV <*> missingLeft miss2 l <*> missingRight miss2 r where xorCacheMin = xor k min goInsertR2 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss2 k v goInsertR2 !k v !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin - then binR <$> missingAllL miss1 (NonEmpty min minV l) <*> goInsertR2 k v xorCache max r - else (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss1 min minV <*> goInsertL2 k v xorCacheMin min l <*> missingRight miss1 r - | k < min = (\v' n' -> l2rMap (maybeInsertMin k v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss2 k v <*> missingRight miss1 n - | otherwise = (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match min minV v <*> missingLeft miss1 l <*> missingRight miss1 r + | inMinBound k min = if xorCache < xorCacheMin + then binR <$> missingAllL miss1 (NonEmpty min minV l) <*> goInsertR2 k v xorCache max r + else (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss1 (boundKey min) minV <*> goInsertL2 k v xorCacheMin min l <*> missingRight miss1 r + | outOfMinBound k min = (\v' n' -> l2rMap (maybeInsertMin (Bound k) v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss2 k v <*> missingRight miss1 n + | otherwise = (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match k minV v <*> missingLeft miss1 l <*> missingRight miss1 r where xorCacheMin = xor k min missingAllR whenMiss = fmap l2rMap . missingAllL whenMiss . r2lMap maybeSingleton :: Key -> Maybe v -> IntMap_ d v maybeSingleton !_ Nothing = Empty -maybeSingleton !k (Just v) = NonEmpty k v Tip +maybeSingleton !k (Just v) = NonEmpty (Bound k) v Tip maybeBinL :: Node L v -> IntMap_ R v -> Node L v maybeBinL l Empty = l @@ -891,22 +891,22 @@ maybeBinR :: IntMap_ L v -> Node R v -> Node R v maybeBinR Empty r = r maybeBinR (NonEmpty min minV l) r = Bin min minV l r -maybeInsertMin :: Key -> Maybe v -> IntMap_ L v -> IntMap_ L v +maybeInsertMin :: Bound L -> Maybe v -> IntMap_ L v -> IntMap_ L v maybeInsertMin !_ Nothing !m = m maybeInsertMin !k (Just v) Empty = NonEmpty k v Tip -maybeInsertMin !k (Just v) (NonEmpty min minV root) = NonEmpty k v (insertMinL (xor k min) min minV root) +maybeInsertMin !k (Just v) (NonEmpty min minV root) = NonEmpty k v (insertMinL (xor (boundKey min) k) min minV root) -maybeInsertMax :: Key -> Maybe v -> IntMap_ R v -> IntMap_ R v +maybeInsertMax :: Bound R -> Maybe v -> IntMap_ R v -> IntMap_ R v maybeInsertMax !_ Nothing !m = m maybeInsertMax !k (Just v) Empty = NonEmpty k v Tip -maybeInsertMax !k (Just v) (NonEmpty max maxV root) = NonEmpty k v (insertMaxR (xor k max) max maxV root) +maybeInsertMax !k (Just v) (NonEmpty max maxV root) = NonEmpty k v (insertMaxR (xor (boundKey max) k) max maxV root) -maybeUnionDisjointL :: Key -> Node L v -> IntMap_ L v -> IntMap_ L v +maybeUnionDisjointL :: Bound L -> Node L v -> IntMap_ L v -> IntMap_ L v maybeUnionDisjointL !_ Tip !m2 = m2 maybeUnionDisjointL !_ !n1 Empty = nodeToMapL n1 maybeUnionDisjointL !min1 !n1 (NonEmpty min2 minV2 root2) = nodeToMapL (unionDisjointL minV2 min1 n1 min2 root2) -maybeUnionDisjointR :: Key -> IntMap_ R v -> Node R v -> IntMap_ R v +maybeUnionDisjointR :: Bound R -> IntMap_ R v -> Node R v -> IntMap_ R v maybeUnionDisjointR !_ !m1 Tip = m1 maybeUnionDisjointR !_ Empty !n2 = nodeToMapR n2 maybeUnionDisjointR !max2 (NonEmpty max1 maxV1 root1) !n2 = nodeToMapR (unionDisjointR maxV1 max1 root1 max2 n2) diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 15ab754d0..b018910ce 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -94,13 +94,13 @@ import Data.IntMap.Merge.Internal mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b mapMissing f = WhenMissing (\k v -> pure (Just (f k v))) (pure . goL) (pure . goR) (pure . start) where start Empty = Empty - start (NonEmpty min minV root) = NonEmpty min (f min minV) (goL root) + start (NonEmpty min minV root) = NonEmpty min (f (boundKey min) minV) (goL root) goL Tip = Tip - goL (Bin k v l r) = Bin k (f k v) (goL l) (goR r) + goL (Bin k v l r) = Bin k (f (boundKey k) v) (goL l) (goR r) goR Tip = Tip - goR (Bin k v l r) = Bin k (f k v) (goL l) (goR r) + goR (Bin k v l r) = Bin k (f (boundKey k) v) (goL l) (goR r) -- | Map over the entries whose keys are missing from the other map, -- optionally removing some. This is the most powerful 'SimpleWhenMissing' @@ -116,38 +116,38 @@ mapMissing f = WhenMissing (\k v -> pure (Just (f k v))) (pure . goL) (pure . go mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b mapMaybeMissing f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pure . goRKeep) (pure . start) where start Empty = Empty - start (NonEmpty min minV root) = case f min minV of + start (NonEmpty min minV root) = case f (boundKey min) minV of Just minV' -> NonEmpty min minV' (goLKeep root) Nothing -> goL root goLKeep Tip = Tip - goLKeep (Bin max maxV l r) = case f max maxV of + goLKeep (Bin max maxV l r) = case f (boundKey max) maxV of Just maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) Nothing -> case goR r of Empty -> goLKeep l NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' goRKeep Tip = Tip - goRKeep (Bin min minV l r) = case f min minV of + goRKeep (Bin min minV l r) = case f (boundKey min) minV of Just minV' -> Bin min minV' (goLKeep l) (goRKeep r) Nothing -> case goL l of Empty -> goRKeep r NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) goL Tip = Empty - goL (Bin max maxV l r) = case f max maxV of + goL (Bin max maxV l r) = case f (boundKey max) maxV of Just maxV' -> case goL l of Empty -> case goRKeep r of - Tip -> NonEmpty max maxV' Tip + Tip -> NonEmpty (maxToMin max) maxV' Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goRKeep r)) Nothing -> binL (goL l) (goR r) goR Tip = Empty - goR (Bin min minV l r) = case f min minV of + goR (Bin min minV l r) = case f (boundKey min) minV of Just minV' -> case goR r of Empty -> case goLKeep l of - Tip -> NonEmpty min minV' Tip + Tip -> NonEmpty (minToMax min) minV' Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goLKeep l) r') Nothing -> binR (goL l) (goR r) @@ -215,13 +215,13 @@ traverseMaybeMissing f = WhenMissing , missingSingle = f } where start Empty = pure Empty - start (NonEmpty min minV root) = maybe nodeToMapL (NonEmpty min) <$> f min minV <*> goL root + start (NonEmpty min minV root) = maybe nodeToMapL (NonEmpty min) <$> f (boundKey min) minV <*> goL root goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> maybe extractBinL (Bin max) maxV' l' r') <$> goL l <*> goR r <*> f max maxV + goL (Bin max maxV l r) = (\l' r' maxV' -> maybe extractBinL (Bin max) maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV goR Tip = pure Tip - goR (Bin min minV l r) = (\minV' l' r' -> maybe extractBinR (Bin min) minV' l' r') <$> f min minV <*> goL l <*> goR r + goR (Bin min minV l r) = (\minV' l' r' -> maybe extractBinR (Bin min) minV' l' r') <$> f (boundKey min) minV <*> goL l <*> goR r -- | Traverse over the entries whose keys are missing from the other -- map. @@ -237,10 +237,10 @@ traverseMissing f = WhenMissing , missingSingle = \k v -> Just <$> f k v } where start Empty = pure Empty - start (NonEmpty min minV root) = NonEmpty min <$> f min minV <*> goL root + start (NonEmpty min minV root) = NonEmpty min <$> f (boundKey min) minV <*> goL root goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f max maxV + goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV goR Tip = pure Tip - goR (Bin min minV l r) = (\minV' l' r' -> Bin min minV' l' r') <$> f min minV <*> goL l <*> goR r + goR (Bin min minV l r) = (\minV' l' r' -> Bin min minV' l' r') <$> f (boundKey min) minV <*> goL l <*> goR r diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 5a31c14a7..b1c255733 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -98,13 +98,13 @@ import Data.IntMap.Merge.Internal mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b mapMissing f = WhenMissing (\k v -> pure (Just $! f k v)) (pure . goL) (pure . goR) (pure . start) where start Empty = Empty - start (NonEmpty min minV root) = NonEmpty min #! f min minV # goL root + start (NonEmpty min minV root) = NonEmpty min #! f (boundKey min) minV # goL root goL Tip = Tip - goL (Bin k v l r) = Bin k #! f k v # goL l # goR r + goL (Bin k v l r) = Bin k #! f (boundKey k) v # goL l # goR r goR Tip = Tip - goR (Bin k v l r) = Bin k #! f k v # goL l # goR r + goR (Bin k v l r) = Bin k #! f (boundKey k) v # goL l # goR r -- | Map over the entries whose keys are missing from the other map, -- optionally removing some. This is the most powerful 'SimpleWhenMissing' @@ -123,38 +123,38 @@ mapMaybeMissing f = WhenMissing (\k v -> case f k v of Just !b -> pure (Just b)) (pure . goLKeep) (pure . goRKeep) (pure . start) where start Empty = Empty - start (NonEmpty min minV root) = case f min minV of + start (NonEmpty min minV root) = case f (boundKey min) minV of Just !minV' -> NonEmpty min minV' (goLKeep root) Nothing -> goL root goLKeep Tip = Tip - goLKeep (Bin max maxV l r) = case f max maxV of + goLKeep (Bin max maxV l r) = case f (boundKey max) maxV of Just !maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) Nothing -> case goR r of Empty -> goLKeep l NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' goRKeep Tip = Tip - goRKeep (Bin min minV l r) = case f min minV of + goRKeep (Bin min minV l r) = case f (boundKey min) minV of Just !minV' -> Bin min minV' (goLKeep l) (goRKeep r) Nothing -> case goL l of Empty -> goRKeep r NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) goL Tip = Empty - goL (Bin max maxV l r) = case f max maxV of + goL (Bin max maxV l r) = case f (boundKey max) maxV of Just !maxV' -> case goL l of Empty -> case goRKeep r of - Tip -> NonEmpty max maxV' Tip + Tip -> NonEmpty (maxToMin max) maxV' Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goRKeep r)) Nothing -> binL (goL l) (goR r) goR Tip = Empty - goR (Bin min minV l r) = case f min minV of + goR (Bin min minV l r) = case f (boundKey min) minV of Just !minV' -> case goR r of Empty -> case goLKeep l of - Tip -> NonEmpty min minV' Tip + Tip -> NonEmpty (minToMax min) minV' Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goLKeep l) r') Nothing -> binR (goL l) (goR r) @@ -225,13 +225,13 @@ traverseMaybeMissing f = WhenMissing , missingSingle = f } where start Empty = pure Empty - start (NonEmpty min minV root) = maybe nodeToMapL (NonEmpty min $!) <$> f min minV <*> goL root + start (NonEmpty min minV root) = maybe nodeToMapL (NonEmpty min $!) <$> f (boundKey min) minV <*> goL root goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> maybe extractBinL (Bin max $!) maxV' l' r') <$> goL l <*> goR r <*> f max maxV + goL (Bin max maxV l r) = (\l' r' maxV' -> maybe extractBinL (Bin max $!) maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV goR Tip = pure Tip - goR (Bin min minV l r) = (\minV' l' r' -> maybe extractBinR (Bin min $!) minV' l' r') <$> f min minV <*> goL l <*> goR r + goR (Bin min minV l r) = (\minV' l' r' -> maybe extractBinR (Bin min $!) minV' l' r') <$> f (boundKey min) minV <*> goL l <*> goR r -- | Traverse over the entries whose keys are missing from the other -- map. @@ -247,10 +247,10 @@ traverseMissing f = WhenMissing , missingSingle = \k v -> Just <$> f k v } where start Empty = pure Empty - start (NonEmpty min minV root) = (NonEmpty min $!) <$> f min minV <*> goL root + start (NonEmpty min minV root) = (NonEmpty min $!) <$> f (boundKey min) minV <*> goL root goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' !maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f max maxV + goL (Bin max maxV l r) = (\l' r' !maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV goR Tip = pure Tip - goR (Bin min minV l r) = (\ !minV' l' r' -> Bin min minV' l' r') <$> f min minV <*> goL l <*> goR r + goR (Bin min minV l r) = (\ !minV' l' r' -> Bin min minV' l' r') <$> f (boundKey min) minV <*> goL l <*> goR r diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index fcd432181..0f390f512 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -255,7 +255,7 @@ import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 singleton :: Key -> a -> IntMap a -singleton k v = v `seq` IntMap (NonEmpty k v Tip) +singleton k v = v `seq` IntMap (NonEmpty (Bound k) v Tip) -- | /O(min(n,W))/. Insert a new key\/value pair in the map. -- If the key is already present in the map, the associated value is @@ -268,33 +268,33 @@ singleton k v = v `seq` IntMap (NonEmpty k v Tip) insert :: Key -> a -> IntMap a -> IntMap a insert = start where - start !k !v (IntMap Empty) = IntMap (NonEmpty k v Tip) + start !k !v (IntMap Empty) = IntMap (NonEmpty (Bound k) v Tip) start !k !v (IntMap (NonEmpty min minV root)) - | k > min = IntMap (NonEmpty min minV (goL k v (xor min k) min root)) - | k < min = IntMap (NonEmpty k v (insertMinL (xor min k) min minV root)) - | otherwise = IntMap (NonEmpty k v root) + | inMinBound k min = IntMap (NonEmpty min minV (goL k v (xor k min) min root)) + | outOfMinBound k min = IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) + | otherwise = IntMap (NonEmpty (Bound k) v root) - goL !k v !_ !_ Tip = Bin k v Tip Tip + goL !k v !_ !_ Tip = Bin (Bound k) v Tip Tip goL !k v !xorCache !min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goL k v xorCache min l) r else Bin max maxV l (goR k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v (Bin max maxV l r) Tip + else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max v l r where xorCacheMax = xor k max - goR !k v !_ !_ Tip = Bin k v Tip Tip + goR !k v !_ !_ Tip = Bin (Bound k) v Tip Tip goR !k v !xorCache !max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goR k v xorCache max r) else Bin min minV (goL k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v Tip (Bin min minV l r) + else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min v l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWith' f key value mp@ @@ -308,33 +308,33 @@ insert = start insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWith = start where - start _ !k v (IntMap Empty) = IntMap (NonEmpty k #! v # Tip) + start _ !k v (IntMap Empty) = IntMap (NonEmpty (Bound k) #! v # Tip) start combine !k v (IntMap (NonEmpty min minV root)) - | k > min = IntMap (NonEmpty min minV (goL combine k v (xor min k) min root)) - | k < min = IntMap (NonEmpty k #! v # insertMinL (xor min k) min minV root) - | otherwise = IntMap (NonEmpty k #! combine v minV # root) + | inMinBound k min = IntMap (NonEmpty min minV (goL combine k v (xor k min) min root)) + | outOfMinBound k min = IntMap (NonEmpty (Bound k) #! v # insertMinL (xor k min) min minV root) + | otherwise = IntMap (NonEmpty (Bound k) #! combine v minV # root) - goL _ !k v !_ !_ Tip = Bin k #! v # Tip # Tip + goL _ !k v !_ !_ Tip = Bin (Bound k) #! v # Tip # Tip goL combine !k v !xorCache !min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goL combine k v xorCache min l) r else Bin max maxV l (goR combine k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k #! v # Bin max maxV l r # Tip - else Bin k #! v # l # insertMaxR xorCacheMax max maxV r + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) #! v # Bin max maxV l r # Tip + else Bin (Bound k) #! v # l # insertMaxR xorCacheMax max maxV r | otherwise = Bin max #! combine v maxV # l # r where xorCacheMax = xor k max - goR _ !k v !_ !_ Tip = Bin k #! v # Tip # Tip + goR _ !k v !_ !_ Tip = Bin (Bound k) #! v # Tip # Tip goR combine !k v !xorCache !max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goR combine k v xorCache max r) else Bin min minV (goL combine k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k #! v # Tip # Bin min minV l r - else Bin k #! v # insertMinL xorCacheMin min minV l # r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) #! v # Tip # Bin min minV l r + else Bin (Bound k) #! v # insertMinL xorCacheMin min minV l # r | otherwise = Bin min #! combine v minV # l # r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWithKey' f key value mp@ @@ -366,38 +366,38 @@ insertWithKey f k = insertWith (f k) k insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) insertLookupWithKey combine !k v = toPair . start where - start (IntMap Empty) = Nothing :*: IntMap (NonEmpty k #! v # Tip) + start (IntMap Empty) = Nothing :*: IntMap (NonEmpty (Bound k) #! v # Tip) start (IntMap (NonEmpty min minV root)) - | k > min = let mv :*: root' = goL (xor min k) min root + | inMinBound k min = let mv :*: root' = goL (xor k min) min root in mv :*: IntMap (NonEmpty min minV root') - | k < min = Nothing :*: IntMap (NonEmpty k #! v # insertMinL (xor min k) min minV root) - | otherwise = Just minV :*: IntMap (NonEmpty k #! combine k v minV # root) + | outOfMinBound k min = Nothing :*: IntMap (NonEmpty (Bound k) #! v # insertMinL (xor k min) min minV root) + | otherwise = Just minV :*: IntMap (NonEmpty (Bound k) #! combine k v minV # root) - goL !_ _ Tip = Nothing :*: (Bin k #! v # Tip # Tip) + goL !_ _ Tip = Nothing :*: (Bin (Bound k) #! v # Tip # Tip) goL !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then let mv :*: l' = goL xorCache min l in mv :*: Bin max maxV l' r else let mv :*: r' = goR xorCacheMax max r in mv :*: Bin max maxV l r' - | k > max = if xor min max < xorCacheMax - then Nothing :*: (Bin k #! v # Bin max maxV l r # Tip) - else Nothing :*: (Bin k #! v # l # insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Nothing :*: (Bin (Bound k) #! v # Bin max maxV l r # Tip) + else Nothing :*: (Bin (Bound k) #! v # l # insertMaxR xorCacheMax max maxV r) | otherwise = Just maxV :*: (Bin max #! combine k v maxV # l # r) where xorCacheMax = xor k max - goR !_ _ Tip = Nothing :*: (Bin k #! v # Tip # Tip) + goR !_ _ Tip = Nothing :*: (Bin (Bound k) #! v # Tip # Tip) goR !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then let mv :*: r' = goR xorCache max r in mv :*: Bin min minV l r' else let mv :*: l' = goL xorCacheMin min l in mv :*: Bin min minV l' r - | k < min = if xor min max < xorCacheMin - then Nothing :*: (Bin k #! v # Tip # Bin min minV l r) - else Nothing :*: (Bin k #! v # insertMinL xorCacheMin min minV l # r) + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Nothing :*: (Bin (Bound k) #! v # Tip # Bin min minV l r) + else Nothing :*: (Bin (Bound k) #! v # insertMinL xorCacheMin min minV l # r) | otherwise = Just minV :*: (Bin min #! combine k v minV # l # r) - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. @@ -410,27 +410,27 @@ adjust f k = k `seq` start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV node)) - | k > min = IntMap (NonEmpty min minV (goL (xor min k) min node)) - | k < min = m + | inMinBound k min = IntMap (NonEmpty min minV (goL (xor k min) min node)) + | outOfMinBound k min = m | otherwise = IntMap (NonEmpty min #! f minV # node) goL !_ _ Tip = Tip goL !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goL xorCache min l) r else Bin max maxV l (goR xorCacheMax max r) - | k > max = n + | outOfMaxBound k max = n | otherwise = Bin max #! f maxV # l # r where xorCacheMax = xor k max goR !_ _ Tip = Tip goR !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goR xorCache max r) else Bin min minV (goL xorCacheMin min l) r - | k < min = n + | outOfMinBound k min = n | otherwise = Bin min #! f minV # l # r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. @@ -455,24 +455,24 @@ update f k = k `seq` start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV Tip)) - | k == min = case f minV of + | k == boundKey min = case f minV of Nothing -> IntMap Empty Just !minV' -> IntMap (NonEmpty min minV' Tip) | otherwise = m start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | k < min = m - | k == min = case f minV of + | outOfMinBound k min = m + | k == boundKey min = case f minV of Nothing -> let DR min' minV' root' = deleteMinL max maxV l r in IntMap (NonEmpty min' minV' root') Just !minV' -> IntMap (NonEmpty min minV' root) - | otherwise = IntMap (NonEmpty min minV (goL (xor min k) min root)) + | otherwise = IntMap (NonEmpty min minV (goL (xor k min) min root)) goL !_ _ Tip = Tip goL !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goL xorCache min l) r else Bin max maxV l (goR xorCacheMax max r) - | k > max = n + | outOfMaxBound k max = n | otherwise = case f maxV of Nothing -> extractBinL l r Just !maxV' -> Bin max maxV' l r @@ -480,14 +480,14 @@ update f k = k `seq` start goR !_ _ Tip = Tip goR !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goR xorCache max r) else Bin min minV (goL xorCacheMin min l) r - | k < min = n + | outOfMinBound k min = n | otherwise = case f minV of Nothing -> extractBinR l r Just !minV' -> Bin min minV' l r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. The expression (@'updateWithKey' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is @@ -514,44 +514,44 @@ updateLookupWithKey f k = k `seq` start where start (IntMap Empty) = (Nothing, IntMap Empty) start m@(IntMap (NonEmpty min minV Tip)) - | k == min = case f min minV of + | k == boundKey min = case f k minV of Nothing -> (Just minV, IntMap Empty) Just !minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) | otherwise = (Nothing, m) start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | k < min = (Nothing, m) - | k == min = case f min minV of + | outOfMinBound k min = (Nothing, m) + | k == boundKey min = case f k minV of Nothing -> let DR min' minV' root' = deleteMinL max maxV l r in (Just minV, IntMap (NonEmpty min' minV' root')) Just !minV' -> (Just minV, IntMap (NonEmpty min minV' root)) - | otherwise = let (mv, root') = goL (xor min k) min root + | otherwise = let (mv, root') = goL (xor k min) min root in (mv, IntMap (NonEmpty min minV root')) goL !_ _ Tip = (Nothing, Tip) goL !xorCache min n@(Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then let (mv, l') = goL xorCache min l in (mv, Bin max maxV l' r) else let (mv, r') = goR xorCacheMax max r in (mv, Bin max maxV l r') - | k > max = (Nothing, n) - | otherwise = case f max maxV of + | outOfMaxBound k max = (Nothing, n) + | otherwise = case f k maxV of Nothing -> (Just maxV, extractBinL l r) Just !maxV' -> (Just maxV, Bin max maxV' l r) where xorCacheMax = xor k max goR !_ _ Tip = (Nothing, Tip) goR !xorCache max n@(Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then let (mv, r') = goR xorCache max r in (mv, Bin min minV l r') else let (mv, l') = goL xorCacheMin min l in (mv, Bin min minV l' r) - | k < min = (Nothing, n) - | otherwise = case f min minV of + | outOfMinBound k min = (Nothing, n) + | otherwise = case f k minV of Nothing -> (Just minV, extractBinR l r) Just !minV' -> (Just minV, Bin min minV' l r) - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. @@ -619,129 +619,129 @@ unionWithKey combine = start start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) - | otherwise = IntMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 - - goL1 minV1 !min1 Tip !_ Tip = Bin min1 minV1 Tip Tip - goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor min1 min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | min1 > max2 = unionDisjointL minV1 min2 n2 min1 n1 - goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 - goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + | otherwise = IntMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + + goL1 minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip + goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = unionDisjointL minV1 min2 n2 min1 n1 + goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL1 minV1 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goL1 minV1 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - goL2 minV2 !_ Tip !min2 Tip = Bin min2 minV2 Tip Tip - goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor min1 min2) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | min2 > max1 = unionDisjointL minV2 min1 n1 min2 n2 - goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 - goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + goL2 minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip + goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor (boundKey min2) min1) min2 minV2 n2 + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = unionDisjointL minV2 min1 n1 min2 n2 + goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 + goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # l1 # goRFused max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l1 # goRFused max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goL2 minV2 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goL2 minV2 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' goLFused !_ Tip n2 = n2 goLFused !_ n1 Tip = n1 - goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # goLFused min l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goLFused min l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - goR1 maxV1 !max1 Tip !_ Tip = Bin max1 maxV1 Tip Tip - goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor max1 max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | min2 > max1 = unionDisjointR maxV1 max1 n1 max2 n2 - goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 - goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + goR1 maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip + goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor (boundKey max1) max2) max1 maxV1 n1 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = unionDisjointR maxV1 max1 n1 max2 n2 + goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR1 maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # goR1 maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - goR2 maxV2 !_ Tip !max2 Tip = Bin max2 maxV2 Tip Tip - goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor max1 max2) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | min1 > max2 = unionDisjointR maxV2 max2 n2 max1 n1 - goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 - goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + goR2 maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip + goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor (boundKey max2) max1) max2 maxV2 n2 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = unionDisjointR maxV2 max2 n2 max1 n1 + goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 + goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goR2 maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # goR2 maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' goRFused !_ Tip n2 = n2 goRFused !_ n1 Tip = n1 - goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> Bin min2 minV2 l2 (goRFused max n1 r2) EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # goRFused max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # goRFused max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goRFused max r1 n2) - goInsertL1 k v !_ _ Tip = Bin k #! v # Tip # Tip + goInsertL1 k v !_ _ Tip = Bin (Bound k) #! v # Tip # Tip goInsertL1 k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goInsertL1 k v xorCache min l) r else Bin max maxV l (goInsertR1 k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v (Bin max maxV l r) Tip + else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max #! combine k v maxV # l # r where xorCacheMax = xor k max - goInsertR1 k v !_ _ Tip = Bin k v Tip Tip + goInsertR1 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertR1 k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goInsertR1 k v xorCache max r) else Bin min minV (goInsertL1 k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v Tip (Bin min minV l r) + else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min #! combine k v minV # l # r - where xorCacheMin = xor min k + where xorCacheMin = xor k min - goInsertL2 k v !_ _ Tip = Bin k v Tip Tip + goInsertL2 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertL2 k v !xorCache min (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then Bin max maxV (goInsertL2 k v xorCache min l) r else Bin max maxV l (goInsertR2 k v xorCacheMax max r) - | k > max = if xor min max < xorCacheMax - then Bin k v (Bin max maxV l r) Tip - else Bin k v l (insertMaxR xorCacheMax max maxV r) + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then Bin (Bound k) v (Bin max maxV l r) Tip + else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max #! combine k maxV v # l # r where xorCacheMax = xor k max - goInsertR2 k v !_ _ Tip = Bin k v Tip Tip + goInsertR2 k v !_ _ Tip = Bin (Bound k) v Tip Tip goInsertR2 k v !xorCache max (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goInsertR2 k v xorCache max r) else Bin min minV (goInsertL2 k v xorCacheMin min l) r - | k < min = if xor min max < xorCacheMin - then Bin k v Tip (Bin min minV l r) - else Bin k v (insertMinL xorCacheMin min minV l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then Bin (Bound k) v Tip (Bin min minV l r) + else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min #! combine k minV v # l # r - where xorCacheMin = xor min k + where xorCacheMin = xor k min -- | The union of a list of maps, with a combining operation. -- @@ -774,47 +774,47 @@ differenceWithKey combine = start start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 min1 root1 min2 root2)) | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) - | otherwise = case combine min1 minV1 minV2 of + | otherwise = case combine (boundKey min1) minV1 minV2 of Nothing -> IntMap (goLFused min1 root1 root2) Just !minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep min1 root1 root2)) - goL1 minV1 min1 Tip min2 n2 = goLookupL min1 minV1 (xor min1 min2) n2 + goL1 minV1 min1 Tip min2 n2 = goLookupL (boundKey min1) minV1 (xor (boundKey min1) min2) n2 goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 Just !maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) Just !maxV1' -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) goL2 !_ Tip !_ !_ = Tip - goL2 min1 n1 min2 Tip = deleteL min2 (xor min1 min2) n1 - goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = n1 - goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goL2 min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 + goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 min1 n1 min2 l2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> goL2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> case goRFused max1 r1 r2 of Empty -> goL2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' Just !maxV1' -> Bin max1 maxV1' (goL2 min1 l1 min2 l2) (goRFusedKeep max1 r1 r2) - GT | xor min1 min2 < xor min2 max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' @@ -825,11 +825,11 @@ differenceWithKey combine = start loop Tip !_ = Empty loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of DR min' minV' n' -> NonEmpty min' minV' n' - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> loop n1 l2 EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 Just !maxV1' -> binL (loop l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) @@ -838,56 +838,56 @@ differenceWithKey combine = start where loop n1 Tip = n1 loop Tip !_ = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> loop n1 l2 EQ | max1 > max2 -> Bin max1 maxV1 (loop l1 l2) (goR2 max1 r1 max2 r2) | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> loop l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> case combine max1 maxV1 maxV2 of + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> case goRFused max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 Empty -> loop l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' Just !maxV1' -> Bin max1 maxV1' (loop l1 l2) (goRFusedKeep max1 r1 r2) GT -> Bin max1 maxV1 (loop l1 n2) r1 - goR1 maxV1 max1 Tip max2 n2 = goLookupR max1 maxV1 (xor max1 max2) n2 + goR1 maxV1 max1 Tip max2 n2 = goLookupR (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 Just !minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (goR1 maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) goR2 !_ Tip !_ !_ = Tip - goR2 max1 n1 max2 Tip = deleteR max2 (xor max1 max2) n1 - goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = n1 - goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goR2 max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 + goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 max1 n1 max2 r2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of Empty -> goR2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> case goLFused min1 l1 l2 of Empty -> goR2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (goR2 max1 r1 max2 r2) - GT | xor min1 max2 > xor max2 max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 @@ -898,11 +898,11 @@ differenceWithKey combine = start loop Tip !_ = Empty loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of DR max' maxV' n' -> NonEmpty max' maxV' n' - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> loop n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) - | otherwise -> case combine min1 minV1 minV2 of + | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (loop r1 r2) GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) @@ -911,40 +911,40 @@ differenceWithKey combine = start where loop n1 Tip = n1 loop Tip !_ = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> loop n1 r2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (loop r1 r2) | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of Empty -> loop r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> case combine min1 minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> case combine (boundKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 Nothing -> case goLFused min1 l1 l2 of Empty -> loop r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (loop r1 r2) GT -> Bin min1 minV1 l1 (loop r1 n2) - goLookupL k v !_ Tip = NonEmpty k v Tip + goLookupL k v !_ Tip = NonEmpty (Bound k) v Tip goLookupL k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL k v xorCache l else goLookupR k v xorCacheMax r - | k > max = NonEmpty k v Tip + | outOfMaxBound k max = NonEmpty (Bound k) v Tip | otherwise = case combine k v maxV of Nothing -> Empty - Just !v' -> NonEmpty k v' Tip + Just !v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max - goLookupR k v !_ Tip = NonEmpty k v Tip + goLookupR k v !_ Tip = NonEmpty (Bound k) v Tip goLookupR k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR k v xorCache r else goLookupL k v xorCacheMin l - | k < min = NonEmpty k v Tip + | outOfMinBound k min = NonEmpty (Bound k) v Tip | otherwise = case combine k v minV of Nothing -> Empty - Just !v' -> NonEmpty k v' Tip - where xorCacheMin = xor min k + Just !v' -> NonEmpty (Bound k) v' Tip + where xorCacheMin = xor k min dummyV = error "impossible" @@ -966,45 +966,45 @@ intersectionWithKey combine = start start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (goL2 minV2 min1 root1 min2 root2) | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) - | otherwise = IntMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. goL1 _ !_ !_ !_ Tip = Empty - goL1 minV1 min1 Tip min2 n2 = goLookupL1 min1 minV1 (xor min1 min2) n2 - goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | min1 > max2 = Empty - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 min1 < xor min1 max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + goL1 minV1 min1 Tip min2 n2 = goLookupL1 (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = Empty + goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 + | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine max1 maxV1 maxV2 # l' # goRFused max1 r1 r2) + Empty -> r2lMap (NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l' # goRFused max1 r1 r2) GT -> goL1 minV1 min1 l1 min2 n2 goL2 _ !_ Tip !_ !_ = Empty - goL2 minV2 min1 n1 min2 Tip = goLookupL2 min2 minV2 (xor min1 min2) n1 - goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | min2 > max1 = Empty - goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goL2 minV2 min1 n1 min2 Tip = goLookupL2 (boundKey min2) minV2 (xor (boundKey min2) min1) n1 + goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = Empty + goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 minV2 min1 n1 min2 l2 EQ | max1 > max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine max1 maxV1 maxV2 # l' # goRFused max1 r1 r2) - GT | xor min1 min2 < xor min2 max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 + Empty -> r2lMap (NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l' # goRFused max1 r1 r2) + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> r2lMap $ goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 #! combine max1 maxV1 maxV2 # goRFused max1 r1 (Bin min2 minV2 l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused max1 r1 (Bin min2 minV2 l2 r2) goLFused min = loop where loop Tip !_ = Tip loop !_ Tip = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of + loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> loop n1 l2 EQ | max1 > max2 -> case goR2 maxV2 max1 r1 max2 r2 of Empty -> loop l1 l2 @@ -1012,44 +1012,44 @@ intersectionWithKey combine = start | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of Empty -> loop l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> Bin max1 #! combine max1 maxV1 maxV2 # loop l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # loop l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> loop l1 n2 goR1 _ !_ !_ !_ Tip = Empty - goR1 maxV1 max1 Tip max2 n2 = goLookupR1 max1 maxV1 (xor max1 max2) n2 - goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | min2 > max1 = Empty - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of - LT | xor min2 max1 > xor max1 max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + goR1 maxV1 max1 Tip max2 n2 = goLookupR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = Empty + goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 + | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # r') + Empty -> l2rMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # r') GT -> goR1 maxV1 max1 r1 max2 n2 goR2 _ !_ Tip !_ !_ = Empty - goR2 maxV2 max1 n1 max2 Tip = goLookupR2 max2 maxV2 (xor max1 max2) n1 - goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | min1 > max2 = Empty - goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max1) (xor min2 max2) of + goR2 maxV2 max1 n1 max2 Tip = goLookupR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 + goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = Empty + goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 maxV2 max1 n1 max2 r2 EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) | otherwise -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # r') - GT | xor min1 max2 > xor max2 max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 + Empty -> l2rMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # r') + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> l2rMap $ goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 #! combine min1 minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) goRFused max = loop where loop Tip !_ = Tip loop !_ Tip = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of + loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> loop n1 r2 EQ | min1 < min2 -> case goL2 minV2 min1 l1 min2 l2 of Empty -> loop r1 r2 @@ -1057,44 +1057,44 @@ intersectionWithKey combine = start | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of Empty -> loop r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> Bin min1 #! combine min1 minV1 minV2 # goLFused min1 l1 l2 # loop r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # loop r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> loop r1 n2 goLookupL1 !_ _ !_ Tip = Empty goLookupL1 k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL1 k v xorCache l else goLookupR1 k v xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k #! combine k v maxV # Tip + | outOfMaxBound k max = Empty + | otherwise = NonEmpty (Bound k) #! combine k v maxV # Tip where xorCacheMax = xor k max goLookupR1 !_ _ !_ Tip = Empty goLookupR1 k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR1 k v xorCache r else goLookupL1 k v xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k #! combine k v minV # Tip - where xorCacheMin = xor min k + | outOfMinBound k min = Empty + | otherwise = NonEmpty (Bound k) #! combine k v minV # Tip + where xorCacheMin = xor k min goLookupL2 !_ _ !_ Tip = Empty goLookupL2 k v !xorCache (Bin max maxV l r) - | k < max = if xorCache < xorCacheMax + | inMaxBound k max = if xorCache < xorCacheMax then goLookupL2 k v xorCache l else goLookupR2 k v xorCacheMax r - | k > max = Empty - | otherwise = NonEmpty k #! combine k maxV v # Tip + | outOfMaxBound k max = Empty + | otherwise = NonEmpty (Bound k) #! combine k maxV v # Tip where xorCacheMax = xor k max goLookupR2 !_ _ !_ Tip = Empty goLookupR2 k v !xorCache (Bin min minV l r) - | k > min = if xorCache < xorCacheMin + | inMinBound k min = if xorCache < xorCacheMin then goLookupR2 k v xorCache r else goLookupL2 k v xorCacheMin l - | k < min = Empty - | otherwise = NonEmpty k #! combine k minV v # Tip - where xorCacheMin = xor min k + | outOfMinBound k min = Empty + | otherwise = NonEmpty (Bound k) #! combine k minV v # Tip + where xorCacheMin = xor k min -- | /O(n+m)/. An unsafe general combining function. -- @@ -1131,7 +1131,7 @@ intersectionWithKey combine = start -- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@. mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) -> IntMap a -> IntMap b -> IntMap c mergeWithKey matched miss1 miss2 = Merge.merge (Merge.mapMaybeMissing (single miss1)) (Merge.mapMaybeMissing (single miss2)) (Merge.zipWithMaybeMatched matched) where - single miss k v = case miss (IntMap (NonEmpty k v Tip)) of + single miss k v = case miss (IntMap (NonEmpty (Bound k) v Tip)) of IntMap Empty -> Nothing IntMap (NonEmpty _ v' _) -> Just v' @@ -1158,13 +1158,13 @@ mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b mapWithKey f = start where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f min minV # goL root) + start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f (boundKey min) minV # goL root) goL Tip = Tip - goL (Bin k v l r) = Bin k #! f k v # goL l # goR r + goL (Bin k v l r) = Bin k #! f (boundKey k) v # goL l # goR r goR Tip = Tip - goR (Bin k v l r) = Bin k #! f k v # goL l # goR r + goR (Bin k v l r) = Bin k #! f (boundKey k) v # goL l # goR r -- | /O(n)/. @@ -1178,13 +1178,13 @@ traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b traverseWithKey f = start where start (IntMap Empty) = pure (IntMap Empty) - start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f min minV <*> goL root + start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f (boundKey min) minV <*> goL root goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max #! maxV' # l' # r') <$> goL l <*> goR r <*> f max maxV + goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max #! maxV' # l' # r') <$> goL l <*> goR r <*> f (boundKey max) maxV goR Tip = pure Tip - goR (Bin min minV l r) = (\minV' l' r' -> Bin min #! minV' # l' # r') <$> f min minV <*> goL l <*> goR r + goR (Bin min minV l r) = (\minV' l' r' -> Bin min #! minV' # l' # r') <$> f (boundKey min) minV <*> goL l <*> goR r -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. @@ -1204,7 +1204,7 @@ mapAccumWithKey f = start where start a (IntMap Empty) = (a, IntMap Empty) start a (IntMap (NonEmpty min minV root)) = - let (a', !minV') = f a min minV + let (a', !minV') = f a (boundKey min) minV (a'', root') = goL root a' in (a'', IntMap (NonEmpty min minV' root')) @@ -1212,12 +1212,12 @@ mapAccumWithKey f = start goL (Bin max maxV l r) a = let (a', l') = goL l a (a'', r') = goR r a' - (a''', !maxV') = f a'' max maxV + (a''', !maxV') = f a'' (boundKey max) maxV in (a''', Bin max maxV' l' r') goR Tip a = (a, Tip) goR (Bin min minV l r) a = - let (a', !minV') = f a min minV + let (a', !minV') = f a (boundKey min) minV (a'', l') = goL l a' (a''', r') = goR r a'' in (a''', Bin min minV' l' r') @@ -1230,12 +1230,12 @@ mapAccumRWithKey f = start start a (IntMap Empty) = (a, IntMap Empty) start a (IntMap (NonEmpty min minV root)) = let (a', root') = goL root a - (a'', !minV') = f a' min minV + (a'', !minV') = f a' (boundKey min) minV in (a'', IntMap (NonEmpty min minV' root')) goL Tip a = (a, Tip) goL (Bin max maxV l r) a = - let (a', !maxV') = f a max maxV + let (a', !maxV') = f a (boundKey max) maxV (a'', r') = goR r a' (a''', l') = goL l a'' in (a''', Bin max maxV' l' r') @@ -1244,7 +1244,7 @@ mapAccumRWithKey f = start goR (Bin min minV l r) a = let (a', r') = goR r a (a'', l') = goL l a' - (a''', !minV') = f a'' min minV + (a''', !minV') = f a'' (boundKey min) minV in (a''', Bin min minV' l' r') -- | /O(n*min(n,W))/. @@ -1329,10 +1329,10 @@ fromAscList = start where start [] = IntMap Empty start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) - go !k v [] !stk = completeBuildStack k v Tip stk + go !k v [] !stk = completeBuildStack (Bound k) v Tip stk go !k v ((!next, nextV) : rest) !stk | next == k = nextV `seq` go k nextV rest stk - | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k next) k v Tip stk) + | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order. @@ -1353,10 +1353,10 @@ fromAscListWithKey f = start where start [] = IntMap Empty start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) - go !k v [] !stk = completeBuildStack k v Tip stk + go !k v [] !stk = completeBuildStack (Bound k) v Tip stk go !k v ((!next, nextV) : rest) !stk | next == k = let !v' = f k nextV v in go k v' rest stk - | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k next) k v Tip stk) + | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. @@ -1368,8 +1368,8 @@ fromDistinctAscList = start where start [] = IntMap Empty start ((!min, !minV) : rest) = IntMap (go min minV rest StackBase) - go !k !v [] !stk = completeBuildStack k v Tip stk - go !k !v ((!next, !nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k next) k v Tip stk) + go !k !v [] !stk = completeBuildStack (Bound k) v Tip stk + go !k !v ((!next, !nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) -- | /O(n)/. Map values and collect the 'Just' results. -- @@ -1386,38 +1386,38 @@ mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b mapMaybeWithKey f = start where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = case f min minV of + start (IntMap (NonEmpty min minV root)) = case f (boundKey min) minV of Just !minV' -> IntMap (NonEmpty min minV' (goL root)) Nothing -> IntMap (goDeleteL root) goL Tip = Tip - goL (Bin max maxV l r) = case f max maxV of + goL (Bin max maxV l r) = case f (boundKey max) maxV of Just !maxV' -> Bin max maxV' (goL l) (goR r) Nothing -> case goDeleteR r of Empty -> goL l NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' goR Tip = Tip - goR (Bin min minV l r) = case f min minV of + goR (Bin min minV l r) = case f (boundKey min) minV of Just !minV' -> Bin min minV' (goL l) (goR r) Nothing -> case goDeleteL l of Empty -> goR r NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) goDeleteL Tip = Empty - goDeleteL (Bin max maxV l r) = case f max maxV of + goDeleteL (Bin max maxV l r) = case f (boundKey max) maxV of Just !maxV' -> case goDeleteL l of Empty -> case goR r of - Tip -> NonEmpty max maxV' Tip + Tip -> NonEmpty (maxToMin max) maxV' Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR r)) Nothing -> binL (goDeleteL l) (goDeleteR r) goDeleteR Tip = Empty - goDeleteR (Bin min minV l r) = case f min minV of + goDeleteR (Bin min minV l r) = case f (boundKey min) minV of Just !minV' -> case goDeleteR r of Empty -> case goL l of - Tip -> NonEmpty min minV' Tip + Tip -> NonEmpty (minToMax min) minV' Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL l) r') Nothing -> binR (goDeleteL l) (goDeleteR r) @@ -1445,14 +1445,14 @@ mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) mapEitherWithKey func = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) - start (IntMap (NonEmpty min minV root)) = case func min minV of + start (IntMap (NonEmpty min minV root)) = case func (boundKey min) minV of Left !v -> let t :*: f = goTrueL root in (IntMap (NonEmpty min v t), IntMap f) Right !v -> let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min v f)) goTrueL Tip = Tip :*: Empty - goTrueL (Bin max maxV l r) = case func max maxV of + goTrueL (Bin max maxV l r) = case func (boundKey max) maxV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin max v tl tr :*: binL fl fr @@ -1467,7 +1467,7 @@ mapEitherWithKey func = start in t :*: f goTrueR Tip = Tip :*: Empty - goTrueR (Bin min minV l r) = case func min minV of + goTrueR (Bin min minV l r) = case func (boundKey min) minV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin min v tl tr :*: binR fl fr @@ -1482,7 +1482,7 @@ mapEitherWithKey func = start in t :*: f goFalseL Tip = Empty :*: Tip - goFalseL (Bin max maxV l r) = case func max maxV of + goFalseL (Bin max maxV l r) = case func (boundKey max) maxV of Left !v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -1497,7 +1497,7 @@ mapEitherWithKey func = start in binL tl tr :*: Bin max v fl fr goFalseR Tip = Empty :*: Tip - goFalseR (Bin min minV l r) = case func min minV of + goFalseR (Bin min minV l r) = case func (boundKey min) minV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of From 0288e2865fb6ca5d849701e427312345bdae83af Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 25 Dec 2019 23:11:37 -0600 Subject: [PATCH 042/147] Undo unintentional changes to tests and deprecated functions --- containers-tests/tests/intmap-properties.hs | 86 ++++++++++++++++++-- containers/src/Data/IntMap.hs | 53 ++++++------ containers/src/Data/IntMap/Internal/Debug.hs | 8 +- 3 files changed, 106 insertions(+), 41 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 697d34807..52dc200f4 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -155,6 +155,8 @@ main = defaultMain , testProperty "intersectionWith model" prop_intersectionWithModel , testProperty "intersectionWithKey model" prop_intersectionWithKeyModel , testProperty "mergeWithKey model" prop_mergeWithKeyModel + , testProperty "merge valid" prop_merge_valid + , testProperty "mergeA effects" prop_mergeA_effects , testProperty "union==merge" prop_unionEqMerge , testProperty "difference==merge" prop_differenceEqMerge , testProperty "intersection==merge" prop_intersectionEqMerge @@ -230,6 +232,8 @@ newtype NonEmptyIntMap a = NonEmptyIntMap {getNonEmptyIntMap :: IntMap a} derivi instance Arbitrary a => Arbitrary (NonEmptyIntMap a) where arbitrary = fmap (NonEmptyIntMap . fromList . getNonEmpty) arbitrary +-- | A wrapper around IntMap with a Show instance based on showTree to aid in debugging when +-- tests fail newtype PrettyIntMap a = PIM { unPIM :: IntMap a } deriving (Eq) instance Arbitrary a => Arbitrary (PrettyIntMap a) where @@ -802,9 +806,36 @@ test_toDescList = do toDescList (fromList [(5,"a"), (-3,"b")]) @?= [(5,"a"), (-3,"b")] test_showTree :: Assertion -test_showTree = - (let t = fromDistinctAscList [(x,()) | x <- [1..5]] - in showTree t) @?= "1 ()\n+--5 ()\n |\n +--3 ()\n | |\n | +-.\n | |\n | +--2 ()\n | |\n | +-.\n | |\n | +-.\n |\n +--4 ()\n |\n +-.\n |\n +-.\n" +test_showTree = do + showTree posTree @?= expectedPosTree + showTree negTree @?= expectedNegTree + where mkAscTree ls = fromDistinctAscList [(x,()) | x <- ls] + posTree = mkAscTree [1..5] + negTree = mkAscTree [(-2)..2] + expectedPosTree = unlines + [ "1:=()" + , "+-- 5:=()" + , " +-- 3:=()" + , " | +-*" + , " | +-- 2:=()" + , " | +-*" + , " | +-*" + , " +-- 4:=()" + , " +-*" + , " +-*" + ] + expectedNegTree = unlines + [ "-2:=()" + , "+-- 2:=()" + , " +-- -1:=()" + , " | +-*" + , " | +-*" + , " +-- 0:=()" + , " +-- 1:=()" + , " | +-*" + , " | +-*" + , " +-*" + ] test_fromAscList :: Assertion test_fromAscList = do @@ -1243,9 +1274,17 @@ prop_withoutKeys m s0 = where s = keysSet s0 -prop_mergeWithKeyModel :: Fun (Int, Int, Int) (Maybe Int) -> Bool -> Bool -> [(Int,Int)] -> [(Int,Int)] -> Bool -prop_mergeWithKeyModel f keep_x keep_y xs ys - = testMergeWithKey (apply3 f) keep_x keep_y +prop_mergeWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_mergeWithKeyModel xs ys + = and [ testMergeWithKey f keep_x keep_y + | f <- [ \_k x1 _x2 -> Just x1 + , \_k _x1 x2 -> Just x2 + , \_k _x1 _x2 -> Nothing + , \k x1 x2 -> if k `mod` 2 == 0 then Nothing else Just (2 * x1 + 3 * x2) + ] + , keep_x <- [ True, False ] + , keep_y <- [ True, False ] + ] where xs' = List.nubBy ((==) `on` fst) xs ys' = List.nubBy ((==) `on` fst) ys @@ -1270,14 +1309,43 @@ prop_mergeWithKeyModel f keep_x keep_y xs ys -- warnings are issued if testMergeWithKey gets inlined. {-# NOINLINE testMergeWithKey #-} +prop_merge_valid + :: Fun (Key, A) (Maybe C) + -> Fun (Key, B) (Maybe C) + -> Fun (Key, A, B) (Maybe C) + -> IntMap A + -> IntMap B + -> Bool +prop_merge_valid whenMissingA whenMissingB whenMatched xs ys + = valid m + where + m = + merge + (mapMaybeMissing (applyFun2 whenMissingA)) + (mapMaybeMissing (applyFun2 whenMissingB)) + (zipWithMaybeMatched (applyFun3 whenMatched)) + xs + ys + +-- This uses the instance +-- Monoid a => Applicative ((,) a) +-- to test that effects are sequenced in ascending key order. +prop_mergeA_effects :: UMap -> UMap -> Property +prop_mergeA_effects xs ys + = effects === sort effects + where + (effects, _m) = mergeA whenMissing whenMissing whenMatched xs ys + whenMissing = traverseMissing (\k _ -> ([k], ())) + whenMatched = zipWithAMatched (\k _ _ -> ([k], ())) + prop_unionEqMerge :: UMap -> UMap -> Property -prop_unionEqMerge m1 m2 = union m1 m2 === merge preserveMissing preserveMissing (zipWithMatched (\_ x _ -> x)) m1 m2 +prop_unionEqMerge m1 m2 = PIM (union m1 m2) === PIM (merge preserveMissing preserveMissing (zipWithMatched (\_ x _ -> x)) m1 m2) prop_differenceEqMerge :: UMap -> UMap -> Property -prop_differenceEqMerge m1 m2 = difference m1 m2 === merge preserveMissing dropMissing (zipWithMaybeMatched (\_ _ _ -> Nothing)) m1 m2 +prop_differenceEqMerge m1 m2 = PIM (difference m1 m2) === PIM (merge preserveMissing dropMissing (zipWithMaybeMatched (\_ _ _ -> Nothing)) m1 m2) prop_intersectionEqMerge :: UMap -> UMap -> Property -prop_intersectionEqMerge m1 m2 = intersection m1 m2 === merge dropMissing dropMissing (zipWithMatched (\_ x _ -> x)) m1 m2 +prop_intersectionEqMerge m1 m2 = PIM (intersection m1 m2) === PIM (merge dropMissing dropMissing (zipWithMatched (\_ x _ -> x)) m1 m2) prop_mergeEqMergeA :: Fun Int Bool -> Fun Int Bool -> Fun Int Bool -> UMap -> UMap -> Property prop_mergeEqMergeA pMiss1 pMiss2 pMatch m1 m2 = PIM merged === PIM mergedA where diff --git a/containers/src/Data/IntMap.hs b/containers/src/Data/IntMap.hs index b62f6f68d..495b0a2d0 100644 --- a/containers/src/Data/IntMap.hs +++ b/containers/src/Data/IntMap.hs @@ -57,36 +57,33 @@ module Data.IntMap #endif ) where -import Prelude hiding (foldr) -import qualified Data.IntMap.Strict as Strict import Data.IntMap.Lazy --- | /O(log n)/. Same as 'insertWith', but the result of the combining function --- is evaluated to WHNF before inserted to the map. -{-# DEPRECATED insertWith' "As of version 0.5, replaced by 'Data.IntMap.Strict.insertWith'." #-} -{-# INLINE insertWith' #-} -insertWith' :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith' = Strict.insertWith +#ifdef __GLASGOW_HASKELL__ +import Utils.Containers.Internal.TypeError + +-- | This function is being removed and is no longer usable. +-- Use 'Data.IntMap.Strict.insertWith' +insertWith' :: Whoops "Data.IntMap.insertWith' is gone. Use Data.IntMap.Strict.insertWith." + => (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWith' _ _ _ _ = undefined --- | /O(log n)/. Same as 'insertWithKey', but the result of the combining --- function is evaluated to WHNF before inserted to the map. -{-# DEPRECATED insertWithKey' "As of version 0.5, replaced by 'Data.IntMap.Strict.insertWithKey'." #-} -{-# INLINE insertWithKey' #-} -insertWithKey' :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWithKey' = Strict.insertWithKey +-- | This function is being removed and is no longer usable. +-- Use 'Data.IntMap.Strict.insertWithKey'. +insertWithKey' :: Whoops "Data.IntMap.insertWithKey' is gone. Use Data.IntMap.Strict.insertWithKey." + => (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithKey' _ _ _ _ = undefined --- | /O(n)/. Fold the values in the map using the given --- right-associative binary operator. This function is an equivalent --- of 'foldr' and is present for compatibility only. -{-# DEPRECATED fold "As of version 0.5, replaced by 'foldr'." #-} -{-# INLINE fold #-} -fold :: (a -> b -> b) -> b -> IntMap a -> b -fold = foldr --- | /O(n)/. Fold the keys and values in the map using the given --- right-associative binary operator. This function is an equivalent --- of 'foldrWithKey' and is present for compatibility only. -{-# DEPRECATED foldWithKey "As of version 0.5, replaced by 'foldrWithKey'." #-} -{-# INLINE foldWithKey #-} -foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b -foldWithKey = foldrWithKey +-- | This function is being removed and is no longer usable. +-- Use 'Data.IntMap.Lazy.foldr'. +fold :: Whoops "Data.IntMap.fold' is gone. Use Data.IntMap.foldr or Prelude.foldr." + => (a -> b -> b) -> b -> IntMap a -> b +fold _ _ _ = undefined + +-- | This function is being removed and is no longer usable. +-- Use 'foldrWithKey'. +foldWithKey :: Whoops "Data.IntMap.foldWithKey is gone. Use foldrWithKey." + => (Key -> a -> b -> b) -> b -> IntMap a -> b +foldWithKey _ _ _ = undefined +#endif diff --git a/containers/src/Data/IntMap/Internal/Debug.hs b/containers/src/Data/IntMap/Internal/Debug.hs index 2773c376c..3fbe50ccd 100644 --- a/containers/src/Data/IntMap/Internal/Debug.hs +++ b/containers/src/Data/IntMap/Internal/Debug.hs @@ -10,13 +10,13 @@ import Data.IntMap.Internal showTree :: Show a => IntMap a -> String showTree = unlines . aux where aux (IntMap Empty) = [] - aux (IntMap (NonEmpty min minV node)) = (show (boundKey min) ++ " " ++ show minV) : auxNode False node + aux (IntMap (NonEmpty min minV node)) = (show (boundKey min) ++ ":=" ++ show minV) : auxNode False node auxNode :: Show a => Bool -> Node t a -> [String] - auxNode _ Tip = ["+-."] - auxNode lined (Bin bound val l r) = ["+--" ++ show (boundKey bound) ++ " " ++ show val, prefix : " |"] ++ fmap indent (auxNode True l) ++ [prefix : " |"] ++ fmap indent (auxNode False r) + auxNode _ Tip = ["+-*"] + auxNode lined (Bin bound val l r) = ["+-- " ++ show (boundKey bound) ++ ":=" ++ show val] ++ fmap indent (auxNode True l) ++ fmap indent (auxNode False r) where prefix = if lined then '|' else ' ' - indent line = prefix : " " ++ line + indent line = prefix : " " ++ line showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String showTreeWith _ _ = showTree From d5f502e14af46edf494c3719097906e40029f83b Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 26 Dec 2019 03:04:33 -0600 Subject: [PATCH 043/147] Document the new IntMap structure by importing the original explanation (with edits) Also document the bit fiddling that makes it run --- containers/src/Data/IntMap/Internal.hs | 260 ++++++++++++++++++++++++- 1 file changed, 259 insertions(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 74714d846..a072f5b4b 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -32,6 +32,230 @@ -- This defines the data structures and core (hidden) manipulations -- on representations. -- +-- = Tree Structure +-- +-- This implementation is based on a tree structure isomorphic to /big-endian patricia +-- trees/, saving space and time by not storing data in the leaves (so not needing to +-- allocate memory for them) and not storing which bit to split on in nodes. Alternatively, it +-- can be viewed as a vantage-point tree under the xor metric. +-- +-- = Derivation +-- +-- It may be instructive to build up the tree structure as a series of optimizations transforming +-- a simple data structure (a bitwise trie). +-- +-- == The basic integer map: the bitwise trie +-- +-- We are trying to create an efficient, simple mapping from integers to values. The most common +-- approaches for these are hash tables, which are not persistent (though we can come close with +-- HAMTs), and binary search trees, which work well, but don't use any special properties of the +-- integer. To come up with this mapping, we need to think of integers not as numbers but as +-- strings of bits. With that perspective, we can use the standard /trie/ data structure to +-- build our mapping. As bits are particularly simple, so is the resulting structure: +-- +-- > data IntMap a = Bin (IntMap a) (IntMap a) | Tip a | Nil +-- +-- The `Bin` constructor represents a bitwise branch, and the `Tip` constructor comes after (on a +-- 64-bit machine) 64 `Bin` construtors in the tree. The associated basic operations navigate the +-- tree by reading a key bit by bit, taking the branch associated with the current bit: +-- +-- > lookup :: Int -> IntMap a -> Maybe a +-- > lookup k = go (finiteBitSize k - 1) +-- > where +-- > go b (Bin l r) = if testBit k b +-- > then go (b - 1) l +-- > else go (b - 1) r +-- > go _ (Tip x) = Just x +-- > go _ Nil = Nothing +-- > +-- > insert :: Int -> a -> IntMap a -> IntMap a +-- > insert k a = go (finiteBitSize k - 1) +-- > where +-- > go (-1) _ = Tip a +-- > go b (Bin l r) = if testBit k b +-- > then Bin (go (b - 1) l) r +-- > else Bin l (go (b - 1) r) +-- > go b _ = if testBit b k +-- > then Bin (go (b + 1) Nil) Nil +-- > else Bin Nil (go (b + 1) Nil) +-- +-- 'delete' follows similarly, and the uniform structure means that even 'union' isn't too hard, +-- a welcome fact given the complexity of merging binary search trees. Unfortunately, this +-- approach is horribly slow and space-inefficient. To see why, look at the tree structure +-- for @'singleton' 5 "hello"@: +-- +-- > +-0-. +-- > | +-0-. +-- > | | +-0-. +-- > | | | +-0-. +-- > | | | | +-0-. +-- > | | | | | +-0-. +-- > | | | | | | +-0-. +-- > | | | | | | | +-0-. +-- > | | | | | | | | +-0-. +-- > | | | | | | | | | +-0-. +-- > | | | | | | | | | | +-0-. +-- > | | | | | | | | | | | +-0-. +-- > | | | | | | | | | | | | +-0-. +-- > | | | | | | | | | | | | | +-0- +-- > | | | | | | | | | | | | | +-1-. +-- > | | | | | | | | | | | | | +-0-. +-- > | | | | | | | | | | | | | | +-0- +-- > | | | | | | | | | | | | | | +-1- "hello" +-- > | | | | | | | | | | | | | +-1- +-- > | | | | | | | | | | | | +-1- +-- > | | | | | | | | | | | +-1- +-- > | | | | | | | | | | +-1- +-- > | | | | | | | | | +-1- +-- > | | | | | | | | +-1- +-- > | | | | | | | +-1- +-- > | | | | | | +-1- +-- > | | | | | +-1- +-- > | | | | +-1- +-- > | | | +-1- +-- > | | +-1- +-- > | +-1- +-- > +-1- +-- +-- Note that, for brevity, the word size is 16 bits. The diagram would be 4 times longer for a +-- 64-bit system. In this atrocious tree structure, there is one pointer for every bit, a 64-fold +-- explosion in space. Arguably worse is the fact that every single 'lookup', 'insert', or +-- 'delete' must traverse 64 pointers, resulting in 64 cache misses and a terrible runtime. +-- +-- == Path compression: PATRICIA trees and the previous version of 'Data.IntMap' +-- +-- To reduce the space usage, we can compress nodes that only have one child. Since they form a +-- linear chain, we can concatenate the bits within that chain, storing what branches would be +-- taken. For example, again temporarily shortening the word size to 16 bits: +-- +-- >>> singleton 5 "hello" +-- +-0000000000000101- "hello" +-- +-- >>> fromList [(1, "1"), (4, "4"), (5, "5")] +-- +-0000000000000-. +-- +-001- "1" +-- +-10-. +-- +-0- "4" +-- +-1- "5" +-- +-- This is much more space efficient, and the basic operations, while more complicated, are still +-- straightforward. In Haskell, the structure is +-- +-- > data IntMap a = Bin Prefix Mask (IntMap a) (IntMap a) | Tip Int a | Nil +-- +-- The @Mask@ tells how long the @Prefix@ is, and the @Int@ in the @Tip@ nodes avoids using @Bin@ +-- for singletons. This representation is known as the big-endian PATRICIA tree and is what the +-- previous iteration of 'IntMap' used. +-- +-- == Implicit prefixes: a simpler representation +-- +-- In the PATRICIA tree representation, we explicitly stored the common prefix of all the keys in +-- a subtree. However, this prefix is not needed if we know what the minimum and maximum keys. The +-- common prefix of a set of keys is the same as the common prefix of the minimum and maximum. +-- Replacing the @Prefix@, @Mask@ pair with a minimum and maximum, we get +-- +-- > data IntMap a = Bin MinBound MaxBound (IntMap a) (IntMap a) | Tip Int a | Nil +-- +-- Some examples: +-- >>> singleton 5 "hello" +-- +-5- "hello" +-- +-- >>> fromList [(1, "1"), (4, "4"), (5, "5")] +-- +-(1,5)-. +-- +-1- "1" +-- +-(4,5)-. +-- +-4- "4" +-- +-5- "5" +-- +-- Traversing this tree efficiently is a bit more difficult, but still possible. See 'xor' for +-- details. Moreover, since it gives exact minimums and maximums, 'lookup's can already be more +-- efficient than in a PATRICIA tree since they can terminate with 'Nothing' as soon as a key +-- is out of the bounds of a subtree, even if it matches the prefix of common bits. However, +-- there are bigger gains to be had. +-- +-- == Removing redundancy +-- The above representation store many keys repeatedly. In the @{1,4,5}@ example, 1 was stored +-- twice, 4 was stored twice, and 5 was stored three times. The minimum and maximum keys of a +-- tree are necessarily keys stored in that tree and moreover are minima and maxima of subtrees. +-- In the {1,4,5} example, we know from the root node that the minimum is 1 and the maximum is 5. +-- At the first branch, we split the set into two parts, @{1}@ and @{4,5}@. However, the minimum +-- of the set of smaller keys is exactly the minimum of the original set. Similarly, the maximum +-- of the set of larger keys is exactly the maximum of the original set. +-- +-- We can restructure the tree to only store 1 new value at each branch, removing the redundancy. +-- In nodes storing a set of smaller keys, we already know the minimum when traversing the tree +-- downward, so we only need to store the new maximum. In nodes storing a set of larger keys, we +-- know the maximum and store the new minimum. The root still needs both the minimum and the +-- maximum, so we need an extra layer to store that information: +-- +-- > data IntMap a = Empty | NonEmpty Bound (Node a) +-- > data Node a = Bin Bound (Node a) (Node a) | Tip a +-- +-- The trees are no longer quite as easy to read at a glance, since keys are no longer available +-- in order at the leaves, and it can be difficult to tell the difference at a glance between a node +-- storing a minimum and a node storing a maximum (the actual implementation uses phantom types to +-- ensure no code gets this wrong). +-- +-- >>> singleton 5 "hello" +-- 5 +-- +- "hello" +-- +-- >>> fromList [(1, "1"), (4, "4"), (5, "5")] +-- 1 +-- +-5-. +-- +- "1" +-- +-4-. +-- +- "4" +-- +- "5" +-- +-- Unfortunately, these nonuniformities do translate to code complexity, but we have already saved +-- a whole word in every node and every leaf. +-- +-- == Moving the values upward +-- +-- The previous section removed the redundancy in keys perfectly, storing each key only once. +-- However, the values are still stored at the leaf, now far away from their associated keys. +-- There is no reason this has to be true now that keys have a unique location in the tree. +-- By moving the values upward in the tree, we simplify: +-- +-- > data IntMap a = Empty | NonEmpty Bound a (Node a) +-- > data Node a = Bin Bound a (Node a) (Node a) | Tip +-- +-- Although nodes still switch between minima and maxima, they can be visualized and manipulated +-- much more cleanly since it is clear which keys are tied to which values. +-- +-- >>> singleton 5 "hello" +-- 5 "hello" +-- +- +-- +-- >>> fromList [(1, "1"), (4, "4"), (5, "5")] +-- 1 "1" +-- +-5-. "5" +-- +- +-- +-4-. "4" +-- +- +-- +- +-- +-- This simpler representation translates to even more savings in both space and time. Since +-- the leaves no longer store any information, GHC will create a single static @Tip@ object +-- and reuse it between all the leaves, the equivalent of representing leaves with a null pointer, +-- saving on allocations and the metadata necessary for garbage collection and lazy evaluation. +-- Additionally, successful lookups can terminate as soon as they see the correct key instead of +-- dereferencing a chain of pointers all the way to the leaves. This means fewer cache misses and +-- a shorter loop. +-- +-- = References +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- . +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve +-- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), +-- October 1968, pages 514-534. +-- * Edward Kmett, \"/Revisiting Matrix Multiplication, Part IV: IntMap!?/\", +-- School of Haskell, 25 August 2013, +-- . +-- -- @since 0.5.9 ----------------------------------------------------------------------------- @@ -71,11 +295,42 @@ type Key = Int i2w :: Int -> Word i2w = fromIntegral --- We need to compare xors using unsigned comparisons +-- | Xor a key with a bound for the purposes of navigation within the tree. +-- +-- The navigation process is as follows. Suppose we are looking up a key `k` in a tree. We know +-- the minimum key in the tree, `min`, and the maximum key, `max`. Represented in binary: +-- +-- > shared prefix bit to split on +-- > /----------\ / +-- > min: 010010010101 0 ???????? +-- > max: 010010010101 1 ???????? +-- > k: 010010010101 ? ???????? +-- +-- To figure out in which subtree might contain `k`, we need to know whether the bit to split on +-- is zero or one. Now, if it is zero, then +-- +-- > xor k min: 000000000000 0 ???????? +-- > xor k max: 000000000000 1 ???????? +-- +-- If it is one: +-- +-- > xor k min: 000000000000 1 ???????? +-- > xor k max: 000000000000 0 ???????? +-- +-- Therefore, the splitting bit is set iff `xor k min > xor k max`. Put another way, the key +-- shares more bits with the bound that it is closer to under the xor metric, since exclusive or +-- maps shared bits to zero. The metric perspective also makes it clear why this works unmodified +-- in the presence of negative numbers, despite storing negative numbers (with a set sign bit) in +-- the left branch normally identified with an unset bit. As long as the comparison is done +-- unsigned (metrics are always nonnegative), negative integers will be closer to other negative +-- integers than they are to nonnegative integers. {-# INLINE xor #-} xor :: Key -> Bound t -> Word xor a (Bound b) = Data.Bits.xor (i2w a) (i2w b) +-- | Xor the minimum and maximum keys of a tree. The most significant bit of the result indicates +-- which bit to split on for navigation and is useful in merging maps to tell whether nodes from +-- different maps branch at the same time. {-# INLINE xorBounds #-} xorBounds :: Bound L -> Bound R -> Word xorBounds (Bound min) (Bound max) = Data.Bits.xor (i2w min) (i2w max) @@ -1797,10 +2052,13 @@ maxViewWithKey m = let (k, a) = findMax m -- | /O(1)/. Returns whether the most significant bit of its first -- argument is less significant than the most significant bit of its -- second argument. + +-- This works by measuring whether x is in between 0 and y but closer to 0 (in the xor metric). {-# INLINE ltMSB #-} ltMSB :: Word -> Word -> Bool ltMSB x y = x < y && x < Data.Bits.xor x y +-- See 'ltMSB' for why this works {-# INLINE compareMSB #-} compareMSB :: Word -> Word -> Ordering compareMSB x y = case compare x y of From f62ccd519689b91a39ff10768d4a78a18c8dae5b Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 26 Dec 2019 13:20:37 -0600 Subject: [PATCH 044/147] Edit IntMap.Internal derivation documentation --- containers/src/Data/IntMap/Internal.hs | 199 +++++++++++++------------ 1 file changed, 101 insertions(+), 98 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index a072f5b4b..677896f86 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -34,30 +34,38 @@ -- -- = Tree Structure -- --- This implementation is based on a tree structure isomorphic to /big-endian patricia --- trees/, saving space and time by not storing data in the leaves (so not needing to --- allocate memory for them) and not storing which bit to split on in nodes. Alternatively, it --- can be viewed as a vantage-point tree under the xor metric. +-- This implementation uses a novel modification of /big-endian patricia trees/, structured +-- as a vantage-point tree under the xor metric. -- -- = Derivation -- --- It may be instructive to build up the tree structure as a series of optimizations transforming --- a simple data structure (a bitwise trie). +-- At its core, 'IntMap'\'s representation can be derived by a series of optimizations from +-- simpler structures: +-- +-- * A bitwise trie is compressed into a PATRICIA tree (a bitwise radix tree) by +-- merging series of nodes that have no branches. +-- * The prefix labels of PATRICIA tree nodes are represented implicitly by storing the minimum +-- and maximum keys in a subtree. +-- * Minima and maxima are only stored once, at the topmost location that they appear. +-- * Values are stored next to their associated keys, rather than in the leaves. +-- +-- Each of these steps is explained in detail below. -- -- == The basic integer map: the bitwise trie -- -- We are trying to create an efficient, simple mapping from integers to values. The most common --- approaches for these are hash tables, which are not persistent (though we can come close with --- HAMTs), and binary search trees, which work well, but don't use any special properties of the --- integer. To come up with this mapping, we need to think of integers not as numbers but as --- strings of bits. With that perspective, we can use the standard /trie/ data structure to --- build our mapping. As bits are particularly simple, so is the resulting structure: +-- approaches are hash tables, which are not persistent (though we can come close with HAMTs), +-- and binary search trees, which work well, but don't use any special properties of the integer. +-- Thinking of integers not as numbers but as strings of bits, we use a /trie/, where a string is +-- interpreted as a series of instructions for which branch to take when navigating the tree. As +-- bits are particularly simple, so is the resulting structure: -- -- > data IntMap a = Bin (IntMap a) (IntMap a) | Tip a | Nil -- --- The `Bin` constructor represents a bitwise branch, and the `Tip` constructor comes after (on a --- 64-bit machine) 64 `Bin` construtors in the tree. The associated basic operations navigate the --- tree by reading a key bit by bit, taking the branch associated with the current bit: +-- The `Bin` constructor represents a bitwise branch, and the `Tip` constructor comes after 64 +-- 64 `Bin` construtors in the tree (on a 64-bit machine). The associated basic operations navigate +-- the tree by reading a key bit by bit, at each node taking the branch associated with the current +-- bit: -- -- > lookup :: Int -> IntMap a -> Maybe a -- > lookup k = go (finiteBitSize k - 1) @@ -81,51 +89,36 @@ -- -- 'delete' follows similarly, and the uniform structure means that even 'union' isn't too hard, -- a welcome fact given the complexity of merging binary search trees. Unfortunately, this --- approach is horribly slow and space-inefficient. To see why, look at the tree structure +-- approach is extremely slow and space-inefficient. To see why, look at the tree structure -- for @'singleton' 5 "hello"@: -- -- > +-0-. --- > | +-0-. --- > | | +-0-. --- > | | | +-0-. --- > | | | | +-0-. --- > | | | | | +-0-. --- > | | | | | | +-0-. --- > | | | | | | | +-0-. --- > | | | | | | | | +-0-. --- > | | | | | | | | | +-0-. --- > | | | | | | | | | | +-0-. --- > | | | | | | | | | | | +-0-. --- > | | | | | | | | | | | | +-0-. --- > | | | | | | | | | | | | | +-0- --- > | | | | | | | | | | | | | +-1-. --- > | | | | | | | | | | | | | +-0-. --- > | | | | | | | | | | | | | | +-0- --- > | | | | | | | | | | | | | | +-1- "hello" --- > | | | | | | | | | | | | | +-1- --- > | | | | | | | | | | | | +-1- --- > | | | | | | | | | | | +-1- --- > | | | | | | | | | | +-1- --- > | | | | | | | | | +-1- --- > | | | | | | | | +-1- --- > | | | | | | | +-1- --- > | | | | | | +-1- --- > | | | | | +-1- --- > | | | | +-1- --- > | | | +-1- --- > | | +-1- --- > | +-1- --- > +-1- --- --- Note that, for brevity, the word size is 16 bits. The diagram would be 4 times longer for a --- 64-bit system. In this atrocious tree structure, there is one pointer for every bit, a 64-fold --- explosion in space. Arguably worse is the fact that every single 'lookup', 'insert', or --- 'delete' must traverse 64 pointers, resulting in 64 cache misses and a terrible runtime. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-0-. +-- > +-1-. +-- > +-0-. +-- > +-1- "hello" +-- +-- Note that, for brevity, the word size in this diagram is 16 bits. It would be 4 times longer +-- for a 64-bit system. In this atrocious tree structure, there is one pointer for every bit, a +-- 64-fold explosion in space. Arguably worse is the fact that every single 'lookup', +-- 'Data.IntMap.Lazy.insert', or 'delete' must traverse 64 pointers, resulting in 64 cache misses +-- and a corresponding slowdown. -- -- == Path compression: PATRICIA trees and the previous version of 'Data.IntMap' -- --- To reduce the space usage, we can compress nodes that only have one child. Since they form a --- linear chain, we can concatenate the bits within that chain, storing what branches would be +-- To reduce space usage, we compress nodes that only have one child. Since they form a +-- linear chain, we can concatenate the bits within that chain, recording which branches would be -- taken. For example, again temporarily shortening the word size to 16 bits: -- -- >>> singleton 5 "hello" @@ -138,25 +131,26 @@ -- +-0- "4" -- +-1- "5" -- --- This is much more space efficient, and the basic operations, while more complicated, are still +-- This is much more space-efficient, and the basic operations, while more complicated, are still -- straightforward. In Haskell, the structure is -- -- > data IntMap a = Bin Prefix Mask (IntMap a) (IntMap a) | Tip Int a | Nil -- --- The @Mask@ tells how long the @Prefix@ is, and the @Int@ in the @Tip@ nodes avoids using @Bin@ --- for singletons. This representation is known as the big-endian PATRICIA tree and is what the +-- The @Mask@ tells how long the @Prefix@ is, and the @Int@ in the @Tip@ nodes encodes the +-- remaining bits. This representation, known as the big-endian PATRICIA tree, is what the -- previous iteration of 'IntMap' used. -- -- == Implicit prefixes: a simpler representation -- --- In the PATRICIA tree representation, we explicitly stored the common prefix of all the keys in --- a subtree. However, this prefix is not needed if we know what the minimum and maximum keys. The --- common prefix of a set of keys is the same as the common prefix of the minimum and maximum. +-- In the PATRICIA tree representation above, we explicitly stored the common prefix of all the +-- keys in a subtree. However, this prefix is not needed if we know the minimum and maximum keys. +-- The common prefix of a set of keys is the same as the common prefix of the minimum and maximum. -- Replacing the @Prefix@, @Mask@ pair with a minimum and maximum, we get -- -- > data IntMap a = Bin MinBound MaxBound (IntMap a) (IntMap a) | Tip Int a | Nil -- --- Some examples: +-- The tree structure looks identical, just with different labels on the edges: +-- -- >>> singleton 5 "hello" -- +-5- "hello" -- @@ -168,33 +162,34 @@ -- +-5- "5" -- -- Traversing this tree efficiently is a bit more difficult, but still possible. See 'xor' for --- details. Moreover, since it gives exact minimums and maximums, 'lookup's can already be more --- efficient than in a PATRICIA tree since they can terminate with 'Nothing' as soon as a key --- is out of the bounds of a subtree, even if it matches the prefix of common bits. However, +-- details. Moreover, since the tree contains exact minima and maxima, 'lookup' can already be +-- more efficient than in a PATRICIA tree. Even if a key matches the prefix of common bits, if the +-- key is out of the bounds of a subtree, a search can terminate early with 'Nothing'. However, -- there are bigger gains to be had. -- -- == Removing redundancy --- The above representation store many keys repeatedly. In the @{1,4,5}@ example, 1 was stored +-- +-- The above representation stores many keys repeatedly. In the @{1,4,5}@ example, 1 was stored -- twice, 4 was stored twice, and 5 was stored three times. The minimum and maximum keys of a -- tree are necessarily keys stored in that tree and moreover are minima and maxima of subtrees. --- In the {1,4,5} example, we know from the root node that the minimum is 1 and the maximum is 5. --- At the first branch, we split the set into two parts, @{1}@ and @{4,5}@. However, the minimum --- of the set of smaller keys is exactly the minimum of the original set. Similarly, the maximum --- of the set of larger keys is exactly the maximum of the original set. --- --- We can restructure the tree to only store 1 new value at each branch, removing the redundancy. --- In nodes storing a set of smaller keys, we already know the minimum when traversing the tree --- downward, so we only need to store the new maximum. In nodes storing a set of larger keys, we +-- In the @{1,4,5}@ example, we know from the root node that the minimum is 1 and the maximum is +-- 5. At the first branch, we split the set into two parts, @{1}@ and @{4,5}@. However, the +-- minimum of the set of lesser keys is equal to the minimum of the original set. Similarly, the +-- maximum of the set of greater keys is equal to the maximum of the original set. +-- +-- We can restructure the tree to store only one new value at each branch, removing the redundancy. +-- In nodes storing a set of lesser keys, we already know the minimum when traversing the tree +-- downward, so we only need to store the new maximum. In nodes storing a set of greater keys, we -- know the maximum and store the new minimum. The root still needs both the minimum and the -- maximum, so we need an extra layer to store that information: -- -- > data IntMap a = Empty | NonEmpty Bound (Node a) -- > data Node a = Bin Bound (Node a) (Node a) | Tip a -- --- The trees are no longer quite as easy to read at a glance, since keys are no longer available --- in order at the leaves, and it can be difficult to tell the difference at a glance between a node --- storing a minimum and a node storing a maximum (the actual implementation uses phantom types to --- ensure no code gets this wrong). +-- The trees are no longer quite as easy to read at a glance, since keys are no longer visible in +-- order at the leaves. It can be difficult to tell the difference at a glance between a node +-- storing a minimum and a node storing a maximum. (The actual implementation uses phantom types +-- to ensure no code gets this wrong.) -- -- >>> singleton 5 "hello" -- 5 @@ -208,21 +203,21 @@ -- +- "4" -- +- "5" -- --- Unfortunately, these nonuniformities do translate to code complexity, but we have already saved --- a whole word in every node and every leaf. +-- Although the nonuniform tree structure results in more complex code, we save a word in each +-- node. -- -- == Moving the values upward -- --- The previous section removed the redundancy in keys perfectly, storing each key only once. --- However, the values are still stored at the leaf, now far away from their associated keys. --- There is no reason this has to be true now that keys have a unique location in the tree. --- By moving the values upward in the tree, we simplify: +-- The above change removed the redundancy in keys perfectly, so each key is stored only once. +-- However, the values are still stored in leaves, now far away from their associated keys. +-- There is no reason this has to be true now that each keys has a unique location in the tree. We +-- simplify by moving the values next to their keys: -- -- > data IntMap a = Empty | NonEmpty Bound a (Node a) -- > data Node a = Bin Bound a (Node a) (Node a) | Tip -- -- Although nodes still switch between minima and maxima, they can be visualized and manipulated --- much more cleanly since it is clear which keys are tied to which values. +-- more cleanly since it is clear which keys are tied to which values. -- -- >>> singleton 5 "hello" -- 5 "hello" @@ -236,25 +231,33 @@ -- +- -- +- -- --- This simpler representation translates to even more savings in both space and time. Since --- the leaves no longer store any information, GHC will create a single static @Tip@ object --- and reuse it between all the leaves, the equivalent of representing leaves with a null pointer, --- saving on allocations and the metadata necessary for garbage collection and lazy evaluation. +-- This simpler representation translates to even more savings in both space and time. Since the +-- leaves no longer store any information, GHC will create a single static @Tip@ object and reuse +-- it for all leaves, the equivalent of representing leaves with a null pointer. This saves on +-- allocations and the metadata necessary for garbage collection and lazy evaluation. -- Additionally, successful lookups can terminate as soon as they see the correct key instead of -- dereferencing a chain of pointers all the way to the leaves. This means fewer cache misses and -- a shorter loop. -- --- = References --- --- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", --- Workshop on ML, September 1998, pages 77-86, --- . --- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve --- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), --- October 1968, pages 514-534. --- * Edward Kmett, \"/Revisiting Matrix Multiplication, Part IV: IntMap!?/\", --- School of Haskell, 25 August 2013, --- . +-- = References and Further Reading +-- +-- Morrison introduced PATRICIA trees in: +-- +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\" +-- Journal of the ACM, 15(4), October 1968, pages 514-534. +-- +-- Okasaki and Gill proposed using them in a functional context and provided implementations, +-- benchmarks, and discussion in: +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- . +-- +-- Kmett proposed replacing explicit prefixes with min/max pairs in: +-- +-- * Edward Kmett, \"/Revisiting Matrix Multiplication, Part IV: IntMap!?/\", +-- School of Haskell, 25 August 2013, +-- . -- -- @since 0.5.9 ----------------------------------------------------------------------------- From d2f723f5c0d2eff0c6b1eabbf3f09c7fa2b69297 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 26 Dec 2019 16:30:20 -0600 Subject: [PATCH 045/147] Fix remnant of Markdown syntax --- containers/src/Data/IntMap/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 677896f86..c4f792489 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -320,7 +320,7 @@ i2w = fromIntegral -- > xor k min: 000000000000 1 ???????? -- > xor k max: 000000000000 0 ???????? -- --- Therefore, the splitting bit is set iff `xor k min > xor k max`. Put another way, the key +-- Therefore, the splitting bit is set iff @'xor' k min > 'xor' k max@. Put another way, the key -- shares more bits with the bound that it is closer to under the xor metric, since exclusive or -- maps shared bits to zero. The metric perspective also makes it clear why this works unmodified -- in the presence of negative numbers, despite storing negative numbers (with a set sign bit) in From 5b058a09aee0e6382fd12f3ec34a469e50a65c60 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 26 Dec 2019 16:55:06 -0600 Subject: [PATCH 046/147] Adjust CPP guards and pragmas to be more correct --- containers/src/Data/IntMap/Internal.hs | 11 ++++++++--- containers/src/Data/IntMap/Lazy.hs | 2 +- containers/src/Data/IntMap/Merge/Internal.hs | 4 +++- containers/src/Data/IntMap/Merge/Lazy.hs | 2 +- containers/src/Data/IntMap/Merge/Strict.hs | 2 +- containers/src/Data/IntMap/Strict.hs | 2 +- 6 files changed, 15 insertions(+), 8 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index c4f792489..b9388e841 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,7 +1,12 @@ -{-# LANGUAGE CPP, BangPatterns, TypeFamilies #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE CPP, BangPatterns #-} +#if defined(__GLASGOW_HASKELL__) +{-# LANGUAGE TypeFamilies #-} +#if !defined(TESTING) {-# LANGUAGE Safe #-} #endif +#endif + +{-# OPTIONS_HADDOCK not-home #-} #include "containers.h" @@ -347,7 +352,7 @@ boundsDisjoint (Bound min) (Bound max) = min > max newtype L = L L newtype R = R R -#if 1 +#if defined(__GLASGOW_HASKELL__) -- TODO: If we are relying on GHC features anyway, L and R could be a new kind. newtype Bound t = Bound { boundKey :: Key } deriving (Eq, Ord, Show) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 047ff4784..727e19565 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, BangPatterns #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index b4a7f8729..253f9e829 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -2,7 +2,7 @@ #include "containers.h" -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) #if MIN_VERSION_base(4,8,0) || __GLASGOW_HASKELL__ < 708 {-# LANGUAGE Safe #-} #else @@ -10,6 +10,8 @@ #endif #endif +{-# OPTIONS_HADDOCK not-home #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Merge.Internal diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index b018910ce..a303ff796 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, BangPatterns #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index b1c255733..c56e9d929 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, BangPatterns #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 0f390f512..c8145baf7 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, BangPatterns #-} -#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif From 48f228593627a2eb12d24069fc6ffe250f070989 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 26 Dec 2019 17:07:48 -0600 Subject: [PATCH 047/147] Temporarily disable the broken implementation of merge --- containers/src/Data/IntMap/Merge/Internal.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 253f9e829..01c493067 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -296,6 +296,8 @@ runWhenMatched = matchedSingle -- prop> mapEachPiece f g h = merge (mapMissing f) (mapMissing g) (zipWithMatched h) {-# INLINE merge #-} merge :: SimpleWhenMissing a c -> SimpleWhenMissing b c -> SimpleWhenMatched a b c -> IntMap a -> IntMap b -> IntMap c +merge miss1 miss2 match = \m1 m2 -> runIdentity (mergeA miss1 miss2 match m1 m2) +{- FIXME: The following is significantly faster, but incorrect. merge miss1 miss2 match = start where start (IntMap Empty) (IntMap Empty) = IntMap Empty start (IntMap Empty) (IntMap !m2) = IntMap (missAllL miss2 m2) @@ -698,6 +700,7 @@ merge miss1 miss2 match = start where {-# INLINE matchSingle #-} matchSingle whenMatch k v1 v2 = runIdentity (matchedSingle whenMatch k v1 v2) +-} -- | An applicative version of 'merge'. Due to the necessity of performing actions -- in order, this can be significantly slower than 'merge'. From f8fcd1248fdecbd03157194cb1db6eb030083a90 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 26 Dec 2019 17:57:14 -0600 Subject: [PATCH 048/147] Fix versioning of imports, only importing things that are available and not in Prelude --- containers/src/Data/IntMap/Internal.hs | 19 +++++++++++++------ containers/src/Data/IntMap/Lazy.hs | 5 +++-- containers/src/Data/IntMap/Merge/Internal.hs | 10 ++++------ containers/src/Data/IntMap/Merge/Lazy.hs | 3 +++ containers/src/Data/IntMap/Merge/Strict.hs | 3 +++ containers/src/Data/IntMap/Strict.hs | 5 +++-- 6 files changed, 29 insertions(+), 16 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index b9388e841..4201e172f 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -278,19 +278,25 @@ module Data.IntMap.Internal where import Control.DeepSeq (NFData(..)) -import Control.Applicative (Applicative(..)) -import Data.Monoid (Monoid(..)) import qualified Data.List (foldl') import qualified Data.Foldable (Foldable(..)) -import Data.Traversable (Traversable(..)) #if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup(..), stimesIdempotentMonoid) +#if MIN_VERSION_base(4,11,0) +import Data.Semigroup (stimes) +#else +import Data.Semigroup (Semigroup(..)) +#endif +import Data.Semigroup (stimesIdempotentMonoid) #endif -import Data.Functor ((<$>)) - +#if !MIN_VERSION_base(4,8,0) import Data.Word (Word) +import Data.Monoid (Monoid(..)) +import Data.Traversable (Traversable(..)) +import Control.Applicative (Applicative(..), (<$>)) +#endif + import qualified Data.Bits (xor) import qualified Data.IntSet (IntSet, fromDistinctAscList, member, notMember) @@ -435,6 +441,7 @@ instance Monoid (IntMap a) where #if MIN_VERSION_base(4,9,0) instance Semigroup (IntMap a) where + (<>) = union stimes = stimesIdempotentMonoid #endif diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 727e19565..04982d6a9 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -216,8 +216,9 @@ module Data.IntMap.Lazy ( import Data.IntMap.Internal import qualified Data.IntMap.Merge.Lazy as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) -import Control.Applicative (Applicative(..)) -import Data.Functor ((<$>)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative(..), (<$>)) +#endif import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 01c493067..abc7ded54 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -41,23 +41,21 @@ module Data.IntMap.Merge.Internal where -import Control.Applicative (Applicative(..)) import Prelude hiding (min, max) import Data.IntMap.Internal #if MIN_VERSION_base (4,8,0) import Data.Functor.Identity (Identity, runIdentity) -#elif __GLASGOW_HASKELL__ >= 708 -import Data.Coerce -#endif - +#else +import Control.Applicative (Applicative(..), (<$>)) -#if !MIN_VERSION_base (4,8,0) -- | The identity type. newtype Identity a = Identity { runIdentity :: a } #if __GLASGOW_HASKELL__ >= 708 +import Data.Coerce + instance Functor Identity where fmap = coerce instance Applicative Identity where diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index a303ff796..0f2881333 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -76,7 +76,10 @@ module Data.IntMap.Merge.Lazy ( , runWhenMissing ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..)) +#endif + import Prelude hiding (min, max) import Data.IntMap.Internal diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index c56e9d929..6cf6cdd86 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -76,7 +76,10 @@ module Data.IntMap.Merge.Strict ( , runWhenMissing ) where +#if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..)) +#endif + import Prelude hiding (min, max) import Data.IntMap.Internal diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index c8145baf7..2488234ee 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -236,8 +236,9 @@ module Data.IntMap.Strict ( import Data.IntMap.Internal import qualified Data.IntMap.Merge.Strict as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) -import Control.Applicative (Applicative(..)) -import Data.Functor ((<$>)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative(..), (<$>)) +#endif import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) From de768a88b8c483a527b717caf049ac7ec70a541d Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 26 Dec 2019 18:17:44 -0600 Subject: [PATCH 049/147] Move import to be before definitions on GHC 7.8 --- containers/src/Data/IntMap/Merge/Internal.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index abc7ded54..fd19c93c4 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -50,12 +50,14 @@ import Data.Functor.Identity (Identity, runIdentity) #else import Control.Applicative (Applicative(..), (<$>)) +#if __GLASGOW_HASKELL__ >= 708 +import Data.Coerce +#endif + -- | The identity type. newtype Identity a = Identity { runIdentity :: a } #if __GLASGOW_HASKELL__ >= 708 -import Data.Coerce - instance Functor Identity where fmap = coerce instance Applicative Identity where From 6cd5441c9c5c2e6ef581f44244901dc9f02410d1 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 26 Dec 2019 18:37:49 -0600 Subject: [PATCH 050/147] Further old GHC import fixes --- containers/src/Data/IntMap/Merge/Lazy.hs | 2 +- containers/src/Data/IntMap/Merge/Strict.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 0f2881333..458238892 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -77,7 +77,7 @@ module Data.IntMap.Merge.Lazy ( ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative(..)) +import Control.Applicative (Applicative(..), (<$>)) #endif import Prelude hiding (min, max) diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 6cf6cdd86..f75d7fffc 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -77,7 +77,7 @@ module Data.IntMap.Merge.Strict ( ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative(..)) +import Control.Applicative (Applicative(..), (<$>)) #endif import Prelude hiding (min, max) From 18ed7360af388b1ea55b05fc860afe56f45e3b77 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Fri, 27 Dec 2019 11:44:35 -0600 Subject: [PATCH 051/147] Reinstate traverseMaybeWithKey tests to test traverseMaybeMissing --- containers-tests/tests/intmap-properties.hs | 27 ++++++++++++++++++++ containers/src/Data/IntMap/Merge/Internal.hs | 7 +++++ 2 files changed, 34 insertions(+) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 52dc200f4..fb12cac90 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -7,6 +7,7 @@ import Data.IntMap.Merge.Strict import Data.IntMap.Lazy as Data.IntMap hiding (showTree) import Data.IntMap.Merge.Lazy #endif +import Data.IntMap.Merge.Internal (runWhenMissingAll) import Data.IntMap.Internal.Debug (showTree) import IntMapValidity (valid) @@ -211,6 +212,9 @@ main = defaultMain , testProperty "withoutKeys" prop_withoutKeys , testProperty "traverseWithKey identity" prop_traverseWithKey_identity , testProperty "traverseWithKey->mapWithKey" prop_traverseWithKey_degrade_to_mapWithKey + , testProperty "traverseMaybeWithKey identity" prop_traverseMaybeWithKey_identity + , testProperty "traverseMaybeWithKey->mapMaybeWithKey" prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey + , testProperty "traverseMaybeWithKey->traverseWithKey" prop_traverseMaybeWithKey_degrade_to_traverseWithKey ] apply2 :: Fun (a, b) c -> a -> b -> c @@ -1619,3 +1623,26 @@ prop_traverseWithKey_degrade_to_mapWithKey fun mp = where f = applyFun2 fun g k v = Identity $ f k v Identity newMap = traverseWithKey g mp + +-- While this isn't part of the IntMap API yet, it is still useful for testing traverseMaybeMissing +traverseMaybeWithKey :: Applicative f => (Key -> a -> f (Maybe b)) -> IntMap a -> f (IntMap b) +traverseMaybeWithKey = runWhenMissingAll . traverseMaybeMissing + +prop_traverseMaybeWithKey_identity :: IntMap A -> Property +prop_traverseMaybeWithKey_identity mp = mp === newMap + where Identity newMap = traverseMaybeWithKey (\_ -> Identity . Just) mp + +prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey :: Fun (Int, A) (Maybe B) -> IntMap A -> Property +prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey fun mp = + mapMaybeWithKey f mp === newMap + where f = applyFun2 fun + g k v = Identity $ f k v + Identity newMap = traverseMaybeWithKey g mp + +prop_traverseMaybeWithKey_degrade_to_traverseWithKey :: Fun (Int, A) B -> IntMap A -> Property +prop_traverseMaybeWithKey_degrade_to_traverseWithKey fun mp = + traverseWithKey f mp === traverseMaybeWithKey g mp + -- used (,) since its Applicative is monoidal in the left argument, + -- so this also checks the order of traversing is the same. + where f k v = (show k, applyFun2 fun k v) + g k v = fmap Just $ f k v diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index fd19c93c4..03465d857 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -100,6 +100,13 @@ type SimpleWhenMissing = WhenMissing Identity runWhenMissing :: WhenMissing f a b -> Key -> a -> f (Maybe b) runWhenMissing = missingSingle +-- | Apply a missing tactic to an entire map. +-- +-- prop> runWhenMissingAll miss m = merge miss dropMissing dropMatched m empty +{-# INLINE runWhenMissingAll #-} +runWhenMissingAll :: Applicative f => WhenMissing f a b -> IntMap a -> f (IntMap b) +runWhenMissingAll miss (IntMap m) = IntMap <$> missingAllL miss m + -- | Drop all the entries whose keys are missing from the other -- map. -- From 11b7f97ab0bca18c871b8e075aaabd2016b343c1 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Fri, 27 Dec 2019 12:50:18 -0600 Subject: [PATCH 052/147] Inline foldlWithKey' and foldrWithKey', finally fixing the major performance regression compared to old Data.IntMap --- containers/src/Data/IntMap/Internal.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 4201e172f..693a2d113 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1419,6 +1419,7 @@ foldl' f z = start -- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. +{-# INLINE foldrWithKey' #-} -- Very important for unwrappable accumulators (e.g. Int) foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b foldrWithKey' f z = start where @@ -1434,6 +1435,7 @@ foldrWithKey' f z = start -- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. +{-# INLINE foldlWithKey' #-} foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a foldlWithKey' f z = start where From 197510b1320e4bdfa431bc0a03939346d9b72c2f Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 28 Dec 2019 03:18:32 -0600 Subject: [PATCH 053/147] Use EmptyDataDecls --- containers/src/Data/IntMap/Internal.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 693a2d113..b2e77bc89 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns, EmptyDataDecls #-} #if defined(__GLASGOW_HASKELL__) {-# LANGUAGE TypeFamilies #-} #if !defined(TESTING) @@ -355,8 +355,8 @@ boundsDisjoint (Bound min) (Bound max) = min > max -- Phantom types used to separate the types of left and right nodes. -- They are uninhabited simply to ensure that they are only used as type parameters. -newtype L = L L -newtype R = R R +data L +data R #if defined(__GLASGOW_HASKELL__) -- TODO: If we are relying on GHC features anyway, L and R could be a new kind. @@ -370,7 +370,7 @@ type instance Flipped R = L type Bound t = Bound_ newtype Bound_ = Bound { boundKey :: Key } deriving (Eq, Ord, Show) -- This, like L and R, is uninhabited to ensure that it is only used as a type parameter -newtype Flipped t = Flipped (Flipped t) +data Flipped t #endif inMinBound :: Key -> Bound L -> Bool From e119d7971396a34230735a1218694f0305e6ce3c Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 28 Dec 2019 03:42:55 -0600 Subject: [PATCH 054/147] Prefer bang patterns for specifying strictness --- containers/src/Data/IntMap/Internal.hs | 72 ++++++++++---------------- containers/src/Data/IntMap/Lazy.hs | 6 +-- containers/src/Data/IntMap/Strict.hs | 10 ++-- 3 files changed, 37 insertions(+), 51 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index b2e77bc89..02ca8bed0 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -501,7 +501,7 @@ size (IntMap (NonEmpty _ _ node)) = sizeNode node where -- > member 5 (fromList [(5,'a'), (3,'b')]) == True -- > member 1 (fromList [(5,'a'), (3,'b')]) == False member :: Key -> IntMap a -> Bool -member k = k `seq` start +member !k = start where start (IntMap Empty) = False start (IntMap (NonEmpty min _ node)) @@ -532,7 +532,7 @@ member k = k `seq` start -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True notMember :: Key -> IntMap a -> Bool -notMember k = k `seq` start +notMember !k = start where start (IntMap Empty) = True start (IntMap (NonEmpty min _ node)) @@ -560,7 +560,7 @@ notMember k = k `seq` start -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'. lookup :: Key -> IntMap a -> Maybe a -lookup k = k `seq` start +lookup !k = start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV node)) @@ -593,7 +593,7 @@ lookup k = k `seq` start -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' findWithDefault :: a -> Key -> IntMap a -> a -findWithDefault def k = k `seq` start +findWithDefault def !k = start where start (IntMap Empty) = def start (IntMap (NonEmpty min minV node)) @@ -625,7 +625,7 @@ findWithDefault def k = k `seq` start -- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing -- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') lookupLT :: Key -> IntMap a -> Maybe (Key, a) -lookupLT k = k `seq` start +lookupLT !k = start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV node)) @@ -658,7 +658,7 @@ lookupLT k = k `seq` start -- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a') -- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') lookupLE :: Key -> IntMap a -> Maybe (Key, a) -lookupLE k = k `seq` start +lookupLE !k = start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV node)) @@ -690,7 +690,7 @@ lookupLE k = k `seq` start -- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') -- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing lookupGT :: Key -> IntMap a -> Maybe (Key, a) -lookupGT k = k `seq` start +lookupGT !k = start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV Tip)) @@ -726,7 +726,7 @@ lookupGT k = k `seq` start -- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b') -- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing lookupGE :: Key -> IntMap a -> Maybe (Key, a) -lookupGE k = k `seq` start +lookupGE !k = start where start (IntMap Empty) = Nothing start (IntMap (NonEmpty min minV Tip)) @@ -765,7 +765,7 @@ empty = IntMap Empty -- | /O(min(n,W))/. Delete a key and its value from the map. -- When the key is not a member of the map, the original map is returned. delete :: Key -> IntMap a -> IntMap a -delete k = k `seq` start +delete !k = start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min _ Tip)) @@ -1387,68 +1387,52 @@ foldMapWithKey f = start -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. +{-# INLINE foldr' #-} foldr' :: (a -> b -> b) -> b -> IntMap a -> b -foldr' f z = start - where - start (IntMap Empty) = z - start (IntMap (NonEmpty _ minV root)) = f minV $! goL root $! z - - goL Tip acc = acc - goL (Bin _ maxV l r) acc = goL l $! goR r $! f maxV $! acc - - goR Tip acc = acc - goR (Bin _ minV l r) acc = f minV $! goL l $! goR r $! acc +foldr' f !z = foldrWithKey' (\ _ v !acc -> f v acc) z -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. +{-# INLINE foldl' #-} foldl' :: (a -> b -> a) -> a -> IntMap b -> a -foldl' f z = start - where - start (IntMap Empty) = z - start (IntMap (NonEmpty _ minV root)) = s goL (s f z minV) root - - goL acc Tip = acc - goL acc (Bin _ maxV l r) = s f (s goR (s goL acc l) r) maxV - - goR acc Tip = acc - goR acc (Bin _ minV l r) = s goR (s goL (s f acc minV) l) r - - s = ($!) +foldl' f !z = foldlWithKey' (\ !acc _ v -> f acc v) z -- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. {-# INLINE foldrWithKey' #-} -- Very important for unwrappable accumulators (e.g. Int) foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b -foldrWithKey' f z = start +foldrWithKey' f !z = start where + f' k v !acc = f k v acc + start (IntMap Empty) = z - start (IntMap (NonEmpty min minV root)) = f (boundKey min) minV $! goL root $! z + start (IntMap (NonEmpty min minV root)) = f' (boundKey min) minV (goL root z) - goL Tip acc = acc - goL (Bin max maxV l r) acc = goL l $! goR r $! f (boundKey max) maxV $! acc + goL Tip !acc = acc + goL (Bin max maxV l r) !acc = goL l (goR r (f' (boundKey max) maxV acc)) - goR Tip acc = acc - goR (Bin min minV l r) acc = f (boundKey min) minV $! goL l $! goR r $! acc + goR Tip !acc = acc + goR (Bin min minV l r) !acc = f' (boundKey min) minV (goL l (goR r acc)) -- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. {-# INLINE foldlWithKey' #-} foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a -foldlWithKey' f z = start +foldlWithKey' f !z = start where + f' !acc k v = f acc k v + start (IntMap Empty) = z - start (IntMap (NonEmpty min minV root)) = s goL (s f z (boundKey min) minV) root + start (IntMap (NonEmpty min minV root)) = goL (f' z (boundKey min) minV) root goL acc Tip = acc - goL acc (Bin max maxV l r) = s f (s goR (s goL acc l) r) (boundKey max) maxV + goL acc (Bin max maxV l r) = f' (goR (goL acc l) r) (boundKey max) maxV goR acc Tip = acc - goR acc (Bin min minV l r) = s goR (s goL (s f acc (boundKey min) minV) l) r - - s = ($!) + goR acc (Bin min minV l r) = goR (goL (f' acc (boundKey min) minV) l) r -- TODO: make the conversion functions good producers @@ -1706,7 +1690,7 @@ mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt) -- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty) -- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty) splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a) -splitLookup k = k `seq` start +splitLookup !k = start where start (IntMap Empty) = (IntMap Empty, Nothing, IntMap Empty) start m@(IntMap (NonEmpty min minV root)) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 04982d6a9..d206f41bf 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -395,7 +395,7 @@ insertLookupWithKey combine !k !v = toPair . start -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > adjust ("new " ++) 7 empty == empty adjust :: (a -> a) -> Key -> IntMap a -> IntMap a -adjust f k = k `seq` start +adjust f !k = start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV node)) @@ -440,7 +440,7 @@ adjustWithKey f k = adjust (f k) k -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a -update f k = k `seq` start +update f !k = start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV Tip)) @@ -499,7 +499,7 @@ updateWithKey f k = update (f k) k -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) -updateLookupWithKey f k = k `seq` start +updateLookupWithKey f !k = start where start (IntMap Empty) = (Nothing, IntMap Empty) start m@(IntMap (NonEmpty min minV Tip)) diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 2488234ee..7f353730e 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -256,7 +256,7 @@ import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1 singleton :: Key -> a -> IntMap a -singleton k v = v `seq` IntMap (NonEmpty (Bound k) v Tip) +singleton !k !v = IntMap (NonEmpty (Bound k) v Tip) -- | /O(min(n,W))/. Insert a new key\/value pair in the map. -- If the key is already present in the map, the associated value is @@ -407,7 +407,7 @@ insertLookupWithKey combine !k v = toPair . start -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > adjust ("new " ++) 7 empty == empty adjust :: (a -> a) -> Key -> IntMap a -> IntMap a -adjust f k = k `seq` start +adjust f !k = start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV node)) @@ -452,7 +452,7 @@ adjustWithKey f k = adjust (f k) k -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a -update f k = k `seq` start +update f !k = start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV Tip)) @@ -511,7 +511,7 @@ updateWithKey f k = update (f k) k -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) -updateLookupWithKey f k = k `seq` start +updateLookupWithKey f !k = start where start (IntMap Empty) = (Nothing, IntMap Empty) start m@(IntMap (NonEmpty min minV Tip)) @@ -1330,6 +1330,8 @@ fromAscList = start where start [] = IntMap Empty start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + -- The strictness here is tricky, mimicking old behavior. Only the last value + -- of a given key (the one being inserted into the map) is evaluated strictly. go !k v [] !stk = completeBuildStack (Bound k) v Tip stk go !k v ((!next, nextV) : rest) !stk | next == k = nextV `seq` go k nextV rest stk From ee45af15d4dd95c11811a21d95b2ae41dfc5f716 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 28 Dec 2019 04:03:37 -0600 Subject: [PATCH 055/147] Favor liftA* over <$> and <*> in case there is a more efficient override, everywhere but mergeA itself --- containers/src/Data/IntMap/Internal.hs | 7 ++++--- containers/src/Data/IntMap/Lazy.hs | 7 ++++--- containers/src/Data/IntMap/Merge/Internal.hs | 7 ++++--- containers/src/Data/IntMap/Merge/Lazy.hs | 13 +++++++------ containers/src/Data/IntMap/Merge/Strict.hs | 13 +++++++------ containers/src/Data/IntMap/Strict.hs | 7 ++++--- 6 files changed, 30 insertions(+), 24 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 02ca8bed0..9f1f70f63 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -296,6 +296,7 @@ import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(..)) import Control.Applicative (Applicative(..), (<$>)) #endif +import Control.Applicative (liftA2, liftA3) import qualified Data.Bits (xor) @@ -427,13 +428,13 @@ instance Traversable IntMap where traverse f = start where start (IntMap Empty) = pure (IntMap Empty) - start (IntMap (NonEmpty min minV node)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f minV <*> goL node + start (IntMap (NonEmpty min minV node)) = liftA2 (\minV' root' -> IntMap (NonEmpty min minV' root')) (f minV) (goL node) goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' v' -> Bin max v' l' r') <$> goL l <*> goR r <*> f maxV + goL (Bin max maxV l r) = liftA3 (\l' r' v' -> Bin max v' l' r') (goL l) (goR r) (f maxV) goR Tip = pure Tip - goR (Bin min minV l r) = Bin min <$> f minV <*> goL l <*> goR r + goR (Bin min minV l r) = liftA3 (Bin min) (f minV) (goL l) (goR r) instance Monoid (IntMap a) where mempty = empty diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index d206f41bf..49f4de62b 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -219,6 +219,7 @@ import qualified Data.IntMap.Merge.Lazy as Merge (merge, mapMaybeMissing, zipWit #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..), (<$>)) #endif +import Control.Applicative (liftA2, liftA3) import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) @@ -1158,13 +1159,13 @@ traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b traverseWithKey f = start where start (IntMap Empty) = pure (IntMap Empty) - start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f (boundKey min) minV <*> goL root + start (IntMap (NonEmpty min minV root)) = liftA2 (\minV' root' -> IntMap (NonEmpty min minV' root')) (f (boundKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV + goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> Bin max maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = Bin min <$> f (boundKey min) minV <*> goL l <*> goR r + goR (Bin min minV l r) = liftA3 (Bin min) (f (boundKey min) minV) (goL l) (goR r) -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 03465d857..c8d7d3989 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -45,6 +45,7 @@ import Prelude hiding (min, max) import Data.IntMap.Internal +import Control.Applicative (liftA2, liftA3) #if MIN_VERSION_base (4,8,0) import Data.Functor.Identity (Identity, runIdentity) #else @@ -202,13 +203,13 @@ filterAMissing f = WhenMissing , missingSingle = \k v -> fmap (\keep -> if keep then Just v else Nothing) (f k v) } where start Empty = pure Empty - start (NonEmpty min minV root) = (\keepV root' -> if keepV then NonEmpty min minV root' else nodeToMapL root') <$> f (boundKey min) minV <*> goL root + start (NonEmpty min minV root) = liftA2 (\keepV root' -> if keepV then NonEmpty min minV root' else nodeToMapL root') (f (boundKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' keepMax -> if keepMax then Bin max maxV l' r' else extractBinL l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV + goL (Bin max maxV l r) = liftA3 (\l' r' keepMax -> if keepMax then Bin max maxV l' r' else extractBinL l' r') (goL l) (goR r) (f (boundKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = (\keepMin l' r' -> if keepMin then Bin min minV l' r' else extractBinR l' r') <$> f (boundKey min) minV <*> goL l <*> goR r + goR (Bin min minV l r) = liftA3 (\keepMin l' r' -> if keepMin then Bin min minV l' r' else extractBinR l' r') (f (boundKey min) minV) (goL l) (goR r) -- | A tactic for dealing with keys present in both -- maps in 'merge' or 'mergeA'. diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 458238892..6e47ea534 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -79,6 +79,7 @@ module Data.IntMap.Merge.Lazy ( #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..), (<$>)) #endif +import Control.Applicative (liftA2, liftA3) import Prelude hiding (min, max) @@ -218,13 +219,13 @@ traverseMaybeMissing f = WhenMissing , missingSingle = f } where start Empty = pure Empty - start (NonEmpty min minV root) = maybe nodeToMapL (NonEmpty min) <$> f (boundKey min) minV <*> goL root + start (NonEmpty min minV root) = liftA2 (maybe nodeToMapL (NonEmpty min)) (f (boundKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> maybe extractBinL (Bin max) maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV + goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> maybe extractBinL (Bin max) maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = (\minV' l' r' -> maybe extractBinR (Bin min) minV' l' r') <$> f (boundKey min) minV <*> goL l <*> goR r + goR (Bin min minV l r) = liftA3 (\minV' l' r' -> maybe extractBinR (Bin min) minV' l' r') (f (boundKey min) minV) (goL l) (goR r) -- | Traverse over the entries whose keys are missing from the other -- map. @@ -240,10 +241,10 @@ traverseMissing f = WhenMissing , missingSingle = \k v -> Just <$> f k v } where start Empty = pure Empty - start (NonEmpty min minV root) = NonEmpty min <$> f (boundKey min) minV <*> goL root + start (NonEmpty min minV root) = liftA2 (NonEmpty min) (f (boundKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV + goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> Bin max maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = (\minV' l' r' -> Bin min minV' l' r') <$> f (boundKey min) minV <*> goL l <*> goR r + goR (Bin min minV l r) = liftA3 (\minV' l' r' -> Bin min minV' l' r') (f (boundKey min) minV) (goL l) (goR r) diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index f75d7fffc..9d7825853 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -79,6 +79,7 @@ module Data.IntMap.Merge.Strict ( #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..), (<$>)) #endif +import Control.Applicative (liftA2, liftA3) import Prelude hiding (min, max) @@ -228,13 +229,13 @@ traverseMaybeMissing f = WhenMissing , missingSingle = f } where start Empty = pure Empty - start (NonEmpty min minV root) = maybe nodeToMapL (NonEmpty min $!) <$> f (boundKey min) minV <*> goL root + start (NonEmpty min minV root) = liftA2 (maybe nodeToMapL (NonEmpty min $!)) (f (boundKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> maybe extractBinL (Bin max $!) maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV + goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> maybe extractBinL (Bin max $!) maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = (\minV' l' r' -> maybe extractBinR (Bin min $!) minV' l' r') <$> f (boundKey min) minV <*> goL l <*> goR r + goR (Bin min minV l r) = liftA3 (\minV' l' r' -> maybe extractBinR (Bin min $!) minV' l' r') (f (boundKey min) minV) (goL l) (goR r) -- | Traverse over the entries whose keys are missing from the other -- map. @@ -250,10 +251,10 @@ traverseMissing f = WhenMissing , missingSingle = \k v -> Just <$> f k v } where start Empty = pure Empty - start (NonEmpty min minV root) = (NonEmpty min $!) <$> f (boundKey min) minV <*> goL root + start (NonEmpty min minV root) = liftA2 (NonEmpty min $!) (f (boundKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' !maxV' -> Bin max maxV' l' r') <$> goL l <*> goR r <*> f (boundKey max) maxV + goL (Bin max maxV l r) = liftA3 (\l' r' !maxV' -> Bin max maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = (\ !minV' l' r' -> Bin min minV' l' r') <$> f (boundKey min) minV <*> goL l <*> goR r + goR (Bin min minV l r) = liftA3 (\ !minV' l' r' -> Bin min minV' l' r') (f (boundKey min) minV) (goL l) (goR r) diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 7f353730e..9a629ada7 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -239,6 +239,7 @@ import qualified Data.IntMap.Merge.Strict as Merge (merge, mapMaybeMissing, zipW #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..), (<$>)) #endif +import Control.Applicative (liftA2, liftA3) import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) @@ -1179,13 +1180,13 @@ traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b traverseWithKey f = start where start (IntMap Empty) = pure (IntMap Empty) - start (IntMap (NonEmpty min minV root)) = (\minV' root' -> IntMap (NonEmpty min minV' root')) <$> f (boundKey min) minV <*> goL root + start (IntMap (NonEmpty min minV root)) = liftA2 (\minV' root' -> IntMap (NonEmpty min minV' root')) (f (boundKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = (\l' r' maxV' -> Bin max #! maxV' # l' # r') <$> goL l <*> goR r <*> f (boundKey max) maxV + goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> Bin max #! maxV' # l' # r') (goL l) (goR r) (f (boundKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = (\minV' l' r' -> Bin min #! minV' # l' # r') <$> f (boundKey min) minV <*> goL l <*> goR r + goR (Bin min minV l r) = liftA3 (\minV' l' r' -> Bin min #! minV' # l' # r') (f (boundKey min) minV) (goL l) (goR r) -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. From 8792fe0ad907b3e386a3c12e3419f40cd74c2ab1 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 28 Dec 2019 12:24:07 -0600 Subject: [PATCH 056/147] Fix review nit --- containers/src/Data/IntMap/Internal.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 9f1f70f63..4dae7dd38 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -492,7 +492,8 @@ null _ = False -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 size :: IntMap a -> Int size (IntMap Empty) = 0 -size (IntMap (NonEmpty _ _ node)) = sizeNode node where +size (IntMap (NonEmpty _ _ node)) = sizeNode node + where sizeNode :: Node t a -> Int sizeNode Tip = 1 sizeNode (Bin _ _ l r) = sizeNode l + sizeNode r From 6e78bacf0d2b16f903c2c5c5ea0ab0fd33aa948c Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 28 Dec 2019 12:37:00 -0600 Subject: [PATCH 057/147] Add specifialized Foldable method implementations. minimum and maximum must traverse the whole tree anyway, so likely wouldn't improve by having a specialized implementation, and they are confusing anyway given the modules focus on minimum and maximum keys. --- containers/src/Data/IntMap/Internal.hs | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 4dae7dd38..6167d7828 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -406,6 +406,7 @@ instance Functor (Node t) where fmap f (Bin k v l r) = Bin k (f v) (fmap f l) (fmap f r) instance Data.Foldable.Foldable IntMap where + {-# INLINE foldMap #-} foldMap f = start where start (IntMap Empty) = mempty @@ -417,13 +418,34 @@ instance Data.Foldable.Foldable IntMap where goR Tip = mempty goR (Bin _ minV l r) = f minV `mappend` goL l `mappend` goR r + {-# INLINE foldr #-} foldr = foldr + {-# INLINE foldl #-} foldl = foldl -#if MIN_VERSION_base(4,6,0) + {-# INLINE foldr' #-} foldr' = foldr' + {-# INLINE foldl' #-} foldl' = foldl' + +#if MIN_VERSION_base(4,8,0) + {-# INLINE length #-} + length = size + {-# INLINE null #-} + null = null + {-# INLINE toList #-} + toList = elems -- NB: Foldable.toList only returns values while IntMap.toList returns keys also + {-# INLINE elem #-} + elem = start + where + start _ (IntMap Empty) = False + start v (IntMap (NonEmpty _ minV root)) = v == minV || go v root + + go :: Eq v => v -> Node t v -> Bool + go _ Tip = False + go v (Bin _ boundV l r) = v == boundV || go v l || go v r #endif + instance Traversable IntMap where traverse f = start where From 1124dfc89abd648a6c53e05ac68fba3d1cce8268 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 28 Dec 2019 14:30:50 -0600 Subject: [PATCH 058/147] Move the IntMap guard around using type families to a constant in containers.h for easier testing --- containers/include/containers.h | 1 + containers/src/Data/IntMap/Internal.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/containers/include/containers.h b/containers/include/containers.h index cd201ca3c..e2ec8f85f 100644 --- a/containers/include/containers.h +++ b/containers/include/containers.h @@ -36,6 +36,7 @@ #ifdef __GLASGOW_HASKELL__ # define USE_ST_MONAD 1 # define USE_UNBOXED_ARRAYS 1 +# define USE_TYPE_FAMILIES 1 #endif #endif diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 6167d7828..9ab135416 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -359,7 +359,7 @@ boundsDisjoint (Bound min) (Bound max) = min > max data L data R -#if defined(__GLASGOW_HASKELL__) +#if USE_TYPE_FAMILIES -- TODO: If we are relying on GHC features anyway, L and R could be a new kind. newtype Bound t = Bound { boundKey :: Key } deriving (Eq, Ord, Show) From bb3fa4837bf3d6f90f4821199fd7112eeafa8a63 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 28 Dec 2019 14:38:51 -0600 Subject: [PATCH 059/147] Add type alias definitions to intro documentation of Data.IntMap.Internal --- containers/src/Data/IntMap/Internal.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 9ab135416..000962b6f 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -139,6 +139,8 @@ -- This is much more space-efficient, and the basic operations, while more complicated, are still -- straightforward. In Haskell, the structure is -- +-- > type Prefix = Int +-- > type Mask = Int -- > data IntMap a = Bin Prefix Mask (IntMap a) (IntMap a) | Tip Int a | Nil -- -- The @Mask@ tells how long the @Prefix@ is, and the @Int@ in the @Tip@ nodes encodes the @@ -152,6 +154,8 @@ -- The common prefix of a set of keys is the same as the common prefix of the minimum and maximum. -- Replacing the @Prefix@, @Mask@ pair with a minimum and maximum, we get -- +-- > type MinBound = Int +-- > type MaxBound = Int -- > data IntMap a = Bin MinBound MaxBound (IntMap a) (IntMap a) | Tip Int a | Nil -- -- The tree structure looks identical, just with different labels on the edges: @@ -188,6 +192,7 @@ -- know the maximum and store the new minimum. The root still needs both the minimum and the -- maximum, so we need an extra layer to store that information: -- +-- > type Bound = Int -- > data IntMap a = Empty | NonEmpty Bound (Node a) -- > data Node a = Bin Bound (Node a) (Node a) | Tip a -- From fb8d3fa4008ebfb32afbe4225360125b4ef2cdc4 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 28 Dec 2019 17:59:19 -0600 Subject: [PATCH 060/147] Improve, extend, and generalize IntMap tests --- containers-tests/tests/intmap-properties.hs | 219 ++++++++++++++++---- 1 file changed, 179 insertions(+), 40 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index fb12cac90..000091695 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -16,7 +16,7 @@ import Data.Monoid import Data.Maybe hiding (mapMaybe) import qualified Data.Maybe as Maybe (mapMaybe) import Data.Ord -import Data.Foldable (foldMap) +import qualified Data.Foldable as Foldable import Data.Function import Data.Traversable (Traversable(traverse), foldMapDefault) #if MIN_VERSION_base(4,8,0) @@ -190,11 +190,16 @@ main = defaultMain , testProperty "deleteMax" prop_deleteMaxModel , testProperty "filter" prop_filter , testProperty "partition" prop_partition + , testProperty "partitionWithKey" prop_partitionWithKey , testProperty "map" prop_map , testProperty "fmap" prop_fmap , testProperty "mapkeys" prop_mapkeys , testProperty "split" prop_splitModel , testProperty "splitRoot" prop_splitRoot + , testProperty "isSubmapOf" prop_isSubmapOf + , testProperty "isSubmapOfBy" prop_isSubmapOfBy + , testProperty "isProperSubmapOf" prop_isProperSubmapOf + , testProperty "isProperSubmapOfBy" prop_isProperSubmapOfBy , testProperty "foldr" prop_foldr , testProperty "foldr'" prop_foldr' , testProperty "foldl" prop_foldl @@ -206,6 +211,7 @@ main = defaultMain , testProperty "prop_FoldableTraversableCompat" prop_FoldableTraversableCompat + , testProperty "elem" prop_elem , testProperty "keysSet" prop_keysSet , testProperty "fromSet" prop_fromSet , testProperty "restrictKeys" prop_restrictKeys @@ -277,6 +283,8 @@ test_index = do test_index_lookup :: Assertion test_index_lookup = do + (empty :: SMap) !? 1 @?= Nothing + fromList [(5,'a'), (3,'b')] !? 1 @?= Nothing fromList [(5,'a'), (3,'b')] !? 5 @?= Just 'a' @@ -304,6 +312,8 @@ test_size2 = do test_member :: Assertion test_member = do + member 5 empty @?= False + member 5 (fromList [(5,'a'), (3,'b')]) @?= True member 1 (fromList [(5,'a'), (3,'b')]) @?= False @@ -313,6 +323,8 @@ test_member = do test_notMember :: Assertion test_notMember = do + notMember 5 empty @?= True + notMember 5 (fromList [(5,'a'), (3,'b')]) @?= False notMember 1 (fromList [(5,'a'), (3,'b')]) @?= True @@ -336,6 +348,8 @@ test_lookup = do test_findWithDefault :: Assertion test_findWithDefault = do + findWithDefault 'x' 1 empty @?= 'x' + findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) @?= 'x' findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) @?= 'a' @@ -347,6 +361,8 @@ test_findWithDefault = do test_lookupLT :: Assertion test_lookupLT = do + lookupLT 3 (empty :: SMap) @?= Nothing + lookupLT 3 (fromList [(3,'a'), (5,'b')]) @?= Nothing lookupLT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a') @@ -357,6 +373,8 @@ test_lookupLT = do test_lookupGT :: Assertion test_lookupGT = do + lookupGT 4 (empty :: SMap) @?= Nothing + lookupGT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b') lookupGT 5 (fromList [(3,'a'), (5,'b')]) @?= Nothing @@ -367,6 +385,8 @@ test_lookupGT = do test_lookupLE :: Assertion test_lookupLE = do + lookupLE 2 (empty :: SMap) @?= Nothing + lookupLE 2 (fromList [(3,'a'), (5,'b')]) @?= Nothing lookupLE 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a') lookupLE 5 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b') @@ -379,6 +399,8 @@ test_lookupLE = do test_lookupGE :: Assertion test_lookupGE = do + lookupGE 3 (empty :: SMap) @?= Nothing + lookupGE 3 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a') lookupGE 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b') lookupGE 6 (fromList [(3,'a'), (5,'b')]) @?= Nothing @@ -506,6 +528,8 @@ test_adjustWithKey = do test_update :: Assertion test_update = do + update f 5 empty @?= empty + update f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "new a")] update f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] update f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" @@ -519,6 +543,8 @@ test_update = do test_updateWithKey :: Assertion test_updateWithKey = do + updateWithKey f 5 empty @?= empty + updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:new a")] updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" @@ -532,6 +558,8 @@ test_updateWithKey = do test_updateLookupWithKey :: Assertion test_updateLookupWithKey = do + updateLookupWithKey f 5 empty @?= (Nothing, empty) + updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:new a")]) updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= (Nothing, fromList [(3, "b"), (5, "a")]) updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= (Just "b", singleton 5 "a") @@ -545,6 +573,9 @@ test_updateLookupWithKey = do test_alter :: Assertion test_alter = do + alter f 7 empty @?= (empty :: SMap) + alter g 7 empty @?= singleton 7 "c" + alter f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] alter f 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" alter g 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "c")] @@ -567,21 +598,25 @@ test_alter = do test_union :: Assertion test_union = do + union empty empty @?= (empty :: SMap) union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")] union (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(-3, "b"), (5, "a"), (7, "C")] test_mappend :: Assertion test_mappend = do + mappend empty empty @?= (empty :: SMap) mappend (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")] mappend (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(-3, "b"), (5, "a"), (7, "C")] test_unionWith :: Assertion test_unionWith = do + unionWith (++) empty empty @?= (empty :: SMap) unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "aA"), (7, "C")] unionWith (++) (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(-3, "b"), (5, "aA"), (7, "C")] test_unionWithKey :: Assertion test_unionWithKey = do + unionWithKey f empty empty @?= (empty :: SMap) unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "5:a|A"), (7, "C")] unionWithKey f (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(-3, "b"), (5, "5:a|A"), (7, "C")] where @@ -589,6 +624,8 @@ test_unionWithKey = do test_unions :: Assertion test_unions = do + unions [] @?= (empty :: SMap) + unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] @?= fromList [(3, "b"), (5, "a"), (7, "C")] unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] @@ -601,6 +638,8 @@ test_unions = do test_mconcat :: Assertion test_mconcat = do + mconcat [] @?= (empty :: SMap) + mconcat [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] @?= fromList [(3, "b"), (5, "a"), (7, "C")] mconcat [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] @@ -613,6 +652,7 @@ test_mconcat = do test_unionsWith :: Assertion test_unionsWith = do + unionsWith (++) [] @?= (empty :: SMap) unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] @?= fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] unionsWith (++) [(fromList [(5, "a"), (-3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (-3, "B3")])] @@ -620,11 +660,17 @@ test_unionsWith = do test_difference :: Assertion test_difference = do + difference empty empty @?= (empty :: SMap) + difference empty (fromList [(5, "A"), (7, "C")]) @?= (empty :: SMap) + difference (fromList [(5, "a"), (3, "b")]) empty @?= fromList [(5, "a"), (3, "b")] difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 3 "b" difference (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton (-3) "b" test_differenceWith :: Assertion test_differenceWith = do + differenceWith f empty empty @?= (empty :: SMap) + differenceWith f empty (fromList [(5, "A"), (3, "B"), (7, "C")]) @?= (empty :: SMap) + differenceWith f (fromList [(5, "a"), (3, "b")]) empty @?= fromList [(5, "a"), (3, "b")] differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) @?= singleton 3 "b:B" differenceWith f (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (-3, "B"), (7, "C")]) @@ -634,6 +680,9 @@ test_differenceWith = do test_differenceWithKey :: Assertion test_differenceWithKey = do + differenceWithKey f empty empty @?= (empty :: SMap) + differenceWithKey f empty (fromList [(5, "A"), (3, "B"), (7, "C")]) @?= empty + differenceWithKey f (fromList [(5, "a"), (3, "b")]) empty @?= fromList [(5, "a"), (3, "b")] differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) @?= singleton 3 "3:b|B" differenceWithKey f (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (-3, "B"), (10, "C")]) @@ -643,17 +692,26 @@ test_differenceWithKey = do test_intersection :: Assertion test_intersection = do + intersection empty empty @?= (empty :: SMap) + intersection empty (fromList [(5, "A"), (7, "C")]) @?= (empty :: SMap) + intersection (fromList [(5, "a"), (3, "b")]) empty @?= empty intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a" intersection (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a" test_intersectionWith :: Assertion test_intersectionWith = do + intersectionWith (++) empty empty @?= (empty :: SMap) + intersectionWith (++) empty (fromList [(5, "A"), (7, "C")]) @?= empty + intersectionWith (++) (fromList [(5, "a"), (3, "b")]) empty @?= empty intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA" intersectionWith (++) (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA" test_intersectionWithKey :: Assertion test_intersectionWithKey = do + intersectionWithKey f empty empty @?= (empty :: SMap) + intersectionWithKey f empty (fromList [(5, "A"), (7, "C")]) @?= empty + intersectionWithKey f (fromList [(5, "a"), (3, "b")]) empty @?= empty intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "5:a|A" intersectionWithKey f (fromList [(5, "a"), (-3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "5:a|A" where @@ -664,12 +722,14 @@ test_intersectionWithKey = do test_map :: Assertion test_map = do + map (++ "x") empty @?= empty map (++ "x") (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "bx"), (5, "ax")] map (++ "x") (fromList [(5,"a"), (3,"b"), (-1,"c")]) @?= fromList [(3, "bx"), (5, "ax"), (-1,"cx")] test_mapWithKey :: Assertion test_mapWithKey = do + mapWithKey f empty @?= empty mapWithKey f (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "3:b"), (5, "5:a")] mapWithKey f (fromList [(5,"a"), (3,"b"), (-1,"c")]) @?= fromList [(3, "3:b"), (5, "5:a"), (-1,"-1:c")] @@ -678,6 +738,7 @@ test_mapWithKey = do test_mapAccum :: Assertion test_mapAccum = do + mapAccum f "Everything: " empty @?= ("Everything: ", empty) mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) @?= ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) mapAccum f "Everything: " (fromList [(5,"a"), (3,"b"), (-1,"c")]) @?= ("Everything: cba", fromList [(3, "bX"), (5, "aX"), (-1, "cX")]) @@ -686,6 +747,7 @@ test_mapAccum = do test_mapAccumWithKey :: Assertion test_mapAccumWithKey = do + mapAccumWithKey f "Everything:" empty @?= ("Everything:", empty) mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b"), (-1,"c")]) @?= ("Everything: -1-c 3-b 5-a", fromList [(3, "bX"), (5, "aX"), (-1,"cX")]) @@ -694,6 +756,7 @@ test_mapAccumWithKey = do test_mapAccumRWithKey :: Assertion test_mapAccumRWithKey = do + mapAccumRWithKey f "Everything:" empty @?= ("Everything:", empty) mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 5-a 3-b", fromList [(3, "bX"), (5, "aX")]) mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b"), (-1,"c")]) @?= ("Everything: 5-a 3-b -1-c", fromList [(3, "bX"), (5, "aX"), (-1,"cX")]) @@ -702,6 +765,8 @@ test_mapAccumRWithKey = do test_mapKeys :: Assertion test_mapKeys = do + mapKeys (+ 1) empty @?= (empty :: SMap) + mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) @?= fromList [(4, "b"), (6, "a")] mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "c" mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "c" @@ -715,6 +780,8 @@ test_mapKeys = do test_mapKeysWith :: Assertion test_mapKeysWith = do + mapKeysWith (++) (\ _ -> 1) empty @?= (empty :: SMap) + mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "cdab" mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "cdab" @@ -723,6 +790,8 @@ test_mapKeysWith = do test_mapKeysMonotonic :: Assertion test_mapKeysMonotonic = do + mapKeysMonotonic (+ 1) empty @?= (empty :: SMap) + mapKeysMonotonic (+ 1) (fromList [(5,"a"), (3,"b")]) @?= fromList [(4, "b"), (6, "a")] mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) @?= fromList [(6, "b"), (10, "a")] @@ -801,16 +870,19 @@ test_fromListWithKey = do test_toAscList :: Assertion test_toAscList = do + toAscList (empty :: SMap) @?= [] toAscList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")] toAscList (fromList [(5,"a"), (-3,"b")]) @?= [(-3,"b"), (5,"a")] test_toDescList :: Assertion test_toDescList = do + toDescList (empty :: SMap) @?= [] toDescList (fromList [(5,"a"), (3,"b")]) @?= [(5,"a"), (3,"b")] toDescList (fromList [(5,"a"), (-3,"b")]) @?= [(5,"a"), (-3,"b")] test_showTree :: Assertion test_showTree = do + showTree (empty :: UMap) @?= unlines [] showTree posTree @?= expectedPosTree showTree negTree @?= expectedNegTree where mkAscTree ls = fromDistinctAscList [(x,()) | x <- ls] @@ -843,6 +915,8 @@ test_showTree = do test_fromAscList :: Assertion test_fromAscList = do + fromAscList [] @?= (empty :: SMap) + fromAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")] fromAscList [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "b")] @@ -852,11 +926,15 @@ test_fromAscList = do test_fromAscListWith :: Assertion test_fromAscListWith = do + fromAscListWith (++) [] @?= (empty :: SMap) + fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "ba")] fromAscListWith (++) [(-3,"b"), (5,"a"), (5,"b")] @?= fromList [(-3, "b"), (5, "ba")] test_fromAscListWithKey :: Assertion test_fromAscListWithKey = do + fromAscListWithKey f [] @?= (empty :: SMap) + fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] @?= fromList [(3, "b"), (5, "5:b5:ba")] fromAscListWithKey f [(-3,"b"), (5,"a"), (5,"b"), (5,"b")] @?= fromList [(-3, "b"), (5, "5:b5:ba")] where @@ -864,6 +942,7 @@ test_fromAscListWithKey = do test_fromDistinctAscList :: Assertion test_fromDistinctAscList = do + fromDistinctAscList [] @?= (empty :: SMap) fromDistinctAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")] fromDistinctAscList [(-3,"b"), (5,"a")] @?= fromList [(-3, "b"), (5, "a")] @@ -872,6 +951,8 @@ test_fromDistinctAscList = do test_filter :: Assertion test_filter = do + filter (> "a") (empty :: SMap) @?= empty + filter (> "a") (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" filter (> "x") (fromList [(5,"a"), (3,"b")]) @?= empty filter (< "a") (fromList [(5,"a"), (3,"b")]) @?= empty @@ -882,11 +963,15 @@ test_filter = do test_filteWithKey :: Assertion test_filteWithKey = do + filterWithKey (\k _ -> k > 4) (empty :: SMap) @?= empty + filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (-3,"b")]) @?= singleton 5 "a" test_partition :: Assertion test_partition = do + partition (> "a") (empty :: SMap) @?= (empty, empty) + partition (> "a") (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a") partition (< "x") (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty) partition (> "x") (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")]) @@ -897,6 +982,8 @@ test_partition = do test_partitionWithKey :: Assertion test_partitionWithKey = do + partitionWithKey (\ k _ -> k > 3) (empty :: SMap) @?= (empty, empty) + partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) @?= (singleton 5 "a", singleton 3 "b") partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty) partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")]) @@ -907,6 +994,7 @@ test_partitionWithKey = do test_mapMaybe :: Assertion test_mapMaybe = do + mapMaybe f (empty :: SMap) @?= empty mapMaybe f (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "new a" mapMaybe f (fromList [(5,"a"), (-3,"b")]) @?= singleton 5 "new a" where @@ -914,6 +1002,7 @@ test_mapMaybe = do test_mapMaybeWithKey :: Assertion test_mapMaybeWithKey = do + mapMaybeWithKey f (empty :: SMap) @?= empty mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "key : 3" mapMaybeWithKey f (fromList [(5,"a"), (-3,"b")]) @?= singleton (-3) "key : -3" where @@ -921,6 +1010,8 @@ test_mapMaybeWithKey = do test_mapEither :: Assertion test_mapEither = do + mapEither f (empty :: SMap) @?= (empty, empty) + mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @?= (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -935,6 +1026,8 @@ test_mapEither = do test_mapEitherWithKey :: Assertion test_mapEitherWithKey = do + mapEitherWithKey f (empty :: SMap) @?= (empty, empty) + mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @?= (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @@ -949,6 +1042,8 @@ test_mapEitherWithKey = do test_split :: Assertion test_split = do + split 2 (empty :: SMap) @?= (empty, empty) + split 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3,"b"), (5,"a")]) split 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, singleton 5 "a") split 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a") @@ -963,6 +1058,8 @@ test_split = do test_splitLookup :: Assertion test_splitLookup = do + splitLookup 2 (empty :: SMap) @?= (empty, Nothing, empty) + splitLookup 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, Nothing, fromList [(3,"b"), (5,"a")]) splitLookup 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, Just "b", singleton 5 "a") splitLookup 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", Nothing, singleton 5 "a") @@ -980,6 +1077,10 @@ test_splitLookup = do test_isSubmapOfBy :: Assertion test_isSubmapOfBy = do + isSubmapOfBy (==) empty (empty :: IMap) @?= True + isSubmapOfBy (==) (fromList [(-1,1),(2,2)]) empty @?= False + isSubmapOfBy (==) empty (fromList [(-1,1),(2,2)]) @?= True + isSubmapOfBy (==) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True isSubmapOfBy (<=) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True isSubmapOfBy (==) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True @@ -997,6 +1098,10 @@ test_isSubmapOfBy = do test_isSubmapOf :: Assertion test_isSubmapOf = do + isSubmapOf empty (empty :: IMap) @?= True + isSubmapOf (fromList [(-1,1),(2,2)]) empty @?= False + isSubmapOf empty (fromList [(-1,1),(2,2)]) @?= True + isSubmapOf (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True isSubmapOf (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True isSubmapOf (fromList [(fromEnum 'a',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False @@ -1009,6 +1114,10 @@ test_isSubmapOf = do test_isProperSubmapOfBy :: Assertion test_isProperSubmapOfBy = do + isProperSubmapOfBy (==) empty (empty :: IMap) @?= False + isProperSubmapOfBy (==) (fromList [(-1,1),(2,2)]) empty @?= False + isProperSubmapOfBy (==) empty (fromList [(-1,1),(2,2)]) @?= True + isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False @@ -1023,6 +1132,10 @@ test_isProperSubmapOfBy = do test_isProperSubmapOf :: Assertion test_isProperSubmapOf = do + isProperSubmapOf empty (empty :: IMap) @?= False + isProperSubmapOf (fromList [(-1,1),(2,2)]) empty @?= False + isProperSubmapOf empty (fromList [(-1,1),(2,2)]) @?= True + isProperSubmapOf (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False @@ -1403,14 +1516,14 @@ prop_alter t k = valid t' .&&. case lookup k t of -- Compare against the list model (after nub on keys) prop_index :: [Int] -> Property -prop_index xs = length xs > 0 ==> +prop_index xs = let m = fromList (zip xs xs) - in xs == [ m ! i | i <- xs ] + in xs === [ m ! i | i <- xs ] prop_index_lookup :: [Int] -> Property -prop_index_lookup xs = length xs > 0 ==> +prop_index_lookup xs = let m = fromList (zip xs xs) - in (Prelude.map Just xs) == [ m !? i | i <- xs ] + in (Prelude.map Just xs) === [ m !? i | i <- xs ] prop_null :: IMap -> Bool prop_null m = null m == (size m == 0) @@ -1499,14 +1612,14 @@ prop_deleteMaxModel ys = length ys > 0 ==> in toAscList (deleteMax m) == init (sort xs) prop_filter :: Fun Int Bool -> [(Int, Int)] -> Property -prop_filter p ys = length ys > 0 ==> +prop_filter p ys = let xs = List.nubBy ((==) `on` fst) ys m = filter (apply p) (fromList xs) in valid m .&&. m === fromList (List.filter (apply p . snd) xs) prop_partition :: Fun Int Bool -> [(Int, Int)] -> Property -prop_partition p ys = length ys > 0 ==> +prop_partition p ys = let xs = List.nubBy ((==) `on` fst) ys m@(l, r) = partition (apply p) (fromList xs) in valid l .&&. @@ -1514,26 +1627,35 @@ prop_partition p ys = length ys > 0 ==> m === let (a,b) = (List.partition (apply p . snd) xs) in (fromList a, fromList b) +prop_partitionWithKey :: Fun (Int, Int) Bool -> [(Int, Int)] -> Property +prop_partitionWithKey p ys = + let xs = List.nubBy ((==) `on` fst) ys + m@(l, r) = partitionWithKey (curry (apply p)) (fromList xs) + in valid l .&&. + valid r .&&. + m === let (a,b) = (List.partition (apply p) xs) + in (fromList a, fromList b) + prop_map :: Fun Int Int -> [(Int, Int)] -> Property -prop_map f ys = length ys > 0 ==> +prop_map f ys = let xs = List.nubBy ((==) `on` fst) ys m = fromList xs - in map (apply f) m == fromList [ (a, apply f b) | (a,b) <- xs ] + in map (apply f) m === fromList [ (a, apply f b) | (a,b) <- xs ] prop_fmap :: Fun Int Int -> [(Int, Int)] -> Property -prop_fmap f ys = length ys > 0 ==> +prop_fmap f ys = let xs = List.nubBy ((==) `on` fst) ys m = fromList xs - in fmap (apply f) m == fromList [ (a, apply f b) | (a,b) <- xs ] + in fmap (apply f) m === fromList [ (a, apply f b) | (a,b) <- xs ] prop_mapkeys :: Fun Int Int -> [(Int, Int)] -> Property -prop_mapkeys f ys = length ys > 0 ==> +prop_mapkeys f ys = let xs = List.nubBy ((==) `on` fst) ys m = fromList xs - in mapKeys (apply f) m == (fromList $ List.nubBy ((==) `on` fst) $ reverse [ (apply f a, b) | (a,b) <- sort xs]) + in mapKeys (apply f) m === (fromList $ List.nubBy ((==) `on` fst) $ reverse [ (apply f a, b) | (a,b) <- sort xs]) prop_splitModel :: Int -> [(Int, Int)] -> Property -prop_splitModel n ys = length ys > 0 ==> +prop_splitModel n ys = let xs = List.nubBy ((==) `on` fst) ys (l, r) = split n $ fromList xs in valid l .&&. @@ -1551,59 +1673,76 @@ prop_splitRoot s = loop ls && (s == unions ls) , y <- toList (unions rst) , x > y ] +prop_isSubmapOf :: IMap -> IMap -> Property +prop_isSubmapOf m1 m2 = (m1 `isSubmapOf` m2) === all (\(k, v) -> lookup k m2 == Just v) (toList m1) + +prop_isSubmapOfBy :: Fun (Int, Int) Bool -> IMap -> IMap -> Property +prop_isSubmapOfBy p m1 m2 = isSubmapOfBy (curry (apply p)) m1 m2 === all (\(k, v) -> member k m2 && apply p (v, m2 ! k)) (toList m1) + +prop_isProperSubmapOf :: IMap -> IMap -> Property +prop_isProperSubmapOf m1 m2 = (m1 `isProperSubmapOf` m2) === (size m1 < size m2 && m1 `isSubmapOf` m2) + +prop_isProperSubmapOfBy :: Fun (Int, Int) Bool -> IMap -> IMap -> Property +prop_isProperSubmapOfBy p m1 m2 = isProperSubmapOfBy (curry (apply p)) m1 m2 === (size m1 < size m2 && isSubmapOfBy (curry (apply p)) m1 m2) + prop_foldr :: Int -> [(Int, Int)] -> Property -prop_foldr n ys = length ys > 0 ==> +prop_foldr n ys = let xs = List.nubBy ((==) `on` fst) ys m = fromList xs - in foldr (+) n m == List.foldr (+) n (List.map snd xs) && - foldr (:) [] m == List.map snd (List.sort xs) && - foldrWithKey (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) && - foldrWithKey (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) && - foldrWithKey (\k x xs -> (k,x):xs) [] m == List.sort xs + in foldr (+) n m === List.foldr (+) n (List.map snd xs) .&&. + foldr (:) [] m === List.map snd (List.sort xs) .&&. + foldrWithKey (\_ a b -> a + b) n m === List.foldr (+) n (List.map snd xs) .&&. + foldrWithKey (\k _ b -> k + b) n m === List.foldr (+) n (List.map fst xs) .&&. + foldrWithKey (\k x xs -> (k,x):xs) [] m === List.sort xs prop_foldr' :: Int -> [(Int, Int)] -> Property -prop_foldr' n ys = length ys > 0 ==> +prop_foldr' n ys = let xs = List.nubBy ((==) `on` fst) ys m = fromList xs - in foldr' (+) n m == List.foldr (+) n (List.map snd xs) && - foldr' (:) [] m == List.map snd (List.sort xs) && - foldrWithKey' (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) && - foldrWithKey' (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) && - foldrWithKey' (\k x xs -> (k,x):xs) [] m == List.sort xs + in foldr' (+) n m === List.foldr (+) n (List.map snd xs) .&&. + foldr' (:) [] m === List.map snd (List.sort xs) .&&. + foldrWithKey' (\_ a b -> a + b) n m === List.foldr (+) n (List.map snd xs) .&&. + foldrWithKey' (\k _ b -> k + b) n m === List.foldr (+) n (List.map fst xs) .&&. + foldrWithKey' (\k x xs -> (k,x):xs) [] m === List.sort xs prop_foldl :: Int -> [(Int, Int)] -> Property -prop_foldl n ys = length ys > 0 ==> +prop_foldl n ys = let xs = List.nubBy ((==) `on` fst) ys m = fromList xs - in foldl (+) n m == List.foldr (+) n (List.map snd xs) && - foldl (flip (:)) [] m == reverse (List.map snd (List.sort xs)) && - foldlWithKey (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) && - foldlWithKey (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) && - foldlWithKey (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs) + in foldl (+) n m === List.foldr (+) n (List.map snd xs) .&&. + foldl (flip (:)) [] m === reverse (List.map snd (List.sort xs)) .&&. + foldlWithKey (\b _ a -> a + b) n m === List.foldr (+) n (List.map snd xs) .&&. + foldlWithKey (\b k _ -> k + b) n m === List.foldr (+) n (List.map fst xs) .&&. + foldlWithKey (\xs k x -> (k,x):xs) [] m === reverse (List.sort xs) prop_foldl' :: Int -> [(Int, Int)] -> Property -prop_foldl' n ys = length ys > 0 ==> +prop_foldl' n ys = let xs = List.nubBy ((==) `on` fst) ys m = fromList xs - in foldl' (+) n m == List.foldr (+) n (List.map snd xs) && - foldl' (flip (:)) [] m == reverse (List.map snd (List.sort xs)) && - foldlWithKey' (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) && - foldlWithKey' (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) && - foldlWithKey' (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs) + in foldl' (+) n m === List.foldr (+) n (List.map snd xs) .&&. + foldl' (flip (:)) [] m === reverse (List.map snd (List.sort xs)) .&&. + foldlWithKey' (\b _ a -> a + b) n m === List.foldr (+) n (List.map snd xs) .&&. + foldlWithKey' (\b k _ -> k + b) n m === List.foldr (+) n (List.map fst xs) .&&. + foldlWithKey' (\xs k x -> (k,x):xs) [] m === reverse (List.sort xs) prop_foldrEqFoldMap :: IntMap Int -> Property prop_foldrEqFoldMap m = - foldr (:) [] m === Data.Foldable.foldMap (:[]) m + foldr (:) [] m === Foldable.foldMap (:[]) m prop_foldrWithKeyEqFoldMapWithKey :: IntMap Int -> Property prop_foldrWithKeyEqFoldMapWithKey m = foldrWithKey (\k v -> ((k,v):)) [] m === foldMapWithKey (\k v -> ([(k,v)])) m prop_FoldableTraversableCompat :: Fun A [B] -> IntMap A -> Property -prop_FoldableTraversableCompat fun m = foldMap f m === foldMapDefault f m +prop_FoldableTraversableCompat fun m = Foldable.foldMap f m === foldMapDefault f m where f = apply fun +#if MIN_VERSION_base(4,8,0) +prop_elem :: Int -> IMap -> Property +prop_elem v m = Foldable.elem v m === List.elem v (elems m) +#endif + prop_keysSet :: [(Int, Int)] -> Bool prop_keysSet xs = keysSet (fromList xs) == IntSet.fromList (List.map fst xs) From 8c47cbaf5be8114abdc9ab92f7fe1d3bff0a2d98 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 28 Dec 2019 19:52:44 -0600 Subject: [PATCH 061/147] Only test elem where it exists --- containers-tests/tests/intmap-properties.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 000091695..cfa365d68 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -211,7 +211,9 @@ main = defaultMain , testProperty "prop_FoldableTraversableCompat" prop_FoldableTraversableCompat +#if MIN_VERSION_base(4,8,0) , testProperty "elem" prop_elem +#endif , testProperty "keysSet" prop_keysSet , testProperty "fromSet" prop_fromSet , testProperty "restrictKeys" prop_restrictKeys From 82e121cf5ce44a9942033b6012b9119aa3e1b45d Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sun, 29 Dec 2019 16:50:58 -0600 Subject: [PATCH 062/147] Add some more documentation to the core types of Data.IntMap --- containers/src/Data/IntMap/Internal.hs | 99 ++++++++++++++++++++++++-- 1 file changed, 93 insertions(+), 6 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 000962b6f..b4e916ef1 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,9 +1,9 @@ {-# LANGUAGE CPP, BangPatterns, EmptyDataDecls #-} -#if defined(__GLASGOW_HASKELL__) -{-# LANGUAGE TypeFamilies #-} -#if !defined(TESTING) +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif +#if USE_TYPE_FAMILIES +{-# LANGUAGE TypeFamilies #-} #endif {-# OPTIONS_HADDOCK not-home #-} @@ -310,6 +310,9 @@ import Utils.Containers.Internal.StrictPair (StrictPair(..)) import Prelude hiding (foldr, foldl, lookup, null, map, min, max) +-- These two definitions are the only things defining that this map applies to 'Int' keys. Using +-- 'Int8' or 'Word' or some other two's complement integer type would produce a working, equally +-- efficient map from that type. type Key = Int i2w :: Int -> Word @@ -359,20 +362,37 @@ xorBounds (Bound min) (Bound max) = Data.Bits.xor (i2w min) (i2w max) boundsDisjoint :: Bound L -> Bound R -> Bool boundsDisjoint (Bound min) (Bound max) = min > max --- Phantom types used to separate the types of left and right nodes. --- They are uninhabited simply to ensure that they are only used as type parameters. +-- These are uninhabited to ensure that they are only used as type parameters. +-- | A type tag denoting 'Node's found on left branches or minimum 'Bound's. data L +-- | A type tag denoting 'Node's found on right branches or maximum 'Bound's. data R #if USE_TYPE_FAMILIES -- TODO: If we are relying on GHC features anyway, L and R could be a new kind. + +-- | A 'Key' stored somewhere within an 'IntMap' with a tag representing its role within that map. +-- Following the left-to-right ascending order of keys in the map, a @'Bound' 'L'@ serves the +-- role of a minimum (and so must be less than all other keys in the subtree where it was found), +-- and a @'Bound' 'R'@ serves the role of maximum (and so must be greater than all other keys in +-- the subtree where it was found). +-- +-- Because the tag represents the relationship between a 'Bound' and other keys in a map, the tag +-- will typically only change or be stripped away in a base case where the 'Bound' is known to be +-- in a trivial singleton subtree with only that one key. Therefore, 'boundKey', 'minToMax', and +-- 'maxToMin', which strip or change the tag, should be rare. newtype Bound t = Bound { boundKey :: Key } deriving (Eq, Ord, Show) +-- | The opposite direction of a tag. This is necessary as the 'Bound's in 'IntMap_' and 'Node' +-- are opposite each other, since they form the initial min/max bracket on the map as a whole. +-- This is used in 'Node', where a left branch inherits the minimum from its parent, so needs +-- to specify a new maximum (a right bound), and symmetrically in a right branch. type family Flipped t type instance Flipped L = R type instance Flipped R = L #else --- Without type families, we can't track min vs. max correctly, so we just don't by making that parameter ignored +-- | A 'Key' stored somewhere within an 'IntMap'. Since this was compiled without type families, +-- the associated tag can't be tracked properly and is therefore thrown away. type Bound t = Bound_ newtype Bound_ = Bound { boundKey :: Key } deriving (Eq, Ord, Show) -- This, like L and R, is uninhabited to ensure that it is only used as a type parameter @@ -393,7 +413,70 @@ outOfMaxBound k (Bound max) = k > max -- | A map of integers to values @a@. newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) + +-- | A self-contained tree mapping integers to values @a@. This is tagged according to the type of +-- its root 'Node'. Although the 'L' form is the only one used at the top level, both types are +-- used as intermediates in cases where 'Node' isn't applicable. This happens primarily when the +-- bound that forms the external context for a 'Node' has been deleted. See also 'binL' and +-- 'binR', which allow 'Bin'-like combination of 'IntMap_'s. +-- +-- Unlike a 'Node', which inherits one of its bounds from its parent, an 'IntMap_' stores both of +-- its bounds, one in the 'NonEmpty' constructor and one in the top-level 'Node'. This allows it +-- to be meaningfully navigated without additional external context. +-- +-- Invariants: +-- +-- * The keys within a tree are in order. Specifically, all descendants of wherever a minimum +-- (@'Bound' 'L'@) is stored must contain keys strictly greater than that minimum, and all +-- descendants of wherever a maximum (@'Bound' 'R'@) is stored must contain keys stricly +-- less than that maximum. +-- * All keys within the left branch of a 'Bin' 'Node' must be stricly less than all keys in the +-- right branch of that same 'Node'. Notably, this is true regardless of the signs of the keys; +-- in a map containing negative and nonnegative keys, the top-level 'Bin' will split with the +-- negative keys on the left and the nonnegative keys on the right. +-- * All keys within the left branch of a 'Bin' 'Node' must share a longer bit prefix with the +-- minimum bound for the 'Node' than with the maximum bound for the 'Node', and vice versa for +-- the right branch: all keys within the right branch of a 'Bin' 'Node' must share a longer bit +-- prefix with the maximum bound for the 'Node' than with the minimum bound for the 'Node'. +-- Put another way, under the xor metric, keys in the left branch are closer to the minimum +-- bound than the maximum bound (@'xor' k min < 'xor' k max@), while keys in the right branch +-- are closer to the maximum bound than the minimum bound. (@'xor' k min > 'xor' k max@). +-- +-- The ordering requirements on keys mean that any key will share whatever prefix bits the +-- bounds also share. This invariant implies that branches are taken based on the immediately +-- following bit. When the minimum and maximum are both of the same sign, the 0 branch is lesser +-- and therefore assigned to the left side. For example, when splitting between 4 (@0100@) and +-- 7 (@0111@), which disagree in the 2's place, 5 (@0101) would be found on the left side since +-- it has a 0 in the 2's place; similarly, -7 (@1001@) and -4 (@1100@) disagree in the 4's +-- place, and -5 (@1011@) would be found on the left side since it has a 0 in the 4's place. +-- However, when the minimum and maximum disagree in sign, they differ in the first bit, the +-- sign bit. A 1 in the sign bit indicates a negative number, so in this case the 1 branch is +-- lesser and therefore assigned to the left side. For example, when splitting between -7 +-- (@1001@) and 7 (@0111@), which disagree in the sign bit, 5 (@0101@) would be found on the +-- /right/ side since it has a 0 in the sign bit. +-- +-- Note that one of these minimum and maximum bounds is inherited from the parent of the 'Node'. +-- The terms do not refer to the minimum and maximum keys actually stored somewhere withing the +-- 'Node' or in one of its descendants. +-- +-- These invariants imply a unique tree structure for a given set of keys. In fact, they are +-- overspecified: the second invariant follows from the other two. data IntMap_ t a = NonEmpty {-# UNPACK #-} !(Bound t) a !(Node t a) | Empty deriving (Eq) + +-- | A node within a tree mapping integers to value @a@. Unlike an 'IntMap_', a 'Node' cannot +-- stand fully on its own; it must have some context defining where the splits between left and +-- right are. A @'Node' 'L'@ is typically found on the left branch of another 'Node', so inherits +-- its minimum bound from its parent 'Node', storing only a new maximum. Similarly, a @'Node' 'R'@ +-- is typically found on the right branch of another 'Node', so inherits its maximum bound from +-- its parent 'Node', storing only a new minimum. See 'IntMap_' for further discussion of the tree +-- structure. +-- +-- Because of its incompleteness, functions that navigate 'Node's will typically pass them in two +-- arguments, one providing the missing bound and one providing the actual 'Node'. This isn't +-- universally true. Some functions, like 'map' or 'filter', preserve the overall branch structure +-- and don't need to understand the criteria used to choose between left and right. Others, like +-- 'lookup', only need to understand the branching criteria with regards to a single, fixed key, +-- and can instead pass the xor-distance between that key and the missing bound. data Node t a = Bin {-# UNPACK #-} !(Bound (Flipped t)) a !(Node L a) !(Node R a) | Tip deriving (Eq, Show) instance Show a => Show (IntMap a) where @@ -521,6 +604,10 @@ size :: IntMap a -> Int size (IntMap Empty) = 0 size (IntMap (NonEmpty _ _ node)) = sizeNode node where + -- A binary tree will always have exactly one more leaf than it has internal nodes. Counting + -- the leaves is also more efficient since we don't have to add a bunch of zeros. From a + -- different perspective, where the tree is seen as a shuffled PATRICIA tree, the data was + -- "originally" stored in the leaves, so counting those locations gives the size of the map. sizeNode :: Node t a -> Int sizeNode Tip = 1 sizeNode (Bin _ _ l r) = sizeNode l + sizeNode r From abc68b5509d41674a4b8403ccc7937179a326659 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sun, 29 Dec 2019 17:07:54 -0600 Subject: [PATCH 063/147] Fix moved #include left out from previous commit --- containers/src/Data/IntMap/Internal.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index b4e916ef1..de6d2761f 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -2,14 +2,15 @@ #if !defined(TESTING) && defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif + +#include "containers.h" + #if USE_TYPE_FAMILIES {-# LANGUAGE TypeFamilies #-} #endif {-# OPTIONS_HADDOCK not-home #-} -#include "containers.h" - ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Internal From c9e4f4788baa132618ca1f5fcb1ce17f86c181d2 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sun, 29 Dec 2019 23:21:06 -0600 Subject: [PATCH 064/147] Unify the IntMap insert* implementations into one INLINEd strictness-generic function --- containers/src/Data/IntMap/Internal.hs | 48 +++++++++++++++++ containers/src/Data/IntMap/Lazy.hs | 75 ++------------------------ containers/src/Data/IntMap/Strict.hs | 63 ++-------------------- 3 files changed, 58 insertions(+), 128 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index de6d2761f..aa709d14d 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -879,6 +879,54 @@ lookupGE !k = start empty :: IntMap a empty = IntMap Empty +{-# INLINE insertWithEval #-} +insertWithEval :: (a -> ()) -> (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithEval meval = start + where + start _ !k v (IntMap Empty) = meval v `seq` IntMap (NonEmpty (Bound k) v Tip) + start combine !k v (IntMap (NonEmpty min minV root)) + | inMinBound k min = IntMap (NonEmpty min minV (goL combine k v (xor k min) min root)) + | outOfMinBound k min = meval v `seq` IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) + | otherwise = let v' = combine v minV + in meval v' `seq` IntMap (NonEmpty (Bound k) v' root) + + -- | Insert a key/value pair into a left node when the key is known to be larger + -- than the minimum bound of the subtree. + goL _ !k v !_ !_ Tip = meval v `seq` Bin (Bound k) v Tip Tip + goL combine !k v !xorCache !min (Bin max maxV l r) + -- In the simple case, we recurse into whichever branch is applicable. + | inMaxBound k max = if xorCache < xorCacheMax + then Bin max maxV (goL combine k v xorCache min l) r + else Bin max maxV l (goR combine k v xorCacheMax max r) + -- If the key is the new maximum, then we have two cases to consider. If + -- the split point between 'min' and 'k' is earlier than the split between + -- 'min' and 'max', then we can just immediately create a new node. Otherwise, + -- we need to push 'max' down into the right branch until it arrives at the + -- correct location. + -- + -- We do the this check by simulating a navigation where 'max' is the key, + -- 'min' is the minimum, and 'k' is the maximum. If 'max' belongs on the + -- left side, then the entire old subtree belongs on the left side. If + -- 'max' belongs on the right side, then we have to push it down. + | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax + then meval v `seq` Bin (Bound k) v (Bin max maxV l r) Tip + else meval v `seq` Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + | otherwise = let v' = combine v maxV + in meval v' `seq` Bin max v' l r + where xorCacheMax = xor k max + + goR _ !k v !_ !_ Tip = meval v `seq` Bin (Bound k) v Tip Tip + goR combine !k v !xorCache !max (Bin min minV l r) + | inMinBound k min = if xorCache < xorCacheMin + then Bin min minV l (goR combine k v xorCache max r) + else Bin min minV (goL combine k v xorCacheMin min l) r + | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin + then meval v `seq` Bin (Bound k) v Tip (Bin min minV l r) + else meval v `seq` Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + | otherwise = let v' = combine v minV + in meval v' `seq` Bin min v' l r + where xorCacheMin = xor k min + -- | /O(min(n,W))/. Delete a key and its value from the map. -- When the key is not a member of the map, the original map is returned. delete :: Key -> IntMap a -> IntMap a diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 49f4de62b..e69bf67f2 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -228,6 +228,9 @@ import qualified Data.IntSet (IntSet, toList) import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) +noeval :: a -> () +noeval _ = () + -- | /O(1)/. A map of one element. -- -- > singleton 1 'a' == fromList [(1, 'a')] @@ -244,47 +247,7 @@ singleton k v = IntMap (NonEmpty (Bound k) v Tip) -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] -- > insert 5 'x' empty == singleton 5 'x' insert :: Key -> a -> IntMap a -> IntMap a -insert = start - where - start !k v (IntMap Empty) = IntMap (NonEmpty (Bound k) v Tip) - start !k v (IntMap (NonEmpty min minV root)) - | inMinBound k min = IntMap (NonEmpty min minV (goL k v (xor k min) min root)) - | outOfMinBound k min = IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) - | otherwise = IntMap (NonEmpty (Bound k) v root) - - -- | Insert a key/value pair into a left node when the key is known to be larger - -- than the minimum value of the tree. - goL !k v !_ !_ Tip = Bin (Bound k) v Tip Tip - goL !k v !xorCache !min (Bin max maxV l r) - -- In the simple case, we just recurse into whichever branch is applicable. - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goL k v xorCache min l) r - else Bin max maxV l (goR k v xorCacheMax max r) - -- If the key is the new maximum, then we have two cases to consider. If - -- the split point between 'min' and 'k' is earlier than the split between - -- 'min' and 'max', then we can just immediately create a new node. Otherwise, - -- we need to push 'max' down into the right branch until it arrives at the - -- correct location. - -- We do the this check by simulating a navigation where 'max' is the key, - -- 'min' is the minimum, and 'k' is the maximum. If 'max' belongs on the - -- left side, then the entire old subtree belongs on the left side. If - -- 'max' belongs on the right side, then we have to push it down. - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v (Bin max maxV l r) Tip - else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max v l r - where xorCacheMax = xor k max - - goR !k v !_ !_ Tip = Bin (Bound k) v Tip Tip - goR !k v !xorCache !max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goR k v xorCache max r) - else Bin min minV (goL k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v Tip (Bin min minV l r) - else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min v l r - where xorCacheMin = xor k min +insert = insertWithEval noeval const -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWith' f key value mp@ @@ -296,35 +259,7 @@ insert = start -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith = start - where - start _ !k v (IntMap Empty) = IntMap (NonEmpty (Bound k) v Tip) - start combine !k v (IntMap (NonEmpty min minV root)) - | inMinBound k min = IntMap (NonEmpty min minV (goL combine k v (xor k min) min root)) - | outOfMinBound k min = IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) - | otherwise = IntMap (NonEmpty (Bound k) (combine v minV) root) - - goL _ !k v !_ !_ Tip = Bin (Bound k) v Tip Tip - goL combine !k v !xorCache !min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goL combine k v xorCache min l) r - else Bin max maxV l (goR combine k v xorCacheMax max r) - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v (Bin max maxV l r) Tip - else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max (combine v maxV) l r - where xorCacheMax = xor k max - - goR _ !k v !_ !_ Tip = Bin (Bound k) v Tip Tip - goR combine !k v !xorCache !max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goR combine k v xorCache max r) - else Bin min minV (goL combine k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v Tip (Bin min minV l r) - else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min (combine v minV) l r - where xorCacheMin = xor k min +insertWith = insertWithEval noeval -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWithKey' f key value mp@ diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 9a629ada7..561c920a1 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -252,6 +252,9 @@ import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) (#!) = ($!) (#) = ($) +eval :: a -> () +eval !_ = () + -- | /O(1)/. A map of one element. -- -- > singleton 1 'a' == fromList [(1, 'a')] @@ -268,35 +271,7 @@ singleton !k !v = IntMap (NonEmpty (Bound k) v Tip) -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] -- > insert 5 'x' empty == singleton 5 'x' insert :: Key -> a -> IntMap a -> IntMap a -insert = start - where - start !k !v (IntMap Empty) = IntMap (NonEmpty (Bound k) v Tip) - start !k !v (IntMap (NonEmpty min minV root)) - | inMinBound k min = IntMap (NonEmpty min minV (goL k v (xor k min) min root)) - | outOfMinBound k min = IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) - | otherwise = IntMap (NonEmpty (Bound k) v root) - - goL !k v !_ !_ Tip = Bin (Bound k) v Tip Tip - goL !k v !xorCache !min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goL k v xorCache min l) r - else Bin max maxV l (goR k v xorCacheMax max r) - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v (Bin max maxV l r) Tip - else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max v l r - where xorCacheMax = xor k max - - goR !k v !_ !_ Tip = Bin (Bound k) v Tip Tip - goR !k v !xorCache !max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goR k v xorCache max r) - else Bin min minV (goL k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v Tip (Bin min minV l r) - else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min v l r - where xorCacheMin = xor k min +insert = insertWithEval eval const -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWith' f key value mp@ @@ -308,35 +283,7 @@ insert = start -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith = start - where - start _ !k v (IntMap Empty) = IntMap (NonEmpty (Bound k) #! v # Tip) - start combine !k v (IntMap (NonEmpty min minV root)) - | inMinBound k min = IntMap (NonEmpty min minV (goL combine k v (xor k min) min root)) - | outOfMinBound k min = IntMap (NonEmpty (Bound k) #! v # insertMinL (xor k min) min minV root) - | otherwise = IntMap (NonEmpty (Bound k) #! combine v minV # root) - - goL _ !k v !_ !_ Tip = Bin (Bound k) #! v # Tip # Tip - goL combine !k v !xorCache !min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goL combine k v xorCache min l) r - else Bin max maxV l (goR combine k v xorCacheMax max r) - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) #! v # Bin max maxV l r # Tip - else Bin (Bound k) #! v # l # insertMaxR xorCacheMax max maxV r - | otherwise = Bin max #! combine v maxV # l # r - where xorCacheMax = xor k max - - goR _ !k v !_ !_ Tip = Bin (Bound k) #! v # Tip # Tip - goR combine !k v !xorCache !max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goR combine k v xorCache max r) - else Bin min minV (goL combine k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) #! v # Tip # Bin min minV l r - else Bin (Bound k) #! v # insertMinL xorCacheMin min minV l # r - | otherwise = Bin min #! combine v minV # l # r - where xorCacheMin = xor k min +insertWith = insertWithEval eval -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWithKey' f key value mp@ From 80668920dda9a8ad50817b1d4eef8a7ed2a42534 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 11:24:50 -0600 Subject: [PATCH 065/147] Speed up Data.IntMap.size by using an accumulator --- containers-tests/benchmarks/IntMap.hs | 3 ++- containers/src/Data/IntMap/Internal.hs | 8 ++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/containers-tests/benchmarks/IntMap.hs b/containers-tests/benchmarks/IntMap.hs index 8bfc24271..8736f67b0 100644 --- a/containers-tests/benchmarks/IntMap.hs +++ b/containers-tests/benchmarks/IntMap.hs @@ -14,7 +14,8 @@ main = do let m = M.fromAscList elems :: M.IntMap Int evaluate $ rnf [m] defaultMain - [ bench "lookup" $ whnf (lookup keys) m + [ bench "size" $ whnf M.size m + , bench "lookup" $ whnf (lookup keys) m , bench "insert" $ whnf (ins elems) M.empty , bench "insertWith empty" $ whnf (insWith elems) M.empty , bench "insertWith update" $ whnf (insWith elems) m diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index aa709d14d..339f16b69 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -603,15 +603,15 @@ null _ = False -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 size :: IntMap a -> Int size (IntMap Empty) = 0 -size (IntMap (NonEmpty _ _ node)) = sizeNode node +size (IntMap (NonEmpty _ _ node)) = sizeNode 0 node where -- A binary tree will always have exactly one more leaf than it has internal nodes. Counting -- the leaves is also more efficient since we don't have to add a bunch of zeros. From a -- different perspective, where the tree is seen as a shuffled PATRICIA tree, the data was -- "originally" stored in the leaves, so counting those locations gives the size of the map. - sizeNode :: Node t a -> Int - sizeNode Tip = 1 - sizeNode (Bin _ _ l r) = sizeNode l + sizeNode r + sizeNode :: Int -> Node t a -> Int + sizeNode !acc Tip = acc + 1 + sizeNode !acc (Bin _ _ l r) = sizeNode (sizeNode acc l) r -- | /O(min(n,W))/. Is the key a member of the map? -- From 642894f49de0798400ae19a0c3985efb81fc2c48 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 11:31:24 -0600 Subject: [PATCH 066/147] Make bench-cmp output a summary --- containers-tests/benchmarks/bench-cmp.pl | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/containers-tests/benchmarks/bench-cmp.pl b/containers-tests/benchmarks/bench-cmp.pl index 52875ae87..41d0959fd 100755 --- a/containers-tests/benchmarks/bench-cmp.pl +++ b/containers-tests/benchmarks/bench-cmp.pl @@ -10,6 +10,11 @@ my $l2 = <$f2>; $l1 eq $l2 or die "CSV files do not correspond -- $l1 and $l2"; +my $min = 1e50; +my $mult = 1.0; +my $max = 0.0; +my $count = 0; + while (defined($l1 = <$f1>)) { $l2 = <$f2>; @@ -17,8 +22,24 @@ my @parts2 = split /,/, $l2; $parts1[0] eq $parts2[0] or die "CSV files do not correspond -- $parts1[0] and $parts2[0]"; + + my $factor = $parts2[1] / $parts1[1]; + $count = $count + 1; + $mult = $mult * $factor; + if ($factor > $max) { + $max = $factor; + } + if ($factor < $min) { + $min = $factor; + } + printf "%s;%+7.2f%%;%.2e\n", $parts1[0], 100 * $parts2[1] / $parts1[1] - 100, $parts1[1]; } +printf ";\n"; +printf "Minimum;%+7.2f%%\n", ($min - 1.0)*100; +printf "Average;%+7.2f%%\n", (($mult ** (1.0 / $count)) - 1.0) * 100; +printf "Maximum;%+7.2f%%\n", ($max - 1.0) * 100; + close $f2; close $f1; From add1e5102746780157a498e122e0c8f17eac24f5 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 11:44:32 -0600 Subject: [PATCH 067/147] Document Data.IntMap.Internal.insertWithEval --- containers/src/Data/IntMap/Internal.hs | 34 +++++++++++++++++--------- containers/src/Data/IntMap/Strict.hs | 8 +++--- 2 files changed, 26 insertions(+), 16 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 339f16b69..908f7591a 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -879,20 +879,30 @@ lookupGE !k = start empty :: IntMap a empty = IntMap Empty +-- | /O(min(n,W))/. Insert with a combining function, generic over strictness. +-- Before inserting a value into the map, @'insertWithEval' eval@ will strictly +-- depend on the resut of calling @eval@ on the value to be inserted. Passing +-- an evaluation function that does no evaluation will result in lazy +-- insertion, while passing a function that actually evaluates its argument +-- will result in strict insertion. +-- +-- When 'insertWithEval' is given one argument (the evaluation function), it is +-- inlined at the call site. 'insertWithEval' is intended for defining +-- @insert@-style functions. {-# INLINE insertWithEval #-} insertWithEval :: (a -> ()) -> (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWithEval meval = start +insertWithEval eval = start where - start _ !k v (IntMap Empty) = meval v `seq` IntMap (NonEmpty (Bound k) v Tip) + start _ !k v (IntMap Empty) = eval v `seq` IntMap (NonEmpty (Bound k) v Tip) start combine !k v (IntMap (NonEmpty min minV root)) | inMinBound k min = IntMap (NonEmpty min minV (goL combine k v (xor k min) min root)) - | outOfMinBound k min = meval v `seq` IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) + | outOfMinBound k min = eval v `seq` IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) | otherwise = let v' = combine v minV - in meval v' `seq` IntMap (NonEmpty (Bound k) v' root) + in eval v' `seq` IntMap (NonEmpty (Bound k) v' root) -- | Insert a key/value pair into a left node when the key is known to be larger -- than the minimum bound of the subtree. - goL _ !k v !_ !_ Tip = meval v `seq` Bin (Bound k) v Tip Tip + goL _ !k v !_ !_ Tip = eval v `seq` Bin (Bound k) v Tip Tip goL combine !k v !xorCache !min (Bin max maxV l r) -- In the simple case, we recurse into whichever branch is applicable. | inMaxBound k max = if xorCache < xorCacheMax @@ -909,22 +919,22 @@ insertWithEval meval = start -- left side, then the entire old subtree belongs on the left side. If -- 'max' belongs on the right side, then we have to push it down. | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then meval v `seq` Bin (Bound k) v (Bin max maxV l r) Tip - else meval v `seq` Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + then eval v `seq` Bin (Bound k) v (Bin max maxV l r) Tip + else eval v `seq` Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = let v' = combine v maxV - in meval v' `seq` Bin max v' l r + in eval v' `seq` Bin max v' l r where xorCacheMax = xor k max - goR _ !k v !_ !_ Tip = meval v `seq` Bin (Bound k) v Tip Tip + goR _ !k v !_ !_ Tip = eval v `seq` Bin (Bound k) v Tip Tip goR combine !k v !xorCache !max (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin then Bin min minV l (goR combine k v xorCache max r) else Bin min minV (goL combine k v xorCacheMin min l) r | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then meval v `seq` Bin (Bound k) v Tip (Bin min minV l r) - else meval v `seq` Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + then eval v `seq` Bin (Bound k) v Tip (Bin min minV l r) + else eval v `seq` Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = let v' = combine v minV - in meval v' `seq` Bin min v' l r + in eval v' `seq` Bin min v' l r where xorCacheMin = xor k min -- | /O(min(n,W))/. Delete a key and its value from the map. diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 561c920a1..cc9268b1e 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -252,8 +252,8 @@ import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) (#!) = ($!) (#) = ($) -eval :: a -> () -eval !_ = () +wheval :: a -> () +wheval !_ = () -- | /O(1)/. A map of one element. -- @@ -271,7 +271,7 @@ singleton !k !v = IntMap (NonEmpty (Bound k) v Tip) -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] -- > insert 5 'x' empty == singleton 5 'x' insert :: Key -> a -> IntMap a -> IntMap a -insert = insertWithEval eval const +insert = insertWithEval wheval const -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWith' f key value mp@ @@ -283,7 +283,7 @@ insert = insertWithEval eval const -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a -insertWith = insertWithEval eval +insertWith = insertWithEval wheval -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWithKey' f key value mp@ From 2fd6e01bb8d67683798fd783588921c6f396e3be Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 13:07:16 -0600 Subject: [PATCH 068/147] Benchmark both when functions find the key they are looking for and when they don't --- containers-tests/benchmarks/IntMap.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/containers-tests/benchmarks/IntMap.hs b/containers-tests/benchmarks/IntMap.hs index 8736f67b0..b2fbcce34 100644 --- a/containers-tests/benchmarks/IntMap.hs +++ b/containers-tests/benchmarks/IntMap.hs @@ -13,9 +13,11 @@ import Prelude hiding (lookup) main = do let m = M.fromAscList elems :: M.IntMap Int evaluate $ rnf [m] + evaluate $ rnf missKeys defaultMain [ bench "size" $ whnf M.size m - , bench "lookup" $ whnf (lookup keys) m + , bench "lookup hit" $ whnf (lookup keys) m + , bench "lookup miss" $ whnf (lookup keys) m , bench "insert" $ whnf (ins elems) M.empty , bench "insertWith empty" $ whnf (insWith elems) M.empty , bench "insertWith update" $ whnf (insWith elems) m @@ -32,10 +34,14 @@ main = do , bench "foldlWithKey" $ whnf (ins elems) m , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m - , bench "delete" $ whnf (del keys) m - , bench "update" $ whnf (upd keys) m - , bench "updateLookupWithKey" $ whnf (upd' keys) m - , bench "alter" $ whnf (alt keys) m + , bench "delete hit" $ whnf (del keys) m + , bench "delete miss" $ whnf (del missKeys) m + , bench "update hit" $ whnf (upd keys) m + , bench "update miss" $ whnf (upd missKeys) m + , bench "updateLookupWithKey hit" $ whnf (upd' keys) m + , bench "updateLookupWithKey miss" $ whnf (upd' missKeys) m + , bench "alter hit" $ whnf (alt keys) m + , bench "alter miss" $ whnf (alt missKeys) m , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m , bench "fromList" $ whnf M.fromList elems @@ -46,8 +52,9 @@ main = do ] where elems = zip keys values - keys = [1..2^12] - values = [1..2^12] + keys = [1,3..2^13] + missKeys = [0,2..2^13] + values = [1,3..2^13] sum k v1 v2 = k + v1 + v2 consPair k v xs = (k, v) : xs From b3876a567a5377a6badceb28b5cfac79435607f1 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 13:15:39 -0600 Subject: [PATCH 069/147] Make IntMap benchmarks actually test what they claim to Updated benchmarks (relative to pre-rewrite, GHC 8.8.1, x86-64): ``` Benchmark Runtime change Original runtime size -22.79% 2.37e-05 lookup hit -14.41% 2.59e-04 lookup miss -11.58% 2.66e-04 insert empty -3.72% 2.43e-04 insertWith empty -5.96% 2.48e-04 insertWith update -14.93% 1.18e-03 insertWith' empty -7.69% 2.59e-04 insertWith' update -22.60% 1.04e-03 insertWithKey empty -0.46% 2.49e-04 insertWithKey update -2.52% 1.18e-03 insertWithKey' empty +0.57% 2.58e-04 insertWithKey' update -22.26% 1.05e-03 insertLookupWithKey empty -49.33% 1.07e-03 insertLookupWithKey update -34.63% 2.38e-03 map -7.40% 7.46e-05 mapWithKey -22.85% 9.04e-05 foldlWithKey -61.70% 4.53e-08 foldlWithKey' -17.96% 3.01e-05 foldrWithKey -72.06% 4.39e-08 foldrWithKey' -1.56% 2.91e-05 delete hit +14.58% 1.66e-04 delete miss -5.17% 7.73e-04 update hit -22.50% 9.64e-04 update miss -5.04% 7.93e-04 updateLookupWithKey hit -12.58% 1.54e-03 updateLookupWithKey miss +1.93% 1.39e-03 alter hit +29.41% 9.96e-04 alter miss -71.89% 8.52e-04 mapMaybe -13.96% 1.28e-04 mapMaybeWithKey -13.93% 1.28e-04 fromList +23.55% 2.33e-04 fromAscList -30.27% 9.40e-05 fromDistinctAscList -28.05% 9.25e-05 minView -17.96% 6.55e-08 Minimum -72.06% Average -20.10% Maximum +29.41% ``` --- containers-tests/benchmarks/IntMap.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/containers-tests/benchmarks/IntMap.hs b/containers-tests/benchmarks/IntMap.hs index b2fbcce34..c3d2210ff 100644 --- a/containers-tests/benchmarks/IntMap.hs +++ b/containers-tests/benchmarks/IntMap.hs @@ -16,9 +16,9 @@ main = do evaluate $ rnf missKeys defaultMain [ bench "size" $ whnf M.size m - , bench "lookup hit" $ whnf (lookup keys) m - , bench "lookup miss" $ whnf (lookup keys) m - , bench "insert" $ whnf (ins elems) M.empty + , bench "lookup hit" $ whnf (lookup keys) m + , bench "lookup miss" $ whnf (lookup missKeys) m + , bench "insert empty" $ whnf (ins elems) M.empty , bench "insertWith empty" $ whnf (insWith elems) M.empty , bench "insertWith update" $ whnf (insWith elems) m , bench "insertWith' empty" $ whnf (insWith' elems) M.empty @@ -31,9 +31,10 @@ main = do , bench "insertLookupWithKey update" $ whnf (insLookupWithKey elems) m , bench "map" $ whnf (M.map (+ 1)) m , bench "mapWithKey" $ whnf (M.mapWithKey (+)) m - , bench "foldlWithKey" $ whnf (ins elems) m + , bench "foldlWithKey" $ whnf (M.foldlWithKey consPairL []) m , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m - , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m + , bench "foldrWithKey" $ whnf (M.foldrWithKey consPairR []) m + , bench "foldrWithKey'" $ whnf (M.foldrWithKey' sum 0) m , bench "delete hit" $ whnf (del keys) m , bench "delete miss" $ whnf (del missKeys) m , bench "update hit" $ whnf (upd keys) m @@ -56,7 +57,8 @@ main = do missKeys = [0,2..2^13] values = [1,3..2^13] sum k v1 v2 = k + v1 + v2 - consPair k v xs = (k, v) : xs + consPairL xs k v = (k, v) : xs + consPairR k v xs = (k, v) : xs add3 :: Int -> Int -> Int -> Int add3 x y z = x + y + z From ed98bb164bb683daeea0e5838c8e28c818da71bf Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 15:39:51 -0600 Subject: [PATCH 070/147] Add customization back to Data.IntMap.Internal.Debug and default to an in-order tree drawing --- containers-tests/tests/intmap-properties.hs | 36 ++++----- containers/src/Data/IntMap/Internal.hs | 79 +++++++++++--------- containers/src/Data/IntMap/Internal/Debug.hs | 55 +++++++++++--- 3 files changed, 107 insertions(+), 63 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index cfa365d68..06e4a5f95 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -892,27 +892,27 @@ test_showTree = do negTree = mkAscTree [(-2)..2] expectedPosTree = unlines [ "1:=()" - , "+-- 5:=()" - , " +-- 3:=()" - , " | +-*" - , " | +-- 2:=()" - , " | +-*" - , " | +-*" - , " +-- 4:=()" - , " +-*" - , " +-*" + , "| ,-*" + , "| +---. 2:=()" + , "| | +-*" + , "| | `-*" + , "| ,---' 3:=()" + , "| +---. 4:=()" + , "| | +-*" + , "| | `-*" + , "`---' 5:=()" ] expectedNegTree = unlines [ "-2:=()" - , "+-- 2:=()" - , " +-- -1:=()" - , " | +-*" - , " | +-*" - , " +-- 0:=()" - , " +-- 1:=()" - , " | +-*" - , " | +-*" - , " +-*" + , "| ,-*" + , "| +-*" + , "| ,---' -1:=()" + , "| +---. 0:=()" + , "| | | ,-*" + , "| | | +-*" + , "| | +---' 1:=()" + , "| | `-*" + , "`---' 2:=()" ] test_fromAscList :: Assertion diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 908f7591a..89b55e42a 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -98,22 +98,22 @@ -- approach is extremely slow and space-inefficient. To see why, look at the tree structure -- for @'singleton' 5 "hello"@: -- --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-0-. --- > +-1-. --- > +-0-. --- > +-1- "hello" +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-0-. +-- > `-1-. +-- > `-0-. +-- > `-1- "hello" -- -- Note that, for brevity, the word size in this diagram is 16 bits. It would be 4 times longer -- for a 64-bit system. In this atrocious tree structure, there is one pointer for every bit, a @@ -128,14 +128,14 @@ -- taken. For example, again temporarily shortening the word size to 16 bits: -- -- >>> singleton 5 "hello" --- +-0000000000000101- "hello" +-- `-0000000000000101- "hello" -- -- >>> fromList [(1, "1"), (4, "4"), (5, "5")] --- +-0000000000000-. +-- `-0000000000000-. -- +-001- "1" --- +-10-. +-- `-10-. -- +-0- "4" --- +-1- "5" +-- `-1- "5" -- -- This is much more space-efficient, and the basic operations, while more complicated, are still -- straightforward. In Haskell, the structure is @@ -162,14 +162,14 @@ -- The tree structure looks identical, just with different labels on the edges: -- -- >>> singleton 5 "hello" --- +-5- "hello" +-- `-5- "hello" -- -- >>> fromList [(1, "1"), (4, "4"), (5, "5")] --- +-(1,5)-. +-- `-(1,5)-. -- +-1- "1" --- +-(4,5)-. +-- `-(4,5)-. -- +-4- "4" --- +-5- "5" +-- `-5- "5" -- -- Traversing this tree efficiently is a bit more difficult, but still possible. See 'xor' for -- details. Moreover, since the tree contains exact minima and maxima, 'lookup' can already be @@ -204,15 +204,26 @@ -- -- >>> singleton 5 "hello" -- 5 --- +- "hello" +-- `- "hello" -- -- >>> fromList [(1, "1"), (4, "4"), (5, "5")] -- 1 --- +-5-. +-- `-5-. -- +- "1" --- +-4-. +-- `-4-. -- +- "4" --- +- "5" +-- `- "5" +-- +-- It may be easier to visualize what is happening here if we draw our trees +-- with maxima coming after their children: +-- +-- >>> fromList [(1, "1"), (4, "4"), (5, "5")] +-- 1 +-- | ,- "1" +-- | +-4-. +-- | | +- "4" +-- | | `- "5" +-- `-5-' -- -- Although the nonuniform tree structure results in more complex code, we save a word in each -- node. @@ -232,15 +243,15 @@ -- -- >>> singleton 5 "hello" -- 5 "hello" --- +- +-- `- -- -- >>> fromList [(1, "1"), (4, "4"), (5, "5")] -- 1 "1" --- +-5-. "5" --- +- --- +-4-. "4" --- +- --- +- +-- | ,- +-- | +-4-. "4" +-- | | +- +-- | | `- +-- `-5-' "5" -- -- This simpler representation translates to even more savings in both space and time. Since the -- leaves no longer store any information, GHC will create a single static @Tip@ object and reuse diff --git a/containers/src/Data/IntMap/Internal/Debug.hs b/containers/src/Data/IntMap/Internal/Debug.hs index 3fbe50ccd..ece1118cc 100644 --- a/containers/src/Data/IntMap/Internal/Debug.hs +++ b/containers/src/Data/IntMap/Internal/Debug.hs @@ -6,17 +6,50 @@ module Data.IntMap.Internal.Debug import Prelude hiding (min, max) import Data.IntMap.Internal --- | Show the tree that implements the map. +-- | Show the tree that implements the map. The tree is shown in in-order, +-- ASCII format. showTree :: Show a => IntMap a -> String -showTree = unlines . aux where - aux (IntMap Empty) = [] - aux (IntMap (NonEmpty min minV node)) = (show (boundKey min) ++ ":=" ++ show minV) : auxNode False node - auxNode :: Show a => Bool -> Node t a -> [String] - auxNode _ Tip = ["+-*"] - auxNode lined (Bin bound val l r) = ["+-- " ++ show (boundKey bound) ++ ":=" ++ show val] ++ fmap indent (auxNode True l) ++ fmap indent (auxNode False r) - where - prefix = if lined then '|' else ' ' - indent line = prefix : " " ++ line +showTree = showTreeWith True False where +-- | The expression @'showTreeWith' inorder unicode map@ shows the tree that +-- implements the map. If @inorder@ is true, the tree is arranged so that keys +-- will appear in their natural order; otherwise, parents will always precede +-- their children. If @unicode@ is true, the tree will be drawn with Unicode +-- Box Drawing characters; otherwise, the tree will be drawn in ASCII art. showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String -showTreeWith _ _ = showTree +showTreeWith inorder unicode = unlines . start where + start (IntMap Empty) = [] + start (IntMap (NonEmpty min minV node)) = (show (boundKey min) ++ ":=" ++ show minV) : goL True True node + + goL root fromBefore Tip = [(if fromBefore then if root then ur else rtee else dr) ++ tip] + goL root fromBefore (Bin max maxV l r) + | inorder = fmap (indent fromBefore) children ++ [line] + | otherwise = [line] ++ fmap (indent (not root)) children + where + children = goL False (not inorder) l ++ goR (not inorder) r + line = (if fromBefore then if root then ur else rtee else dr) + ++ horiz ++ horiz ++ horiz + ++ (if inorder then ul else dl) + ++ " " ++ show (boundKey max) ++ ":=" ++ show maxV + + goR fromBefore Tip = [(if fromBefore then ur else rtee) ++ tip] + goR fromBefore (Bin min minV l r) = [line] ++ fmap (indent (not fromBefore)) children + where + children = goL False True l ++ goR True r + line = (if fromBefore then ur else rtee) + ++ horiz ++ horiz ++ horiz + ++ dl + ++ " " ++ show (boundKey min) ++ ":=" ++ show minV + + indent lined line = prefix ++ " " ++ line + where + prefix = if lined then vert else " " + + ul = if unicode then "┘" else "'" + dl = if unicode then "┐" else "." + ur = if unicode then "└" else "`" + dr = if unicode then "┌" else "," + rtee = if unicode then "├" else "+" + vert = if unicode then "│" else "|" + horiz = if unicode then "─" else "-" + tip = if unicode then "╼" else "-*" From ab3b73339eb138685ad738711c560fb7e4169669 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 16:45:01 -0600 Subject: [PATCH 071/147] Fix typos in Data.IntMap.isSubmapOf and friends --- containers-tests/tests/intmap-properties.hs | 19 ++++++++++++++---- containers/src/Data/IntMap/Internal.hs | 22 +++++++++++++++++---- 2 files changed, 33 insertions(+), 8 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 06e4a5f95..e24bc8cd1 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -1675,17 +1675,28 @@ prop_splitRoot s = loop ls && (s == unions ls) , y <- toList (unions rst) , x > y ] +-- 'isSubmapOf' and friends short-circuit all over the place, so test them a +-- lot more. +-- TODO: Is there a way to increase the number of tests that still allows +-- specifying a number at the command line? For example, multiply the +-- passed-in number of tests by 100? +increaseTests = withMaxSuccess 10000 + prop_isSubmapOf :: IMap -> IMap -> Property -prop_isSubmapOf m1 m2 = (m1 `isSubmapOf` m2) === all (\(k, v) -> lookup k m2 == Just v) (toList m1) +prop_isSubmapOf m1 m2 = increaseTests $ (m1 `isSubmapOf` m2) + === all (\(k, v) -> lookup k m2 == Just v) (toList m1) prop_isSubmapOfBy :: Fun (Int, Int) Bool -> IMap -> IMap -> Property -prop_isSubmapOfBy p m1 m2 = isSubmapOfBy (curry (apply p)) m1 m2 === all (\(k, v) -> member k m2 && apply p (v, m2 ! k)) (toList m1) +prop_isSubmapOfBy p m1 m2 = increaseTests $ isSubmapOfBy (curry (apply p)) m1 m2 + === all (\(k, v) -> member k m2 && apply p (v, m2 ! k)) (toList m1) prop_isProperSubmapOf :: IMap -> IMap -> Property -prop_isProperSubmapOf m1 m2 = (m1 `isProperSubmapOf` m2) === (size m1 < size m2 && m1 `isSubmapOf` m2) +prop_isProperSubmapOf m1 m2 = increaseTests $ (m1 `isProperSubmapOf` m2) + === (size m1 < size m2 && m1 `isSubmapOf` m2) prop_isProperSubmapOfBy :: Fun (Int, Int) Bool -> IMap -> IMap -> Property -prop_isProperSubmapOfBy p m1 m2 = isProperSubmapOfBy (curry (apply p)) m1 m2 === (size m1 < size m2 && isSubmapOfBy (curry (apply p)) m1 m2) +prop_isProperSubmapOfBy p m1 m2 = increaseTests $ isProperSubmapOfBy (curry (apply p)) m1 m2 + === (size m1 < size m2 && isSubmapOfBy (curry (apply p)) m1 m2) prop_foldr :: Int -> [(Int, Int)] -> Property prop_foldr n ys = diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 89b55e42a..34ffdc8f2 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1958,6 +1958,20 @@ isSubmapOf = isSubmapOfBy (==) isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool isSubmapOfBy p = start where + -- 'isSubmapOfBy' follows the pattern of 'intersection' with a few exceptions: + -- + -- * We compare bounds (@max1@ and @max2@ in 'goL' and @min1@ and @min2@ in + -- 'goR') before we compare MSBs, since if a subtree of map 1 isn't + -- entirely contained withing map 2, we can immediately return 'False'. + -- * The "disjoint bounds" case is dropped, as it is already caught by + -- comparing minima (in 'goR') or maxima (in 'goL') in the next step. + -- * Once we know that map 1 has a smaller range than map 2 (that is, + -- @min1 > min2 && max1 < max2@, we know map 1 can't have an earlier + -- splitting bit, so we can use the simpler 'ltMSB' instead of + -- 'compareMSB'. + -- * The preconditions of @goL2@, @goR2@, and such in 'intersection' + -- imply that map 1 isn't a submap of map 2, so we omit those and just + -- return 'False'. start (IntMap Empty) !_ = True start !_ (IntMap Empty) = False start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) @@ -1973,7 +1987,7 @@ isSubmapOfBy p = start True | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL minV1 min1 n1 min2 l2 -- LT | otherwise -> goR maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ - | otherwise = p maxV1 maxV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max1 of + | otherwise = p maxV1 maxV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max2 of True -> goRFused max1 (Bin min1 minV1 l1 r1) r2 -- LT False -> goL minV1 min1 l1 min2 l2 && goRFused max1 r1 r2 -- EQ @@ -1994,7 +2008,7 @@ isSubmapOfBy p = start True | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR maxV1 max1 n1 max2 r2 -- LT | otherwise -> goL minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ - | otherwise = p minV1 minV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max1 of + | otherwise = p minV1 minV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max2 of True -> goLFused min1 (Bin max1 maxV1 l1 r1) l2 -- LT False -> goLFused min1 l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ @@ -2069,7 +2083,7 @@ submapCmp p = start True | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL minV1 min1 n1 min2 l2 -- LT | otherwise -> goR maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ - | otherwise = p maxV1 maxV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max1 of + | otherwise = p maxV1 maxV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max2 of True -> goRFusedBool max1 (Bin min1 minV1 l1 r1) r2 -- LT False -> goL minV1 min1 l1 min2 l2 && goRFusedBool max1 r1 r2 -- EQ @@ -2101,7 +2115,7 @@ submapCmp p = start True | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR maxV1 max1 n1 max2 r2 -- LT | otherwise -> goL minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 False -> goL minV1 min1 l1 min2 l2 && goR maxV1 max1 r1 max2 r2 -- EQ - | otherwise = p minV1 minV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max1 of + | otherwise = p minV1 minV2 && case xorBounds min1 max1 `ltMSB` xorBounds min2 max2 of True -> goLFusedBool min1 (Bin max1 maxV1 l1 r1) l2 -- LT False -> goLFusedBool min1 l1 l2 && goR maxV1 max1 r1 max2 r2 -- EQ From 56f604a758368234935318d971d665adfb0bbc73 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 17:33:01 -0600 Subject: [PATCH 072/147] Use the box-drawing tree syntax in documentation --- containers/src/Data/IntMap/Internal.hs | 96 +++++++++++++------------- 1 file changed, 48 insertions(+), 48 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 34ffdc8f2..6c42dda2f 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -98,22 +98,22 @@ -- approach is extremely slow and space-inefficient. To see why, look at the tree structure -- for @'singleton' 5 "hello"@: -- --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-0-. --- > `-1-. --- > `-0-. --- > `-1- "hello" +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─0─┐ +-- > └─1─┐ +-- > └─0─┐ +-- > └─1─ "hello" -- -- Note that, for brevity, the word size in this diagram is 16 bits. It would be 4 times longer -- for a 64-bit system. In this atrocious tree structure, there is one pointer for every bit, a @@ -128,14 +128,14 @@ -- taken. For example, again temporarily shortening the word size to 16 bits: -- -- >>> singleton 5 "hello" --- `-0000000000000101- "hello" +-- └─0000000000000101─ "hello" -- -- >>> fromList [(1, "1"), (4, "4"), (5, "5")] --- `-0000000000000-. --- +-001- "1" --- `-10-. --- +-0- "4" --- `-1- "5" +-- └─0000000000000─┐ +-- ├─001─ "1" +-- └─10─┐ +-- ├─0─ "4" +-- └─1─ "5" -- -- This is much more space-efficient, and the basic operations, while more complicated, are still -- straightforward. In Haskell, the structure is @@ -162,14 +162,14 @@ -- The tree structure looks identical, just with different labels on the edges: -- -- >>> singleton 5 "hello" --- `-5- "hello" +-- └─5─ "hello" -- -- >>> fromList [(1, "1"), (4, "4"), (5, "5")] --- `-(1,5)-. --- +-1- "1" --- `-(4,5)-. --- +-4- "4" --- `-5- "5" +-- └─(1,5)─┐ +-- ├─1─ "1" +-- └─(4,5)─┐ +-- ├─4─ "4" +-- └─5─ "5" -- -- Traversing this tree efficiently is a bit more difficult, but still possible. See 'xor' for -- details. Moreover, since the tree contains exact minima and maxima, 'lookup' can already be @@ -204,26 +204,26 @@ -- -- >>> singleton 5 "hello" -- 5 --- `- "hello" +-- └─ "hello" -- -- >>> fromList [(1, "1"), (4, "4"), (5, "5")] -- 1 --- `-5-. --- +- "1" --- `-4-. --- +- "4" --- `- "5" +-- └─5─┐ +-- ├─ "1" +-- └─4─┐ +-- ├─ "4" +-- └─ "5" -- -- It may be easier to visualize what is happening here if we draw our trees -- with maxima coming after their children: -- -- >>> fromList [(1, "1"), (4, "4"), (5, "5")] -- 1 --- | ,- "1" --- | +-4-. --- | | +- "4" --- | | `- "5" --- `-5-' +-- │ ┌─ "1" +-- │ ├─4─┐ +-- │ │ ├─ "4" +-- │ │ └─ "5" +-- └─5─┘ -- -- Although the nonuniform tree structure results in more complex code, we save a word in each -- node. @@ -243,15 +243,15 @@ -- -- >>> singleton 5 "hello" -- 5 "hello" --- `- +-- └╼ -- -- >>> fromList [(1, "1"), (4, "4"), (5, "5")] -- 1 "1" --- | ,- --- | +-4-. "4" --- | | +- --- | | `- --- `-5-' "5" +-- │ ┌╼ +-- │ ├─4─┐ "4" +-- │ │ ├╼ +-- │ │ └╼ +-- └─5─┘ "5" -- -- This simpler representation translates to even more savings in both space and time. Since the -- leaves no longer store any information, GHC will create a single static @Tip@ object and reuse @@ -332,8 +332,8 @@ i2w = fromIntegral -- | Xor a key with a bound for the purposes of navigation within the tree. -- --- The navigation process is as follows. Suppose we are looking up a key `k` in a tree. We know --- the minimum key in the tree, `min`, and the maximum key, `max`. Represented in binary: +-- The navigation process is as follows. Suppose we are looking up a key @k@ in a tree. We know +-- the minimum key in the tree, @min@, and the maximum key, @max@. Represented in binary: -- -- > shared prefix bit to split on -- > /----------\ / @@ -341,7 +341,7 @@ i2w = fromIntegral -- > max: 010010010101 1 ???????? -- > k: 010010010101 ? ???????? -- --- To figure out in which subtree might contain `k`, we need to know whether the bit to split on +-- To figure out in which subtree might contain @k@, we need to know whether the bit to split on -- is zero or one. Now, if it is zero, then -- -- > xor k min: 000000000000 0 ???????? From 2f21e2994a2ef7008e660af653216653cebf0637 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 19:38:02 -0600 Subject: [PATCH 073/147] Implement type classes for IntMap --- containers/src/Data/IntMap/Internal.hs | 156 +++++++++++++++++++++++-- containers/src/Data/IntMap/Lazy.hs | 4 +- 2 files changed, 149 insertions(+), 11 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 6c42dda2f..477c71746 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,6 +1,9 @@ {-# LANGUAGE CPP, BangPatterns, EmptyDataDecls #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} +#if defined(__GLASGOW_HASKELL__) +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#if !defined(TESTING) +{-# LANGUAGE Trustworthy #-} +#endif #endif #include "containers.h" @@ -305,6 +308,17 @@ import Data.Semigroup (stimes) import Data.Semigroup (Semigroup(..)) #endif import Data.Semigroup (stimesIdempotentMonoid) +import Data.Functor.Classes +#endif + +#if defined(__GLASGOW_HASKELL__) +import Data.Typeable +import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), + DataType, mkDataType) +import Text.Read +#endif +#if __GLASGOW_HASKELL__ >= 708 +import qualified GHC.Exts as GHCExts (IsList(..)) #endif #if !MIN_VERSION_base(4,8,0) @@ -491,20 +505,105 @@ data IntMap_ t a = NonEmpty {-# UNPACK #-} !(Bound t) a !(Node t a) | Empty deri -- and can instead pass the xor-distance between that key and the missing bound. data Node t a = Bin {-# UNPACK #-} !(Bound (Flipped t)) a !(Node L a) !(Node R a) | Tip deriving (Eq, Show) +#if MIN_VERSION_base(4,9,0) +-- | @since 0.5.9 +instance Eq1 IntMap where + liftEq eq (IntMap m1) (IntMap m2) = liftEq eq m1 m2 + +instance Eq1 (IntMap_ t) where + liftEq eq (NonEmpty min1 minV1 root1) (NonEmpty min2 minV2 root2) + = min1 == min2 && eq minV1 minV2 && liftEq eq root1 root2 + liftEq _ Empty Empty = True + liftEq _ _ _ = False + +instance Eq1 (Node t) where + liftEq eq (Bin k1 v1 l1 r1) (Bin k2 v2 l2 r2) + = k1 == k2 && eq v1 v2 && liftEq eq l1 l2 && liftEq eq r1 r2 + liftEq _ Tip Tip = True + liftEq _ _ _ = False +#endif + +instance Ord a => Ord (IntMap a) where + compare m1 m2 = compare (toList m1) (toList m2) + m1 <= m2 = toList m1 <= toList m2 + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.5.9 +instance Ord1 IntMap where + liftCompare cmp m1 m2 = liftCompare (liftCompare cmp) (toList m1) (toList m2) +#endif + + instance Show a => Show (IntMap a) where - show m = "fromList " ++ show (toList m) + showsPrec precedence m = showParen (precedence > 10) (showString "fromList " . shows (toList m)) + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.5.9 +instance Show1 IntMap where + liftShowsPrec innerShowsPrec innerShowList precedence m + = showsUnaryWith listShowsPrec "fromList" precedence (toList m) + where + listShowsPrec = liftShowsPrec pairShowsPrec pairShowList + pairShowsPrec = liftShowsPrec innerShowsPrec innerShowList + pairShowList = liftShowList innerShowsPrec innerShowList +#endif + +instance Read a => Read (IntMap a) where +#if defined(__GLASGOW_HASKELL__) + -- ReadPrec is more efficient than ReadS, so use it if possible + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + fromListLazy <$> readPrec + readListPrec = readListPrecDefault +#else + readsPrec precedence = readParen (precedence > 10) $ \str -> do + ("fromList", str') <- lex str + first fromList <$> reads str' +#endif + +#if MIN_VERSION_base(4,9,0) +instance Read1 IntMap where +#if defined(__GLASGOW_HASKELL__) && MIN_VERSION_base(4,10,0) + liftReadPrec innerOne innerList = readData (readUnaryWith listOne "fromList" fromListLazy) + where + listOne = liftReadPrec pairOne pairList + pairOne = liftReadPrec innerOne innerList + pairList = liftReadListPrec innerOne innerList + liftReadListPrec = liftReadListPrecDefault +#else + liftReadsPrec innerOne innerList = readsData (readsUnaryWith listOne "fromList" fromListLazy) + where + listOne = liftReadsPrec pairOne pairList + pairOne = liftReadsPrec innerOne innerList + pairList = liftReadsListPrec innerOne innerList +#endif +#endif instance Functor IntMap where fmap f (IntMap m) = IntMap (fmap f m) +#if defined(__GLASGOW_HASKELL__) + a <$ (IntMap m) = IntMap (a <$ m) +#endif + instance Functor (IntMap_ t) where fmap _ Empty = Empty fmap f (NonEmpty min minV node) = NonEmpty min (f minV) (fmap f node) +#if defined(__GLASGOW_HASKELL__) + _ <$ Empty = Empty + a <$ NonEmpty min _ node = NonEmpty min a (a <$ node) +#endif + instance Functor (Node t) where fmap _ Tip = Tip fmap f (Bin k v l r) = Bin k (f v) (fmap f l) (fmap f r) +#if defined(__GLASGOW_HASKELL__) + _ <$ Tip = Tip + a <$ Bin k _ l r = Bin k a (a <$ l) (a <$ r) +#endif + instance Data.Foldable.Foldable IntMap where {-# INLINE foldMap #-} foldMap f = start @@ -545,7 +644,6 @@ instance Data.Foldable.Foldable IntMap where go v (Bin _ boundV l r) = v == boundV || go v l || go v r #endif - instance Traversable IntMap where traverse f = start where @@ -558,9 +656,6 @@ instance Traversable IntMap where goR Tip = pure Tip goR (Bin min minV l r) = liftA3 (Bin min) (f minV) (goL l) (goR r) -instance Monoid (IntMap a) where - mempty = empty - mappend = union #if MIN_VERSION_base(4,9,0) instance Semigroup (IntMap a) where @@ -568,9 +663,45 @@ instance Semigroup (IntMap a) where stimes = stimesIdempotentMonoid #endif +instance Monoid (IntMap a) where + mempty = empty + mappend = union + +#if __GLASGOW_HASKELL__ >= 708 +-- | @since 0.5.6.2 +instance GHCExts.IsList (IntMap a) where + type Item (IntMap a) = (Key, a) + fromList = fromListLazy + toList = toList +#endif + +INSTANCE_TYPEABLE1(IntMap) + +#if defined(__GLASGOW_HASKELL__) +-- This instance preserves data abstraction at the cost of inefficiency. +-- We provide limited reflection services for the sake of data abstraction. +instance Data a => Data (IntMap a) where + gfoldl f z im = z fromListLazy `f` (toList im) + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of + 1 -> k (z fromListLazy) + _ -> error "gunfold" + dataTypeOf _ = intMapDataType + dataCast1 f = gcast1 f + +fromListConstr :: Constr +fromListConstr = mkConstr intMapDataType "fromList" [] Prefix + +intMapDataType :: DataType +intMapDataType = mkDataType "Data.IntMap.Internal.IntMap" [fromListConstr] +#endif + instance NFData a => NFData (IntMap a) where - rnf (IntMap Empty) = () - rnf (IntMap (NonEmpty _ v n)) = rnf v `seq` rnf n + rnf (IntMap m) = rnf m + +instance NFData a => NFData (IntMap_ t a) where + rnf Empty = () + rnf (NonEmpty _ v root) = rnf v `seq` rnf root instance NFData a => NFData (Node t a) where rnf Tip = () @@ -948,6 +1079,13 @@ insertWithEval eval = start in eval v' `seq` Bin min v' l r where xorCacheMin = xor k min +-- Small functions that really ought to be defined in Data.IntMap.Lazy but have +-- to be here for the sake of type class implementations +insertLazy :: Key -> a -> IntMap a -> IntMap a +insertLazy = insertWithEval (const ()) const +fromListLazy :: [(Key, a)] -> IntMap a +fromListLazy = Data.List.foldl' (\t (k, a) -> insertLazy k a t) empty + -- | /O(min(n,W))/. Delete a key and its value from the map. -- When the key is not a member of the map, the original map is returned. delete :: Key -> IntMap a -> IntMap a diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index e69bf67f2..d9d4d73d3 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -247,7 +247,7 @@ singleton k v = IntMap (NonEmpty (Bound k) v Tip) -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] -- > insert 5 'x' empty == singleton 5 'x' insert :: Key -> a -> IntMap a -> IntMap a -insert = insertWithEval noeval const +insert = insertLazy -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWith' f key value mp@ @@ -1216,7 +1216,7 @@ fromSet f = fromDistinctAscList . Data.List.map (\k -> (k, f k)) . Data.IntSet.t -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. fromList :: [(Key, a)] -> IntMap a -fromList = Data.List.foldl' (\t (k, a) -> insert k a t) empty +fromList = fromListLazy -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -- From e1a1d85cc54f0b41e9eea0609b9a80b99fb889d0 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 19:53:11 -0600 Subject: [PATCH 074/147] Import <$ where necessary --- containers/src/Data/IntMap/Internal.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 477c71746..09a2ffcca 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -312,6 +312,9 @@ import Data.Functor.Classes #endif #if defined(__GLASGOW_HASKELL__) +#if !MIN_VERSION_base(4,8,0) +import Data.Functor ((<$)) +#endif import Data.Typeable import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType) From d7e94324e05737cfe0343f5e00a535a07f7688cb Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 20:00:24 -0600 Subject: [PATCH 075/147] Fix incorrect method name in Read1 --- containers/src/Data/IntMap/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 09a2ffcca..92a105ca1 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -578,7 +578,7 @@ instance Read1 IntMap where where listOne = liftReadsPrec pairOne pairList pairOne = liftReadsPrec innerOne innerList - pairList = liftReadsListPrec innerOne innerList + pairList = liftReadList innerOne innerList #endif #endif From 6d1cd9057817228be2b25060240dda74f093d83b Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 30 Dec 2019 20:16:00 -0600 Subject: [PATCH 076/147] Move the danger of IsList into a helper module so that IntMap.Internal can be Safe --- containers-tests/containers-tests.cabal | 1 + containers/containers.cabal | 1 + containers/src/Data/IntMap/Internal.hs | 6 +++--- containers/src/Utils/Containers/Internal/IsList.hs | 14 ++++++++++++++ 4 files changed, 19 insertions(+), 3 deletions(-) create mode 100644 containers/src/Utils/Containers/Internal/IsList.hs diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index 2c7637112..3680fbf7c 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -90,6 +90,7 @@ library Data.IntMap.Internal.DeprecatedDebug Data.Map.Internal.DeprecatedShowTree Utils.Containers.Internal.TypeError + Utils.Containers.Internal.IsList if impl(ghc >= 8.6) ghc-options: -Werror diff --git a/containers/containers.cabal b/containers/containers.cabal index 23cfbcdb6..0f7310bf7 100644 --- a/containers/containers.cabal +++ b/containers/containers.cabal @@ -77,6 +77,7 @@ Library if impl(ghc) other-modules: Utils.Containers.Internal.TypeError + Utils.Containers.Internal.IsList Data.Map.Internal.DeprecatedShowTree Data.IntMap.Internal.DeprecatedDebug diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 92a105ca1..8fa5173cb 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -2,7 +2,7 @@ #if defined(__GLASGOW_HASKELL__) {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} #if !defined(TESTING) -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} #endif #endif @@ -321,7 +321,7 @@ import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), import Text.Read #endif #if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as GHCExts (IsList(..)) +import qualified Utils.Containers.Internal.IsList as IsList #endif #if !MIN_VERSION_base(4,8,0) @@ -672,7 +672,7 @@ instance Monoid (IntMap a) where #if __GLASGOW_HASKELL__ >= 708 -- | @since 0.5.6.2 -instance GHCExts.IsList (IntMap a) where +instance IsList.IsList (IntMap a) where type Item (IntMap a) = (Key, a) fromList = fromListLazy toList = toList diff --git a/containers/src/Utils/Containers/Internal/IsList.hs b/containers/src/Utils/Containers/Internal/IsList.hs new file mode 100644 index 000000000..01b0e4dc9 --- /dev/null +++ b/containers/src/Utils/Containers/Internal/IsList.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP, Trustworthy #-} + +-- | A @Trustworthy@ module for the sole purpose of exposing 'GHC.Exts.IsList'. +-- To ensure that this is not misused, this module is not and should not be +-- exposed, and we only export the safe methods ('fromList') and ('toList'). +module Utils.Containers.Internal.IsList ( +#if __GLASGOW_HASKELL__ >= 708 + IsList(Item, fromList, toList) +#endif +) where + +#if __GLASGOW_HASKELL__ >= 708 +import GHC.Exts (IsList(Item, fromList, toList)) +#endif From aa291c570f2582a4c4ecb5ab4b9a15fa75f22279 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 7 Jan 2020 10:37:01 -0600 Subject: [PATCH 077/147] Add an export list to Data.IntMap.Internal --- containers/src/Data/IntMap/Internal.hs | 162 +++++++++++++++++++++++-- 1 file changed, 149 insertions(+), 13 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 8fa5173cb..13e997e24 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -295,7 +295,154 @@ -- must be checked for increased allocation when creating and modifying such -- functions. -module Data.IntMap.Internal where +module Data.IntMap.Internal ( + -- * Map Types + IntMap(..) + , L, R + , Node(..) + , IntMap_(..) + , DeleteResult(..) + + -- ** Key Manipulation + , Key + , Bound(..) + , xor + , xorBounds + , inMinBound + , inMaxBound + , outOfMinBound + , outOfMaxBound + , ltMSB + , compareMSB + , boundsDisjoint + , minToMax + , maxToMin + + -- * Construction + , empty + + -- ** From Unordered Lists + , fromListLazy + + -- ** From Ascending Lists + , BuildStack(..) + , pushBuildStack + , completeBuildStack + + -- * Insertion + , insertLazy + , insertWithEval + , insertMinL + , insertMaxR + + -- * Deletion\/Update + , delete + , deleteL + , deleteR + , deleteMinL + , deleteMaxR + + -- * Query + -- ** Lookup + , lookup + , (!?) + , (!) + , findWithDefault + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + + -- ** Size + , null + , size + + -- * Combine + -- ** Union + , union + , unions + , unionDisjointL + , unionDisjointR + + -- ** Difference + , difference + , (\\) + + -- ** Intersection + , intersection + + -- ** Disjoint + , disjoint + + -- * Folds + , foldr + , foldl + , foldrWithKey + , foldlWithKey + , foldMapWithKey + + -- ** Strict folds + , foldr' + , foldl' + , foldrWithKey' + , foldlWithKey' + + -- * Conversion + , elems + , keys + , assocs + , keysSet + + -- ** Lists + , toList + + -- ** Ordered Lists + , toAscList + , toDescList + + -- ** Internal Manipulation + , binL + , binR + , extractBinL + , extractBinR + , l2rMap + , r2lMap + , nodeToMapL + , nodeToMapR + + -- * Filter + , filter + , filterWithKey + , restrictKeys + , withoutKeys + , partition + , partitionWithKey + , split + , splitLookup + , splitRoot + + -- * Submap + , isSubmapOf + , isSubmapOfBy + , isProperSubmapOf + , isProperSubmapOfBy + + -- * Min\/Max + , lookupMin + , lookupMax + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , minView + , maxView + , minViewWithKey + , maxViewWithKey +) where import Control.DeepSeq (NFData(..)) @@ -337,7 +484,7 @@ import qualified Data.Bits (xor) import qualified Data.IntSet (IntSet, fromDistinctAscList, member, notMember) import Utils.Containers.Internal.StrictPair (StrictPair(..)) -import Prelude hiding (foldr, foldl, lookup, null, map, min, max) +import Prelude hiding (foldr, foldl, filter, lookup, null, map, min, max) -- These two definitions are the only things defining that this map applies to 'Int' keys. Using -- 'Int8' or 'Word' or some other two's complement integer type would produce a working, equally @@ -1997,17 +2144,6 @@ split :: Key -> IntMap a -> (IntMap a, IntMap a) split k m = case splitLookup k m of (lt, _, gt) -> (lt, gt) - -data SplitLookup a = SplitLookup !(IntMap a) !(Maybe a) !(IntMap a) - -mapLT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a -mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt -{-# INLINE mapLT #-} - -mapGT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a -mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt) -{-# INLINE mapGT #-} - -- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot -- key was found in the original map. -- From 59fcfd28e48f4bb1df111a32e365680e88cce941 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 7 Jan 2020 17:49:57 -0600 Subject: [PATCH 078/147] Unify lookup-style functions into one INLINE lookupChurch function --- containers/src/Data/IntMap/Internal.hs | 128 +++++++------------------ 1 file changed, 35 insertions(+), 93 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 13e997e24..979e883f4 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -905,95 +905,60 @@ size (IntMap (NonEmpty _ _ node)) = sizeNode 0 node sizeNode !acc Tip = acc + 1 sizeNode !acc (Bin _ _ l r) = sizeNode (sizeNode acc l) r --- | /O(min(n,W))/. Is the key a member of the map? --- --- > member 5 (fromList [(5,'a'), (3,'b')]) == True --- > member 1 (fromList [(5,'a'), (3,'b')]) == False -member :: Key -> IntMap a -> Bool -member !k = start +-- | /O(min(n,W)/. Lookup the value at a key in the map, returning the result +-- to the provided continuations. See also 'lookup'. +-- +-- When 'lookupChurch' is given three arguments (the continuations and key), it +-- is inlined to the call site. You should therefore use 'lookupChurch' only to +-- define custom lookup functions. +{-# INLINE lookupChurch #-} +lookupChurch :: r -> (a -> r) -> Key -> IntMap a -> r +lookupChurch nothing just !k = start where - start (IntMap Empty) = False - start (IntMap (NonEmpty min _ node)) - | outOfMinBound k min = False - | k == boundKey min = True + start (IntMap Empty) = nothing + start (IntMap (NonEmpty min minV node)) + | outOfMinBound k min = nothing + | k == boundKey min = just minV | otherwise = goL (xor k min) node - goL !_ Tip = False - goL !xorCache (Bin max _ l r) + goL !_ Tip = nothing + goL !xorCache (Bin max maxV l r) | inMaxBound k max = if xorCache < xorCacheMax then goL xorCache l else goR xorCacheMax r - | outOfMaxBound k max = False - | otherwise = True + | outOfMaxBound k max = nothing + | otherwise = just maxV where xorCacheMax = xor k max - goR !_ Tip = False - goR !xorCache (Bin min _ l r) + goR !_ Tip = nothing + goR !xorCache (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin then goR xorCache r else goL xorCacheMin l - | outOfMinBound k min = False - | otherwise = True + | outOfMinBound k min = nothing + | otherwise = just minV where xorCacheMin = xor k min +-- | /O(min(n,W))/. Is the key a member of the map? +-- +-- > member 5 (fromList [(5,'a'), (3,'b')]) == True +-- > member 1 (fromList [(5,'a'), (3,'b')]) == False +{-# NOINLINE[0] member #-} +member :: Key -> IntMap a -> Bool +member !k = lookupChurch False (const True) k + -- | /O(min(n,W))/. Is the key not a member of the map? -- -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True +{-# NOINLINE[0] notMember #-} notMember :: Key -> IntMap a -> Bool -notMember !k = start - where - start (IntMap Empty) = True - start (IntMap (NonEmpty min _ node)) - | outOfMinBound k min = True - | k == boundKey min = False - | otherwise = goL (xor k min) node - - goL !_ Tip = True - goL !xorCache (Bin max _ l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goL xorCache l - else goR xorCacheMax r - | outOfMaxBound k max = True - | otherwise = False - where xorCacheMax = xor k max - - goR !_ Tip = True - goR !xorCache (Bin min _ l r) - | inMinBound k min = if xorCache < xorCacheMin - then goR xorCache r - else goL xorCacheMin l - | outOfMinBound k min = True - | otherwise = False - where xorCacheMin = xor k min +notMember !k = lookupChurch True (const False) k -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'. +{-# NOINLINE[0] lookup #-} lookup :: Key -> IntMap a -> Maybe a -lookup !k = start - where - start (IntMap Empty) = Nothing - start (IntMap (NonEmpty min minV node)) - | outOfMinBound k min = Nothing - | k == boundKey min = Just minV - | otherwise = goL (xor k min) node - - goL !_ Tip = Nothing - goL !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goL xorCache l - else goR xorCacheMax r - | outOfMaxBound k max = Nothing - | otherwise = Just maxV - where xorCacheMax = xor k max - - goR !_ Tip = Nothing - goR !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goR xorCache r - else goL xorCacheMin l - | outOfMinBound k min = Nothing - | otherwise = Just minV - where xorCacheMin = xor k min +lookup !k = lookupChurch Nothing Just k -- | /O(min(n,W))/. The expression @'findWithDefault' def k map@ -- returns the value at key @k@ or returns @def@ when the key is not an @@ -1001,32 +966,9 @@ lookup !k = start -- -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' +{-# NOINLINE[0] findWithDefault #-} findWithDefault :: a -> Key -> IntMap a -> a -findWithDefault def !k = start - where - start (IntMap Empty) = def - start (IntMap (NonEmpty min minV node)) - | outOfMinBound k min = def - | k == boundKey min = minV - | otherwise = goL (xor k min) node - - goL !_ Tip = def - goL !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goL xorCache l - else goR xorCacheMax r - | outOfMaxBound k max = def - | otherwise = maxV - where xorCacheMax = xor k max - - goR !_ Tip = def - goR !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goR xorCache r - else goL xorCacheMin l - | outOfMinBound k min = def - | otherwise = minV - where xorCacheMin = xor k min +findWithDefault def !k = lookupChurch def id k -- | /O(log n)/. Find largest key smaller than the given one and return the -- corresponding (key, value) pair. From ab3f797941c247c9259ba7a144c0f914459b36ba Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 7 Jan 2020 18:09:05 -0600 Subject: [PATCH 079/147] Remove now-unused LookupGE tests for IntMap --- containers-tests/benchmarks/LookupGE/IntMap.hs | 4 +--- containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs | 8 -------- 2 files changed, 1 insertion(+), 11 deletions(-) diff --git a/containers-tests/benchmarks/LookupGE/IntMap.hs b/containers-tests/benchmarks/LookupGE/IntMap.hs index e18d669ca..7c53a2cfd 100644 --- a/containers-tests/benchmarks/LookupGE/IntMap.hs +++ b/containers-tests/benchmarks/LookupGE/IntMap.hs @@ -34,9 +34,7 @@ main = do , \(n,fun) -> bench (n++" !far") $ nf (fge2 fun odds) m_large ] funs1 = [ ("GE split", M.lookupGE1) - , ("GE Craig", M.lookupGE2) - , ("GE Twan", M.lookupGE3) - , ("GE Milan", M.lookupGE4) ] + , ("GE direct", M.lookupGE2) ] fge :: (Int -> M.IntMap Int -> Maybe (Int,Int)) -> [Int] -> M.IntMap Int -> (Int,Int) fge fun xs m = foldl' (\n k -> fromMaybe n (fun k m)) (0,0) xs diff --git a/containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs b/containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs index a168c8cc3..c9512ce64 100644 --- a/containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs +++ b/containers-tests/benchmarks/LookupGE/LookupGE_IntMap.hs @@ -12,8 +12,6 @@ lookupGE1 k m = lookupGE2 = lookupGE -lookupGE3 = lookupGE -lookupGE4 = lookupGE ------------------------------------------------------------------------------- -- Utilities @@ -32,11 +30,5 @@ findMinMaybe m prop_lookupGE12 :: Int -> [Int] -> Bool prop_lookupGE12 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE2 x m - -prop_lookupGE13 :: Int -> [Int] -> Bool -prop_lookupGE13 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE3 x m - -prop_lookupGE14 :: Int -> [Int] -> Bool -prop_lookupGE14 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE4 x m #endif From 6f11681bb7f456236344db03618a3401bc738f71 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 7 Jan 2020 18:19:19 -0600 Subject: [PATCH 080/147] Use appropriate NOINLINE pragmas to ensure that functions defined trivially in terms of another INLINE function don't get inlined before their true definition. --- containers/src/Data/IntMap/Internal.hs | 9 +++++---- containers/src/Data/IntMap/Lazy.hs | 1 + containers/src/Data/IntMap/Strict.hs | 2 ++ 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 979e883f4..c86427e8a 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -943,7 +943,7 @@ lookupChurch nothing just !k = start -- -- > member 5 (fromList [(5,'a'), (3,'b')]) == True -- > member 1 (fromList [(5,'a'), (3,'b')]) == False -{-# NOINLINE[0] member #-} +{-# NOINLINE[1] member #-} member :: Key -> IntMap a -> Bool member !k = lookupChurch False (const True) k @@ -951,12 +951,12 @@ member !k = lookupChurch False (const True) k -- -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True -{-# NOINLINE[0] notMember #-} +{-# NOINLINE[1] notMember #-} notMember :: Key -> IntMap a -> Bool notMember !k = lookupChurch True (const False) k -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'. -{-# NOINLINE[0] lookup #-} +{-# NOINLINE[1] lookup #-} lookup :: Key -> IntMap a -> Maybe a lookup !k = lookupChurch Nothing Just k @@ -966,7 +966,7 @@ lookup !k = lookupChurch Nothing Just k -- -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' -{-# NOINLINE[0] findWithDefault #-} +{-# NOINLINE[1] findWithDefault #-} findWithDefault :: a -> Key -> IntMap a -> a findWithDefault def !k = lookupChurch def id k @@ -1173,6 +1173,7 @@ insertWithEval eval = start -- Small functions that really ought to be defined in Data.IntMap.Lazy but have -- to be here for the sake of type class implementations +{-# NOINLINE[1] insertLazy #-} insertLazy :: Key -> a -> IntMap a -> IntMap a insertLazy = insertWithEval (const ()) const fromListLazy :: [(Key, a)] -> IntMap a diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index d9d4d73d3..b83d021d9 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -258,6 +258,7 @@ insert = insertLazy -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +{-# NOINLINE[1] insertWith #-} insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWith = insertWithEval noeval diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index cc9268b1e..bb673f607 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -270,6 +270,7 @@ singleton !k !v = IntMap (NonEmpty (Bound k) v Tip) -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] -- > insert 5 'x' empty == singleton 5 'x' +{-# NOINLINE[1] insert #-} insert :: Key -> a -> IntMap a -> IntMap a insert = insertWithEval wheval const @@ -282,6 +283,7 @@ insert = insertWithEval wheval const -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" +{-# NOINLINE[1] insertWith #-} insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWith = insertWithEval wheval From a0cc309219e85d5ae7345b17323b6e3f4e27a56c Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 7 Jan 2020 18:33:59 -0600 Subject: [PATCH 081/147] Update IntMap copyright lines --- containers/src/Data/IntMap/Internal.hs | 2 +- containers/src/Data/IntMap/Lazy.hs | 2 +- containers/src/Data/IntMap/Merge/Internal.hs | 2 +- containers/src/Data/IntMap/Merge/Lazy.hs | 3 ++- containers/src/Data/IntMap/Merge/Strict.hs | 3 ++- containers/src/Data/IntMap/Strict.hs | 2 +- 6 files changed, 8 insertions(+), 6 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index c86427e8a..33f64567b 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -19,7 +19,7 @@ -- Module : Data.IntMap.Internal -- Copyright : Documentation & Interface (c) Daan Leijen 2002 -- Documentation (c) Andriy Palamarchuk 2008 --- Documentation & Implementation (c) Jonathan S. 2016 +-- Documentation & Implementation (c) Jonathan "gereeter" S. 2020 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index b83d021d9..eeb1a9599 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -8,7 +8,7 @@ -- Module : Data.IntMap.Lazy -- Copyright : Documentation & Interface (c) Daan Leijen 2002 -- Documentation (c) Andriy Palamarchuk 2008 --- Documentation & Implementation (c) Jonathan S. 2016 +-- Documentation & Implementation (c) Jonathan "gereeter" S. 2020 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index c8d7d3989..c7960e2b3 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -15,7 +15,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Merge.Internal --- Copyright : (c) Jonathan S. 2016 +-- Copyright : (c) Jonathan "gereeter" S. 2020 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : provisional diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 6e47ea534..a68325e2e 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -6,7 +6,8 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Merge.Lazy --- Copyright : (c) Jonathan S. 2016 +-- Copyright : Documentation & Interface (c) wren romano 2016 +-- Documentation & Implementation (c) Jonathan "gereeter" S. 2020 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : provisional diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 9d7825853..b7c0cb5d9 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -6,7 +6,8 @@ ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap.Merge.Strict --- Copyright : (c) Jonathan S. 2016 +-- Copyright : Documentation & Interface (c) wren romano 2016 +-- Documentation & Implementation (c) Jonathan "gereeter" S. 2020 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : provisional diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index bb673f607..0c3012ca3 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -8,7 +8,7 @@ -- Module : Data.IntMap.Strict -- Copyright : Documentation & Interface (c) Daan Leijen 2002 -- Documentation (c) Andriy Palamarchuk 2008 --- Documentation & Implementation (c) Jonathan S. 2016 +-- Documentation & Implementation (c) Jonathan "gereeter" S. 2020 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Portability : portable From e82e21ab80813044b3502ecd9255d2b6b7bb7dfe Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 7 Jan 2020 22:03:00 -0600 Subject: [PATCH 082/147] Re-enable list fusion for the IntMap conversion-to-list functions --- containers/include/containers.h | 1 + containers/src/Data/IntMap/Internal.hs | 50 ++++++++++++++++++++++++-- 2 files changed, 48 insertions(+), 3 deletions(-) diff --git a/containers/include/containers.h b/containers/include/containers.h index e2ec8f85f..e622ea3d5 100644 --- a/containers/include/containers.h +++ b/containers/include/containers.h @@ -37,6 +37,7 @@ # define USE_ST_MONAD 1 # define USE_UNBOXED_ARRAYS 1 # define USE_TYPE_FAMILIES 1 +# define USE_REWRITE_RULES 1 #endif #endif diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 33f64567b..4ab57db0a 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,9 +1,6 @@ {-# LANGUAGE CPP, BangPatterns, EmptyDataDecls #-} #if defined(__GLASGOW_HASKELL__) {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#if !defined(TESTING) -{-# LANGUAGE Safe #-} -#endif #endif #include "containers.h" @@ -11,6 +8,13 @@ #if USE_TYPE_FAMILIES {-# LANGUAGE TypeFamilies #-} #endif +#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) +#if USE_REWRITE_RULES +{-# LANGUAGE Trustworthy #-} +#else +{-# LANGUAGE Safe #-} +#endif +#endif {-# OPTIONS_HADDOCK not-home #-} @@ -470,6 +474,9 @@ import Text.Read #if __GLASGOW_HASKELL__ >= 708 import qualified Utils.Containers.Internal.IsList as IsList #endif +#if USE_REWRITE_RULES +import GHC.Exts (build) +#endif #if !MIN_VERSION_base(4,8,0) import Data.Word (Word) @@ -1903,6 +1910,43 @@ toAscList = foldrWithKey (\k v l -> (k, v) : l) [] toDescList :: IntMap a -> [(Key, a)] toDescList = foldlWithKey (\l k v -> (k, v) : l) [] +-- List fusion for the list generating functions. +#if USE_REWRITE_RULES +-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion. +-- They are important to convert unfused methods back: see mapFB in Prelude. +foldrFB :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldrFB = foldrWithKey +{-# INLINE[0] foldrFB #-} +foldlFB :: (a -> Key -> b -> a) -> a -> IntMap b -> a +foldlFB = foldlWithKey +{-# INLINE[0] foldlFB #-} + +-- Inline assocs and toList so that we need to fuse only toAscList. +{-# INLINE assocs #-} +{-# INLINE toList #-} + +-- The fusion is enabled up to phase 2 included. If it does not succeed, +-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to +-- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were +-- used in a list fusion, otherwise it would go away in phase 1), and let compiler +-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to +-- inline it before phase 0, otherwise the fusion rules would not fire at all. +{-# NOINLINE[0] elems #-} +{-# NOINLINE[0] keys #-} +{-# NOINLINE[0] toAscList #-} +{-# NOINLINE[0] toDescList #-} +{-# RULES +"IntMap.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) +"IntMap.elems back" [1] foldrFB (\_ x xs -> x : xs) [] = elems +"IntMap.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) +"IntMap.keys back" [1] foldrFB (\k _ xs -> k : xs) [] = keys +"IntMap.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k, x) xs) n m) +"IntMap.toAscList back" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList +"IntMap.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k, x) xs) n m) +"IntMap.toDescList back" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList + #-} +#endif + -- | A stack used in the in-order building of IntMaps. data BuildStack a = Push {-# UNPACK #-} !(Bound L) a !(Node L a) !(BuildStack a) | StackBase From e4eb35949196bfed5305a287fa9923981ef55683 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 8 Jan 2020 00:56:06 -0600 Subject: [PATCH 083/147] Add an export list to Data.IntMap.Merge.Internal --- containers/src/Data/IntMap/Merge/Internal.hs | 24 +++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index c7960e2b3..e9420c9f2 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -39,7 +39,29 @@ -- on representations. ----------------------------------------------------------------------------- -module Data.IntMap.Merge.Internal where +module Data.IntMap.Merge.Internal ( + -- * Types and inspection of tactics + WhenMissing(..) + , WhenMatched(..) + , SimpleWhenMissing + , SimpleWhenMatched +#if !MIN_VERSION_base(4,8,0) + , Identity(..) +#endif + , runWhenMissing + , runWhenMatched + , runWhenMissingAll + + -- * General combining functions + , merge + , mergeA + + -- * @WhenMissing@ tactics + , dropMissing + , preserveMissing + , filterMissing + , filterAMissing +) where import Prelude hiding (min, max) From 9a2df5c2aba93f644a8e5d401ecc08a5056b807e Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 8 Jan 2020 09:49:02 -0600 Subject: [PATCH 084/147] Don't bind the combination function in Data.IntMap.unionWith ``` unionWith-block_nn -8.76% 8.21e-05 unionWith-block_nn_swap -7.78% 8.12e-05 unionWith-block_ns -17.58% 6.56e-06 unionWith-block_sn_swap -17.33% 6.64e-06 unionWith-common_nn -3.82% 1.08e-02 unionWith-common_nn_swap -4.32% 1.08e-02 unionWith-common_ns -3.86% 2.53e-03 unionWith-common_nt -4.12% 4.50e-05 unionWith-common_sn_swap -4.38% 2.55e-03 unionWith-common_tn_swap -9.08% 4.96e-05 unionWith-disj_nn -48.71% 2.85e-07 unionWith-disj_nn_swap -49.35% 2.89e-07 unionWith-disj_ns -52.23% 2.71e-07 unionWith-disj_nt -55.48% 2.39e-07 unionWith-disj_sn_swap -51.94% 2.71e-07 unionWith-disj_tn_swap -55.96% 2.43e-07 unionWith-mix_nn -7.93% 1.46e-02 unionWith-mix_nn_swap -8.32% 1.46e-02 unionWith-mix_ns -5.41% 2.53e-03 unionWith-mix_nt -3.51% 4.92e-05 unionWith-mix_sn_swap -3.44% 2.56e-03 unionWith-mix_tn_swap -9.39% 5.44e-05 ``` --- .../SetOperations/SetOperations-IntMap.hs | 2 +- containers/src/Data/IntMap/Lazy.hs | 192 +++++++++--------- containers/src/Data/IntMap/Strict.hs | 192 +++++++++--------- 3 files changed, 193 insertions(+), 193 deletions(-) diff --git a/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs b/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs index 036c82caa..a3af94af7 100644 --- a/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs +++ b/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs @@ -3,4 +3,4 @@ module Main where import Data.IntMap as C import SetOperations -main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)] +main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True [("union", C.union), ("unionWith", C.unionWith (+)), ("difference", C.difference), ("intersection", C.intersection)] diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index eeb1a9599..31427f758 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -538,131 +538,131 @@ unionWith f = unionWithKey (const f) -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWithKey combine = start +unionWithKey = start where - start (IntMap Empty) m2 = m2 - start m1 (IntMap Empty) = m1 - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 minV2 min1 root1 min2 root2)) - | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) - | otherwise = IntMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 - - goL1 minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip - goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = unionDisjointL minV1 min2 n2 min1 n1 - goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 - goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 - | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) l2 (goRFused max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - - goL2 minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip - goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor (boundKey min2) min1) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = unionDisjointL minV2 min1 n1 min2 n2 - goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 - goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 - | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) l1 (goRFused max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 + start _ (IntMap Empty) m2 = m2 + start _ m1 (IntMap Empty) = m1 + start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 combine minV1 min1 root1 min2 root2)) + | otherwise = IntMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + + goL1 _ minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip + goL1 _ minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 + goL1 _ minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = unionDisjointL minV1 min2 n2 min1 n1 + goL1 combine minV1 !min1 Tip !min2 !n2 = goInsertL1 combine (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 + goL1 combine minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + | max1 > max2 -> Bin max1 maxV1 l2 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> Bin max2 maxV2 l2 (goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) l2 (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 n2) r1 + + goL2 _ minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip + goL2 _ minV2 !min1 Tip !min2 !n2 = insertMinL (xor (boundKey min2) min1) min2 minV2 n2 + goL2 _ minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = unionDisjointL minV2 min1 n1 min2 n2 + goL2 combine minV2 !min1 !n1 !min2 Tip = goInsertL2 combine (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 + goL2 combine minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> Bin max2 maxV2 l1 (goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) l1 (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + LT -> Bin max2 maxV2 (goL2 combine minV2 min1 n1 min2 l2) r2 -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' - goLFused !_ Tip n2 = n2 - goLFused !_ n1 Tip = n1 - goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 - EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - - goR1 maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip - goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor (boundKey max1) max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = unionDisjointR maxV1 max1 n1 max2 n2 - goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 - goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 - GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - - goR2 maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip - goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor (boundKey max2) max1) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = unionDisjointR maxV2 max2 n2 max1 n1 - goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 - goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 - LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) + goLFused _ !_ Tip n2 = n2 + goLFused _ !_ n1 Tip = n1 + goLFused combine min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of + LT -> Bin max2 maxV2 (goLFused combine min n1 l2) r2 + EQ | max1 > max2 -> Bin max1 maxV1 (goLFused combine min l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> Bin max1 maxV1 (goLFused combine min l1 n2) r1 + + goR1 _ maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip + goR1 _ maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor (boundKey max1) max2) max1 maxV1 n1 + goR1 _ maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = unionDisjointR maxV1 max1 n1 max2 n2 + goR1 combine maxV1 !max1 Tip !max2 !n2 = goInsertR1 combine (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 + goR1 combine maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 combine maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT -> Bin min1 minV1 l1 (goR1 combine maxV1 max1 r1 max2 n2) + + goR2 _ maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip + goR2 _ maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor (boundKey max2) max1) max2 maxV2 n2 + goR2 _ maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = unionDisjointR maxV2 max2 n2 max1 n1 + goR2 combine maxV2 !max1 !n1 !max2 Tip = goInsertR2 combine (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 + goR2 combine maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + LT -> Bin min2 minV2 l2 (goR2 combine maxV2 max1 n1 max2 r2) -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' - goRFused !_ Tip n2 = n2 - goRFused !_ n1 Tip = n1 - goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> Bin min2 minV2 l2 (goRFused max n1 r2) - EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 - GT -> Bin min1 minV1 l1 (goRFused max r1 n2) - - goInsertL1 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertL1 k v !xorCache min (Bin max maxV l r) + goRFused _ !_ Tip n2 = n2 + goRFused _ !_ n1 Tip = n1 + goRFused combine max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of + LT -> Bin min2 minV2 l2 (goRFused combine max n1 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max r1 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + GT -> Bin min1 minV1 l1 (goRFused combine max r1 n2) + + goInsertL1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip + goInsertL1 combine k v !xorCache min (Bin max maxV l r) | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL1 k v xorCache min l) r - else Bin max maxV l (goInsertR1 k v xorCacheMax max r) + then Bin max maxV (goInsertL1 combine k v xorCache min l) r + else Bin max maxV l (goInsertR1 combine k v xorCacheMax max r) | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax then Bin (Bound k) v (Bin max maxV l r) Tip else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max (combine k v maxV) l r where xorCacheMax = xor k max - goInsertR1 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR1 k v !xorCache max (Bin min minV l r) + goInsertR1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip + goInsertR1 combine k v !xorCache max (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR1 k v xorCache max r) - else Bin min minV (goInsertL1 k v xorCacheMin min l) r + then Bin min minV l (goInsertR1 combine k v xorCache max r) + else Bin min minV (goInsertL1 combine k v xorCacheMin min l) r | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin then Bin (Bound k) v Tip (Bin min minV l r) else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min (combine k v minV) l r where xorCacheMin = xor k min - goInsertL2 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertL2 k v !xorCache min (Bin max maxV l r) + goInsertL2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip + goInsertL2 combine k v !xorCache min (Bin max maxV l r) | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL2 k v xorCache min l) r - else Bin max maxV l (goInsertR2 k v xorCacheMax max r) + then Bin max maxV (goInsertL2 combine k v xorCache min l) r + else Bin max maxV l (goInsertR2 combine k v xorCacheMax max r) | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax then Bin (Bound k) v (Bin max maxV l r) Tip else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max (combine k maxV v) l r where xorCacheMax = xor k max - goInsertR2 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR2 k v !xorCache max (Bin min minV l r) + goInsertR2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip + goInsertR2 combine k v !xorCache max (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR2 k v xorCache max r) - else Bin min minV (goInsertL2 k v xorCacheMin min l) r + then Bin min minV l (goInsertR2 combine k v xorCache max r) + else Bin min minV (goInsertL2 combine k v xorCacheMin min l) r | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin then Bin (Bound k) v Tip (Bin min minV l r) else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 0c3012ca3..dc8a40c8d 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -563,131 +563,131 @@ unionWith f = unionWithKey (const f) -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWithKey combine = start +unionWithKey = start where - start (IntMap Empty) m2 = m2 - start m1 (IntMap Empty) = m1 - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 minV2 min1 root1 min2 root2)) - | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) - | otherwise = IntMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 - - goL1 minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip - goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = unionDisjointL minV1 min2 n2 min1 n1 - goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 - goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 - | max1 > max2 -> Bin max1 maxV1 l2 (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> Bin max2 maxV2 l2 (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goL1 minV1 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - - goL2 minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip - goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor (boundKey min2) min1) min2 minV2 n2 - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = unionDisjointL minV2 min1 n1 min2 n2 - goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 - goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 - | max1 > max2 -> Bin max1 maxV1 l1 (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | max1 < max2 -> Bin max2 maxV2 l1 (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l1 # goRFused max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goL2 minV2 min1 l1 min2 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - LT -> Bin max2 maxV2 (goL2 minV2 min1 n1 min2 l2) r2 + start _ (IntMap Empty) m2 = m2 + start _ m1 (IntMap Empty) = m1 + start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) + | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 combine minV1 min1 root1 min2 root2)) + | otherwise = IntMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + + goL1 _ minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip + goL1 _ minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 + goL1 _ minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = unionDisjointL minV1 min2 n2 min1 n1 + goL1 combine minV1 !min1 Tip !min2 !n2 = goInsertL1 combine (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 + goL1 combine minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 + | max1 > max2 -> Bin max1 maxV1 l2 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> Bin max2 maxV2 l2 (goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goL1 combine minV1 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 n2) r1 + + goL2 _ minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip + goL2 _ minV2 !min1 Tip !min2 !n2 = insertMinL (xor (boundKey min2) min1) min2 minV2 n2 + goL2 _ minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = unionDisjointL minV2 min1 n1 min2 n2 + goL2 combine minV2 !min1 !n1 !min2 Tip = goInsertL2 combine (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 + goL2 combine minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> Bin max2 maxV2 l1 (goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l1 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goL2 combine minV2 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + LT -> Bin max2 maxV2 (goL2 combine minV2 min1 n1 min2 l2) r2 -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goL' - goLFused !_ Tip n2 = n2 - goLFused !_ n1 Tip = n1 - goLFused min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> Bin max2 maxV2 (goLFused min n1 l2) r2 - EQ | max1 > max2 -> Bin max1 maxV1 (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> Bin max2 maxV2 (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goLFused min l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - - goR1 maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip - goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor (boundKey max1) max2) max1 maxV1 n1 - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = unionDisjointR maxV1 max1 n1 max2 n2 - goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 - goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # goR1 maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 - GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - - goR2 maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip - goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor (boundKey max2) max1) max2 maxV2 n2 - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = unionDisjointR maxV2 max2 n2 max1 n1 - goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 - goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 - | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # goR2 maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 - LT -> Bin min2 minV2 l2 (goR2 maxV2 max1 n1 max2 r2) + goLFused _ !_ Tip n2 = n2 + goLFused _ !_ n1 Tip = n1 + goLFused combine min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of + LT -> Bin max2 maxV2 (goLFused combine min n1 l2) r2 + EQ | max1 > max2 -> Bin max1 maxV1 (goLFused combine min l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> Bin max2 maxV2 (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> Bin max1 maxV1 (goLFused combine min l1 n2) r1 + + goR1 _ maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip + goR1 _ maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor (boundKey max1) max2) max1 maxV1 n1 + goR1 _ maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = unionDisjointR maxV1 max1 n1 max2 n2 + goR1 combine maxV1 !max1 Tip !max2 !n2 = goInsertR1 combine (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 + goR1 combine maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 combine maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 + | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goR1 combine maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + GT -> Bin min1 minV1 l1 (goR1 combine maxV1 max1 r1 max2 n2) + + goR2 _ maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip + goR2 _ maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor (boundKey max2) max1) max2 maxV2 n2 + goR2 _ maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = unionDisjointR maxV2 max2 n2 max1 n1 + goR2 combine maxV2 !max1 !n1 !max2 Tip = goInsertR2 combine (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 + goR2 combine maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goR2 combine maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + LT -> Bin min2 minV2 l2 (goR2 combine maxV2 max1 n1 max2 r2) -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same -- Note that because of this property, the trees cannot be disjoint, so we can skip most of the checks in 'goR' - goRFused !_ Tip n2 = n2 - goRFused !_ n1 Tip = n1 - goRFused max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> Bin min2 minV2 l2 (goRFused max n1 r2) - EQ | min1 < min2 -> Bin min1 minV1 (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) - | min1 > min2 -> Bin min2 minV2 (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # goRFused max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 - GT -> Bin min1 minV1 l1 (goRFused max r1 n2) - - goInsertL1 k v !_ _ Tip = Bin (Bound k) #! v # Tip # Tip - goInsertL1 k v !xorCache min (Bin max maxV l r) + goRFused _ !_ Tip n2 = n2 + goRFused _ !_ n1 Tip = n1 + goRFused combine max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of + LT -> Bin min2 minV2 l2 (goRFused combine max n1 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max r1 r2) + | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 + GT -> Bin min1 minV1 l1 (goRFused combine max r1 n2) + + goInsertL1 _ k v !_ _ Tip = Bin (Bound k) #! v # Tip # Tip + goInsertL1 combine k v !xorCache min (Bin max maxV l r) | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL1 k v xorCache min l) r - else Bin max maxV l (goInsertR1 k v xorCacheMax max r) + then Bin max maxV (goInsertL1 combine k v xorCache min l) r + else Bin max maxV l (goInsertR1 combine k v xorCacheMax max r) | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax then Bin (Bound k) v (Bin max maxV l r) Tip else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max #! combine k v maxV # l # r where xorCacheMax = xor k max - goInsertR1 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR1 k v !xorCache max (Bin min minV l r) + goInsertR1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip + goInsertR1 combine k v !xorCache max (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR1 k v xorCache max r) - else Bin min minV (goInsertL1 k v xorCacheMin min l) r + then Bin min minV l (goInsertR1 combine k v xorCache max r) + else Bin min minV (goInsertL1 combine k v xorCacheMin min l) r | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin then Bin (Bound k) v Tip (Bin min minV l r) else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r | otherwise = Bin min #! combine k v minV # l # r where xorCacheMin = xor k min - goInsertL2 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertL2 k v !xorCache min (Bin max maxV l r) + goInsertL2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip + goInsertL2 combine k v !xorCache min (Bin max maxV l r) | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL2 k v xorCache min l) r - else Bin max maxV l (goInsertR2 k v xorCacheMax max r) + then Bin max maxV (goInsertL2 combine k v xorCache min l) r + else Bin max maxV l (goInsertR2 combine k v xorCacheMax max r) | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax then Bin (Bound k) v (Bin max maxV l r) Tip else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) | otherwise = Bin max #! combine k maxV v # l # r where xorCacheMax = xor k max - goInsertR2 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR2 k v !xorCache max (Bin min minV l r) + goInsertR2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip + goInsertR2 combine k v !xorCache max (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR2 k v xorCache max r) - else Bin min minV (goInsertL2 k v xorCacheMin min l) r + then Bin min minV l (goInsertR2 combine k v xorCache max r) + else Bin min minV (goInsertL2 combine k v xorCacheMin min l) r | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin then Bin (Bound k) v Tip (Bin min minV l r) else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r From 3a34c0980f971272e8294809dfc91d3918514cd5 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 8 Jan 2020 18:10:32 -0600 Subject: [PATCH 085/147] Don't bind arguments in IntMap.intersectionWith. This may have been partially justified before, but is costly now. ``` Benchmark Runtime change Original runtime intersectionWith-block_nn -20.76% 1.61e-05 intersectionWith-block_nn_swap -23.81% 1.61e-05 intersectionWith-block_ns -30.41% 2.04e-06 intersectionWith-block_sn_swap -31.58% 2.13e-06 intersectionWith-common_nn -4.51% 1.02e-02 intersectionWith-common_nn_swap -4.03% 1.02e-02 intersectionWith-common_ns -0.07% 1.26e-03 intersectionWith-common_nt -16.17% 3.26e-05 intersectionWith-common_sn_swap +0.35% 1.28e-03 intersectionWith-common_tn_swap -13.89% 3.22e-05 intersectionWith-disj_nn -79.22% 1.21e-07 intersectionWith-disj_nn_swap -78.40% 1.19e-07 intersectionWith-disj_ns -79.31% 1.21e-07 intersectionWith-disj_nt -79.25% 1.21e-07 intersectionWith-disj_sn_swap -78.44% 1.19e-07 intersectionWith-disj_tn_swap -78.49% 1.19e-07 intersectionWith-mix_nn +11.27% 2.59e-03 intersectionWith-mix_nn_swap +11.45% 2.58e-03 intersectionWith-mix_ns -3.69% 3.56e-04 intersectionWith-mix_nt -17.32% 2.59e-05 intersectionWith-mix_sn_swap -4.98% 3.70e-04 intersectionWith-mix_tn_swap -11.32% 2.43e-05 Minimum -79.31% Average -39.80% Maximum +11.45% ``` --- .../SetOperations/SetOperations-IntMap.hs | 6 +- containers/src/Data/IntMap/Lazy.hs | 222 +++++++++--------- 2 files changed, 114 insertions(+), 114 deletions(-) diff --git a/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs b/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs index a3af94af7..a3bf40824 100644 --- a/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs +++ b/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs @@ -3,4 +3,8 @@ module Main where import Data.IntMap as C import SetOperations -main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True [("union", C.union), ("unionWith", C.unionWith (+)), ("difference", C.difference), ("intersection", C.intersection)] +main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True + [ ("union", C.union), ("unionWith", C.unionWith (+)) + , ("difference", C.difference) + , ("intersection", C.intersection), ("intersectionWith", C.intersectionWith (+)) + ] diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 31427f758..2ad51164f 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -885,139 +885,135 @@ intersectionWith f = intersectionWithKey (const f) -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey combine = start +intersectionWithKey = start where - start (IntMap Empty) !_ = IntMap Empty - start !_ (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (goL2 minV2 min1 root1 min2 root2) - | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) - | otherwise = IntMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + start _ (IntMap Empty) !_ = IntMap Empty + start _ !_ (IntMap Empty) = IntMap Empty + start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (goL2 combine minV2 min1 root1 min2 root2) + | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) + | otherwise = IntMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. - goL1 _ !_ !_ !_ Tip = Empty - goL1 minV1 min1 Tip min2 n2 = goLookupL1 (boundKey min1) minV1 (xor (boundKey min1) min2) n2 - goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = Empty - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lMap $ goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundKey max1) maxV1 maxV2) l' (goRFused max1 r1 r2)) - GT -> goL1 minV1 min1 l1 min2 n2 - - goL2 _ !_ Tip !_ !_ = Empty - goL2 minV2 min1 n1 min2 Tip = goLookupL2 (boundKey min2) minV2 (xor (boundKey min2) min1) n1 - goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = Empty - goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goL2 minV2 min1 n1 min2 l2 - EQ | max1 > max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundKey max1) maxV1 maxV2) l' (goRFused max1 r1 r2)) - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> r2lMap $ goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused max1 r1 (Bin min2 minV2 l2 r2)) - - goLFused min = loop - where - loop Tip !_ = Tip - loop !_ Tip = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT -> loop l1 n2 - - goR1 _ !_ !_ !_ Tip = Empty - goR1 maxV1 max1 Tip max2 n2 = goLookupR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 - goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = Empty - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rMap $ goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) - EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) r') - GT -> goR1 maxV1 max1 r1 max2 n2 - - goR2 _ !_ Tip !_ !_ = Empty - goR2 maxV2 max1 n1 max2 Tip = goLookupR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 - goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = Empty - goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goR2 maxV2 max1 n1 max2 r2 - EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) r') - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> l2rMap $ goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) - - goRFused max = loop - where - loop Tip !_ = Tip - loop !_ Tip = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (loop r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT -> loop r1 n2 - - goLookupL1 !_ _ !_ Tip = Empty - goLookupL1 k v !xorCache (Bin max maxV l r) + goL1 _ _ !_ !_ !_ Tip = Empty + goL1 combine minV1 min1 Tip min2 n2 = goLookupL1 combine (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 _ _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = Empty + goL1 combine minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 + | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> r2lMap $ NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> case goL1 combine minV1 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused combine max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundKey max1) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) + GT -> goL1 combine minV1 min1 l1 min2 n2 + + goL2 _ _ !_ Tip !_ !_ = Empty + goL2 combine minV2 min1 n1 min2 Tip = goLookupL2 combine (boundKey min2) minV2 (xor (boundKey min2) min1) n1 + goL2 _ _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = Empty + goL2 combine minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goL2 combine minV2 min1 n1 min2 l2 + EQ | max1 > max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> case goL2 combine minV2 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused combine max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundKey max1) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 combine minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) + | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) + + goLFused _ !_ Tip !_ = Tip + goLFused _ !_ !_ Tip = Tip + goLFused combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of + LT -> goLFused combine min n1 l2 + EQ | max1 > max2 -> case goR2 combine maxV2 max1 r1 max2 r2 of + Empty -> goLFused combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of + Empty -> goLFused combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> goLFused combine min l1 n2 + + goR1 _ _ !_ !_ !_ Tip = Empty + goR1 combine maxV1 max1 Tip max2 n2 = goLookupR1 combine (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 _ _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = Empty + goR1 combine maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> l2rMap $ NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> case goR1 combine maxV1 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) r') + GT -> goR1 combine maxV1 max1 r1 max2 n2 + + goR2 _ _ !_ Tip !_ !_ = Empty + goR2 combine maxV2 max1 n1 max2 Tip = goLookupR2 combine (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 + goR2 _ _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = Empty + goR2 combine maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goR2 combine maxV2 max1 n1 max2 r2 + EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | otherwise -> case goR2 combine maxV2 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) r') + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 combine maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) + + goRFused _ !_ Tip !_ = Tip + goRFused _ !_ !_ Tip = Tip + goRFused combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of + LT -> goRFused combine max n1 r2 + EQ | min1 < min2 -> case goL2 combine minV2 min1 l1 min2 l2 of + Empty -> goRFused combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of + Empty -> goRFused combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> goRFused combine max r1 n2 + + goLookupL1 _ !_ _ !_ Tip = Empty + goLookupL1 combine k v !xorCache (Bin max maxV l r) | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL1 k v xorCache l - else goLookupR1 k v xorCacheMax r + then goLookupL1 combine k v xorCache l + else goLookupR1 combine k v xorCacheMax r | outOfMaxBound k max = Empty | otherwise = NonEmpty (Bound k) (combine k v maxV) Tip where xorCacheMax = xor k max - goLookupR1 !_ _ !_ Tip = Empty - goLookupR1 k v !xorCache (Bin min minV l r) + goLookupR1 _ !_ _ !_ Tip = Empty + goLookupR1 combine k v !xorCache (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin - then goLookupR1 k v xorCache r - else goLookupL1 k v xorCacheMin l + then goLookupR1 combine k v xorCache r + else goLookupL1 combine k v xorCacheMin l | outOfMinBound k min = Empty | otherwise = NonEmpty (Bound k) (combine k v minV) Tip where xorCacheMin = xor k min - goLookupL2 !_ _ !_ Tip = Empty - goLookupL2 k v !xorCache (Bin max maxV l r) + goLookupL2 _ !_ _ !_ Tip = Empty + goLookupL2 combine k v !xorCache (Bin max maxV l r) | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL2 k v xorCache l - else goLookupR2 k v xorCacheMax r + then goLookupL2 combine k v xorCache l + else goLookupR2 combine k v xorCacheMax r | outOfMaxBound k max = Empty | otherwise = NonEmpty (Bound k) (combine k maxV v) Tip where xorCacheMax = xor k max - goLookupR2 !_ _ !_ Tip = Empty - goLookupR2 k v !xorCache (Bin min minV l r) + goLookupR2 _ !_ _ !_ Tip = Empty + goLookupR2 combine k v !xorCache (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin - then goLookupR2 k v xorCache r - else goLookupL2 k v xorCacheMin l + then goLookupR2 combine k v xorCache r + else goLookupL2 combine k v xorCacheMin l | outOfMinBound k min = Empty | otherwise = NonEmpty (Bound k) (combine k minV v) Tip where xorCacheMin = xor k min From 5e1d0aa9b3ad626c99b4b2d61117e1a48ff5cd75 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 8 Jan 2020 20:24:32 -0600 Subject: [PATCH 086/147] Make IntMap.{min,max}View{,WithKey} more strict, forcing the min/max key before returning a Just result --- containers/src/Data/IntMap/Internal.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 4ab57db0a..111c17ab9 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -2484,14 +2484,14 @@ deleteFindMax m = let (k, a) = findMax m -- stripped of that element, or 'Nothing' if passed an empty map. minView :: IntMap a -> Maybe (a, IntMap a) minView (IntMap Empty) = Nothing -minView m = let (k, a) = findMin m +minView m = let (!k, a) = findMin m in Just (a, delete k m) -- | /O(min(n,W))/. Retrieves the maximal key of the map, and the map -- stripped of that element, or 'Nothing' if passed an empty map. maxView :: IntMap a -> Maybe (a, IntMap a) maxView (IntMap Empty) = Nothing -maxView m = let (k, a) = findMax m +maxView m = let (!k, a) = findMax m in Just (a, delete k m) -- | /O(min(n,W))/. Retrieves the minimal (key,value) pair of the map, and @@ -2501,7 +2501,7 @@ maxView m = let (k, a) = findMax m -- > minViewWithKey empty == Nothing minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) minViewWithKey (IntMap Empty) = Nothing -minViewWithKey m = let (k, a) = findMin m +minViewWithKey m = let (!k, a) = findMin m in Just ((k, a), delete k m) -- | /O(min(n,W))/. Retrieves the maximal (key,value) pair of the map, and @@ -2511,7 +2511,7 @@ minViewWithKey m = let (k, a) = findMin m -- > maxViewWithKey empty == Nothing maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) maxViewWithKey (IntMap Empty) = Nothing -maxViewWithKey m = let (k, a) = findMax m +maxViewWithKey m = let (!k, a) = findMax m in Just ((k, a), delete k m) -- | /O(1)/. Returns whether the most significant bit of its first From b3660e9bd695d18b7a15ec34e9956e708cc968fc Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 9 Jan 2020 09:36:05 -0600 Subject: [PATCH 087/147] Don't incorrectly use BangPatterns nested in another pattern --- containers/src/Data/IntMap/Internal.hs | 16 ++++++++-------- containers/src/Data/IntMap/Lazy.hs | 12 ++++++------ containers/src/Data/IntMap/Strict.hs | 12 ++++++------ 3 files changed, 20 insertions(+), 20 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 111c17ab9..45fb47c1f 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -2484,15 +2484,15 @@ deleteFindMax m = let (k, a) = findMax m -- stripped of that element, or 'Nothing' if passed an empty map. minView :: IntMap a -> Maybe (a, IntMap a) minView (IntMap Empty) = Nothing -minView m = let (!k, a) = findMin m - in Just (a, delete k m) +minView m = let (k, a) = findMin m + in k `seq` Just (a, delete k m) -- | /O(min(n,W))/. Retrieves the maximal key of the map, and the map -- stripped of that element, or 'Nothing' if passed an empty map. maxView :: IntMap a -> Maybe (a, IntMap a) maxView (IntMap Empty) = Nothing -maxView m = let (!k, a) = findMax m - in Just (a, delete k m) +maxView m = let (k, a) = findMax m + in k `seq` Just (a, delete k m) -- | /O(min(n,W))/. Retrieves the minimal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. @@ -2501,8 +2501,8 @@ maxView m = let (!k, a) = findMax m -- > minViewWithKey empty == Nothing minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) minViewWithKey (IntMap Empty) = Nothing -minViewWithKey m = let (!k, a) = findMin m - in Just ((k, a), delete k m) +minViewWithKey m = let (k, a) = findMin m + in k `seq` Just ((k, a), delete k m) -- | /O(min(n,W))/. Retrieves the maximal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. @@ -2511,8 +2511,8 @@ minViewWithKey m = let (!k, a) = findMin m -- > maxViewWithKey empty == Nothing maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) maxViewWithKey (IntMap Empty) = Nothing -maxViewWithKey m = let (!k, a) = findMax m - in Just ((k, a), delete k m) +maxViewWithKey m = let (k, a) = findMax m + in k `seq` Just ((k, a), delete k m) -- | /O(1)/. Returns whether the most significant bit of its first -- argument is less significant than the most significant bit of its diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 2ad51164f..0f688e7d5 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1240,10 +1240,10 @@ fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty fromAscList :: [(Key, a)] -> IntMap a fromAscList = start where start [] = IntMap Empty - start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + start ((min, minV) : rest) = IntMap (go min minV rest StackBase) go !k v [] !stk = completeBuildStack (Bound k) v Tip stk - go !k v ((!next, nextV) : rest) !stk + go !k v ((next, nextV) : rest) !stk | next == k = go k nextV rest stk | otherwise = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) @@ -1264,10 +1264,10 @@ fromAscListWith f = fromAscListWithKey (const f) fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a fromAscListWithKey f = start where start [] = IntMap Empty - start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + start ((min, minV) : rest) = IntMap (go min minV rest StackBase) go !k v [] !stk = completeBuildStack (Bound k) v Tip stk - go !k v ((!next, nextV) : rest) !stk + go !k v ((next, nextV) : rest) !stk | next == k = go k (f k nextV v) rest stk | otherwise = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) @@ -1279,10 +1279,10 @@ fromAscListWithKey f = start where fromDistinctAscList :: [(Key, a)] -> IntMap a fromDistinctAscList = start where start [] = IntMap Empty - start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + start ((min, minV) : rest) = IntMap (go min minV rest StackBase) go !k v [] !stk = completeBuildStack (Bound k) v Tip stk - go !k v ((!next, nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) + go !k v ((next, nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) -- | /O(n)/. Map values and collect the 'Just' results. -- diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index dc8a40c8d..50dec9dca 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1278,12 +1278,12 @@ fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty fromAscList :: [(Key, a)] -> IntMap a fromAscList = start where start [] = IntMap Empty - start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + start ((min, minV) : rest) = IntMap (go min minV rest StackBase) -- The strictness here is tricky, mimicking old behavior. Only the last value -- of a given key (the one being inserted into the map) is evaluated strictly. go !k v [] !stk = completeBuildStack (Bound k) v Tip stk - go !k v ((!next, nextV) : rest) !stk + go !k v ((next, nextV) : rest) !stk | next == k = nextV `seq` go k nextV rest stk | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) @@ -1304,10 +1304,10 @@ fromAscListWith f = fromAscListWithKey (const f) fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a fromAscListWithKey f = start where start [] = IntMap Empty - start ((!min, minV) : rest) = IntMap (go min minV rest StackBase) + start ((min, minV) : rest) = IntMap (go min minV rest StackBase) go !k v [] !stk = completeBuildStack (Bound k) v Tip stk - go !k v ((!next, nextV) : rest) !stk + go !k v ((next, nextV) : rest) !stk | next == k = let !v' = f k nextV v in go k v' rest stk | otherwise = v `seq` go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) @@ -1319,10 +1319,10 @@ fromAscListWithKey f = start where fromDistinctAscList :: [(Key, a)] -> IntMap a fromDistinctAscList = start where start [] = IntMap Empty - start ((!min, !minV) : rest) = IntMap (go min minV rest StackBase) + start ((min, !minV) : rest) = IntMap (go min minV rest StackBase) go !k !v [] !stk = completeBuildStack (Bound k) v Tip stk - go !k !v ((!next, !nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) + go !k !v ((next, !nextV) : rest) !stk = go next nextV rest (pushBuildStack (xor k (Bound next)) k v Tip stk) -- | /O(n)/. Map values and collect the 'Just' results. -- From aa5fbd5ce85154eaad29d77842d6bd7ad6b1fd31 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 9 Jan 2020 09:46:15 -0600 Subject: [PATCH 088/147] Implement the IntMap min/max manipulation functions more directly --- containers/src/Data/IntMap/Internal.hs | 28 +++++++++++++------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 45fb47c1f..5bcb05c31 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -450,6 +450,7 @@ module Data.IntMap.Internal ( import Control.DeepSeq (NFData(..)) +import Data.Maybe (fromMaybe) import qualified Data.List (foldl') import qualified Data.Foldable (Foldable(..)) #if MIN_VERSION_base(4,9,0) @@ -2460,7 +2461,7 @@ findMax (IntMap (NonEmpty min minV root)) = case root of -- versions prior to 0.5 threw an error if the 'IntMap' was already empty. deleteMin :: IntMap a -> IntMap a deleteMin (IntMap Empty) = IntMap Empty -deleteMin m = delete (fst (findMin m)) m +deleteMin (IntMap (NonEmpty _ _ root)) = IntMap (nodeToMapL root) -- | /O(min(n,W))/. Delete the maximal key. Returns an empty map if the map is empty. -- @@ -2468,31 +2469,31 @@ deleteMin m = delete (fst (findMin m)) m -- versions prior to 0.5 threw an error if the 'IntMap' was already empty. deleteMax :: IntMap a -> IntMap a deleteMax (IntMap Empty) = IntMap Empty -deleteMax m = delete (fst (findMax m)) m +deleteMax (IntMap (NonEmpty _ _ Tip)) = IntMap Empty +deleteMax (IntMap (NonEmpty min minV (Bin _ _ l r))) = IntMap (NonEmpty min minV (extractBinL l r)) -- | /O(min(n,W))/. Delete and find the minimal element. deleteFindMin :: IntMap a -> ((Key, a), IntMap a) -deleteFindMin m = let (k, a) = findMin m - in ((k, a), delete k m) +deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") + . minViewWithKey -- | /O(min(n,W))/. Delete and find the maximal element. deleteFindMax :: IntMap a -> ((Key, a), IntMap a) -deleteFindMax m = let (k, a) = findMax m - in ((k, a), delete k m) +deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") + . maxViewWithKey -- | /O(min(n,W))/. Retrieves the minimal key of the map, and the map -- stripped of that element, or 'Nothing' if passed an empty map. minView :: IntMap a -> Maybe (a, IntMap a) minView (IntMap Empty) = Nothing -minView m = let (k, a) = findMin m - in k `seq` Just (a, delete k m) +minView (IntMap (NonEmpty _ minV root)) = Just (minV, IntMap (nodeToMapL root)) -- | /O(min(n,W))/. Retrieves the maximal key of the map, and the map -- stripped of that element, or 'Nothing' if passed an empty map. maxView :: IntMap a -> Maybe (a, IntMap a) maxView (IntMap Empty) = Nothing -maxView m = let (k, a) = findMax m - in k `seq` Just (a, delete k m) +maxView (IntMap (NonEmpty _ minV Tip)) = Just (minV, IntMap Empty) +maxView (IntMap (NonEmpty min minV (Bin _ maxV l r))) = Just (maxV, IntMap (NonEmpty min minV (extractBinL l r))) -- | /O(min(n,W))/. Retrieves the minimal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. @@ -2501,8 +2502,7 @@ maxView m = let (k, a) = findMax m -- > minViewWithKey empty == Nothing minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) minViewWithKey (IntMap Empty) = Nothing -minViewWithKey m = let (k, a) = findMin m - in k `seq` Just ((k, a), delete k m) +minViewWithKey (IntMap (NonEmpty min minV root)) = Just ((boundKey min, minV), IntMap (nodeToMapL root)) -- | /O(min(n,W))/. Retrieves the maximal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map. @@ -2511,8 +2511,8 @@ minViewWithKey m = let (k, a) = findMin m -- > maxViewWithKey empty == Nothing maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a) maxViewWithKey (IntMap Empty) = Nothing -maxViewWithKey m = let (k, a) = findMax m - in k `seq` Just ((k, a), delete k m) +maxViewWithKey (IntMap (NonEmpty min minV Tip)) = Just ((boundKey min, minV), IntMap Empty) +maxViewWithKey (IntMap (NonEmpty min minV (Bin max maxV l r))) = Just ((boundKey max, maxV), IntMap (NonEmpty min minV (extractBinL l r))) -- | /O(1)/. Returns whether the most significant bit of its first -- argument is less significant than the most significant bit of its From 122b4c35a28163ca3306075b681ac9c9e57b1031 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 9 Jan 2020 09:56:39 -0600 Subject: [PATCH 089/147] Implement IntMap.update{Min,Max}{,WithKey} more directly --- containers/src/Data/IntMap/Lazy.hs | 17 +++++++++++------ containers/src/Data/IntMap/Strict.hs | 17 +++++++++++------ 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 0f688e7d5..ede491012 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1429,16 +1429,14 @@ mapEitherWithKey func = start -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMin _ (IntMap Empty) = IntMap Empty -updateMin f m = update f (fst (findMin m)) m +updateMin f = updateMinWithKey (const f) -- | /O(min(n,W))/. Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMax _ (IntMap Empty) = IntMap Empty -updateMax f m = update f (fst (findMax m)) m +updateMax f = updateMaxWithKey (const f) -- | /O(min(n,W))/. Update the value at the minimal key. -- @@ -1446,7 +1444,9 @@ updateMax f m = update f (fst (findMax m)) m -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a updateMinWithKey _ (IntMap Empty) = IntMap Empty -updateMinWithKey f m = updateWithKey f (fst (findMin m)) m +updateMinWithKey f (IntMap (NonEmpty min minV root)) = IntMap $ case f (boundKey min) minV of + Nothing -> nodeToMapL root + Just minV' -> NonEmpty min minV' root -- | /O(min(n,W))/. Update the value at the maximal key. -- @@ -1454,4 +1454,9 @@ updateMinWithKey f m = updateWithKey f (fst (findMin m)) m -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a updateMaxWithKey _ (IntMap Empty) = IntMap Empty -updateMaxWithKey f m = updateWithKey f (fst (findMax m)) m +updateMaxWithKey f (IntMap (NonEmpty min minV Tip)) = IntMap $ case f (boundKey min) minV of + Nothing -> Empty + Just minV' -> NonEmpty min minV' Tip +updateMaxWithKey f (IntMap (NonEmpty min minV (Bin max maxV l r))) = IntMap . NonEmpty min minV $ case f (boundKey max) maxV of + Nothing -> extractBinL l r + Just maxV' -> Bin max maxV' l r diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 50dec9dca..781f9c79e 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1469,16 +1469,14 @@ mapEitherWithKey func = start -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMin _ (IntMap Empty) = IntMap Empty -updateMin f m = update f (fst (findMin m)) m +updateMin f = updateMinWithKey (const f) -- | /O(min(n,W))/. Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a -updateMax _ (IntMap Empty) = IntMap Empty -updateMax f m = update f (fst (findMax m)) m +updateMax f = updateMaxWithKey (const f) -- | /O(min(n,W))/. Update the value at the minimal key. -- @@ -1486,7 +1484,9 @@ updateMax f m = update f (fst (findMax m)) m -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a updateMinWithKey _ (IntMap Empty) = IntMap Empty -updateMinWithKey f m = updateWithKey f (fst (findMin m)) m +updateMinWithKey f (IntMap (NonEmpty min minV root)) = IntMap $ case f (boundKey min) minV of + Nothing -> nodeToMapL root + Just !minV' -> NonEmpty min minV' root -- | /O(min(n,W))/. Update the value at the maximal key. -- @@ -1494,4 +1494,9 @@ updateMinWithKey f m = updateWithKey f (fst (findMin m)) m -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a updateMaxWithKey _ (IntMap Empty) = IntMap Empty -updateMaxWithKey f m = updateWithKey f (fst (findMax m)) m +updateMaxWithKey f (IntMap (NonEmpty min minV Tip)) = IntMap $ case f (boundKey min) minV of + Nothing -> Empty + Just !minV' -> NonEmpty min minV' Tip +updateMaxWithKey f (IntMap (NonEmpty min minV (Bin max maxV l r))) = IntMap . NonEmpty min minV $ case f (boundKey max) maxV of + Nothing -> extractBinL l r + Just !maxV' -> Bin max maxV' l r From a5393eb627190183df0f1e0f5d3005989fc1d9b4 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 9 Jan 2020 10:20:29 -0600 Subject: [PATCH 090/147] Don't bind arguments in Data.IntMap.Strict.intersectionWithKey (and fix indentation in the lazy version) --- containers/src/Data/IntMap/Lazy.hs | 36 ++--- containers/src/Data/IntMap/Strict.hs | 222 +++++++++++++-------------- 2 files changed, 127 insertions(+), 131 deletions(-) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index ede491012..268b80c9d 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -929,15 +929,15 @@ intersectionWithKey = start goLFused _ !_ Tip !_ = Tip goLFused _ !_ !_ Tip = Tip goLFused combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> goLFused combine min n1 l2 - EQ | max1 > max2 -> case goR2 combine maxV2 max1 r1 max2 r2 of - Empty -> goLFused combine min l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' - | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of - Empty -> goLFused combine min l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT -> goLFused combine min l1 n2 + LT -> goLFused combine min n1 l2 + EQ | max1 > max2 -> case goR2 combine maxV2 max1 r1 max2 r2 of + Empty -> goLFused combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of + Empty -> goLFused combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' + | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> goLFused combine min l1 n2 goR1 _ _ !_ !_ !_ Tip = Empty goR1 combine maxV1 max1 Tip max2 n2 = goLookupR1 combine (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 @@ -972,15 +972,15 @@ intersectionWithKey = start goRFused _ !_ Tip !_ = Tip goRFused _ !_ !_ Tip = Tip goRFused combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> goRFused combine max n1 r2 - EQ | min1 < min2 -> case goL2 combine minV2 min1 l1 min2 l2 of - Empty -> goRFused combine max r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) - | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of - Empty -> goRFused combine max r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - GT -> goRFused combine max r1 n2 + LT -> goRFused combine max n1 r2 + EQ | min1 < min2 -> case goL2 combine minV2 min1 l1 min2 l2 of + Empty -> goRFused combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of + Empty -> goRFused combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) + | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + GT -> goRFused combine max r1 n2 goLookupL1 _ !_ _ !_ Tip = Empty goLookupL1 combine k v !xorCache (Bin max maxV l r) diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 781f9c79e..5a28e4e62 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -910,139 +910,135 @@ intersectionWith f = intersectionWithKey (const f) -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey combine = start +intersectionWithKey = start where - start (IntMap Empty) !_ = IntMap Empty - start !_ (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (goL2 minV2 min1 root1 min2 root2) - | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) - | otherwise = IntMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + start _ (IntMap Empty) !_ = IntMap Empty + start _ !_ (IntMap Empty) = IntMap Empty + start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (goL2 combine minV2 min1 root1 min2 root2) + | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) + | otherwise = IntMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. - goL1 _ !_ !_ !_ Tip = Empty - goL1 minV1 min1 Tip min2 n2 = goLookupL1 (boundKey min1) minV1 (xor (boundKey min1) min2) n2 - goL1 _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = Empty - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lMap $ goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused max1 (Bin min1 minV1 l1 r1) r2 - EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l' # goRFused max1 r1 r2) - GT -> goL1 minV1 min1 l1 min2 n2 - - goL2 _ !_ Tip !_ !_ = Empty - goL2 minV2 min1 n1 min2 Tip = goLookupL2 (boundKey min2) minV2 (xor (boundKey min2) min1) n1 - goL2 _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = Empty - goL2 minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goL2 minV2 min1 n1 min2 l2 - EQ | max1 > max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> binL (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l' # goRFused max1 r1 r2) - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> r2lMap $ goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused max1 r1 (Bin min2 minV2 l2 r2) - - goLFused min = loop - where - loop Tip !_ = Tip - loop !_ Tip = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # loop l1 l2 # goRFused max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT -> loop l1 n2 - - goR1 _ !_ !_ !_ Tip = Empty - goR1 maxV1 max1 Tip max2 n2 = goLookupR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 - goR1 _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = Empty - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rMap $ goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 (Bin max1 maxV1 l1 r1) l2 - EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # r') - GT -> goR1 maxV1 max1 r1 max2 n2 - - goR2 _ !_ Tip !_ !_ = Empty - goR2 maxV2 max1 n1 max2 Tip = goLookupR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 - goR2 _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = Empty - goR2 maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goR2 maxV2 max1 n1 max2 r2 - EQ | min1 < min2 -> binR (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> case goR2 maxV2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # r') - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> l2rMap $ goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 (Bin max2 maxV2 l2 r2) - - goRFused max = loop - where - loop Tip !_ = Tip - loop !_ Tip = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> case goL2 minV2 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused min1 l1 l2 # loop r1 r2 -- we choose max1 arbitrarily, as max1 == max2 - GT -> loop r1 n2 - - goLookupL1 !_ _ !_ Tip = Empty - goLookupL1 k v !xorCache (Bin max maxV l r) + goL1 _ _ !_ !_ !_ Tip = Empty + goL1 combine minV1 min1 Tip min2 n2 = goLookupL1 combine (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 _ _ min1 (Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = Empty + goL1 combine minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 + | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 + EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> case goL1 combine minV1 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused combine max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) + GT -> goL1 combine minV1 min1 l1 min2 n2 + + goL2 _ _ !_ Tip !_ !_ = Empty + goL2 combine minV2 min1 n1 min2 Tip = goLookupL2 combine (boundKey min2) minV2 (xor (boundKey min2) min1) n1 + goL2 _ _ _ (Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = Empty + goL2 combine minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goL2 combine minV2 min1 n1 min2 l2 + EQ | max1 > max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | max1 < max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> case goL2 combine minV2 min1 l1 min2 l2 of + Empty -> r2lMap (NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused combine max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 combine minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) + | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) + + goLFused _ !_ Tip !_ = Tip + goLFused _ !_ !_ Tip = Tip + goLFused combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of + LT -> goLFused combine min n1 l2 + EQ | max1 > max2 -> case goR2 combine maxV2 max1 r1 max2 r2 of + Empty -> goLFused combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of + Empty -> goLFused combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' + | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> goLFused combine min l1 n2 + + goR1 _ _ !_ !_ !_ Tip = Empty + goR1 combine maxV1 max1 Tip max2 n2 = goLookupR1 combine (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 _ _ max1 (Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = Empty + goR1 combine maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 + EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> case goR1 combine maxV1 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # r') + GT -> goR1 combine maxV1 max1 r1 max2 n2 + + goR2 _ _ !_ Tip !_ !_ = Empty + goR2 combine maxV2 max1 n1 max2 Tip = goLookupR2 combine (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 + goR2 _ _ _ (Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = Empty + goR2 combine maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goR2 combine maxV2 max1 n1 max2 r2 + EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) + | otherwise -> case goR2 combine maxV2 max1 r1 max2 r2 of + Empty -> l2rMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # r') + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 combine maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) + + goRFused _ !_ Tip !_ = Tip + goRFused _ !_ !_ Tip = Tip + goRFused combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of + LT -> goRFused combine max n1 r2 + EQ | min1 < min2 -> case goL2 combine minV2 min1 l1 min2 l2 of + Empty -> goRFused combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of + Empty -> goRFused combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) + | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + GT -> goRFused combine max r1 n2 + + goLookupL1 _ !_ _ !_ Tip = Empty + goLookupL1 combine k v !xorCache (Bin max maxV l r) | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL1 k v xorCache l - else goLookupR1 k v xorCacheMax r + then goLookupL1 combine k v xorCache l + else goLookupR1 combine k v xorCacheMax r | outOfMaxBound k max = Empty | otherwise = NonEmpty (Bound k) #! combine k v maxV # Tip where xorCacheMax = xor k max - goLookupR1 !_ _ !_ Tip = Empty - goLookupR1 k v !xorCache (Bin min minV l r) + goLookupR1 _ !_ _ !_ Tip = Empty + goLookupR1 combine k v !xorCache (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin - then goLookupR1 k v xorCache r - else goLookupL1 k v xorCacheMin l + then goLookupR1 combine k v xorCache r + else goLookupL1 combine k v xorCacheMin l | outOfMinBound k min = Empty | otherwise = NonEmpty (Bound k) #! combine k v minV # Tip where xorCacheMin = xor k min - goLookupL2 !_ _ !_ Tip = Empty - goLookupL2 k v !xorCache (Bin max maxV l r) + goLookupL2 _ !_ _ !_ Tip = Empty + goLookupL2 combine k v !xorCache (Bin max maxV l r) | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL2 k v xorCache l - else goLookupR2 k v xorCacheMax r + then goLookupL2 combine k v xorCache l + else goLookupR2 combine k v xorCacheMax r | outOfMaxBound k max = Empty | otherwise = NonEmpty (Bound k) #! combine k maxV v # Tip where xorCacheMax = xor k max - goLookupR2 !_ _ !_ Tip = Empty - goLookupR2 k v !xorCache (Bin min minV l r) + goLookupR2 _ !_ _ !_ Tip = Empty + goLookupR2 combine k v !xorCache (Bin min minV l r) | inMinBound k min = if xorCache < xorCacheMin - then goLookupR2 k v xorCache r - else goLookupL2 k v xorCacheMin l + then goLookupR2 combine k v xorCache r + else goLookupL2 combine k v xorCacheMin l | outOfMinBound k min = Empty | otherwise = NonEmpty (Bound k) #! combine k minV v # Tip where xorCacheMin = xor k min From fa69caa7099c83a8e31f03d5e2718e2722f9963c Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 9 Jan 2020 21:02:33 -0600 Subject: [PATCH 091/147] Move IntMap validity testing into Data.IntMap.Internal.Debug and return detailed descriptions of broken invariants on failure --- containers-tests/containers-tests.cabal | 2 - containers-tests/tests/IntMapValidity.hs | 37 ---------- containers-tests/tests/intmap-properties.hs | 44 ++++++------ containers/src/Data/IntMap/Internal.hs | 3 +- containers/src/Data/IntMap/Internal/Debug.hs | 72 ++++++++++++++++++++ 5 files changed, 97 insertions(+), 61 deletions(-) delete mode 100644 containers-tests/tests/IntMapValidity.hs diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index 3680fbf7c..ade9f74f7 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -320,7 +320,6 @@ test-suite intmap-lazy-properties hs-source-dirs: tests main-is: intmap-properties.hs type: exitcode-stdio-1.0 - other-modules: IntMapValidity build-depends: containers-tests build-depends: array >=0.4.0.0 @@ -344,7 +343,6 @@ test-suite intmap-strict-properties main-is: intmap-properties.hs type: exitcode-stdio-1.0 cpp-options: -DSTRICT - other-modules: IntMapValidity build-depends: containers-tests build-depends: array >=0.4.0.0 diff --git a/containers-tests/tests/IntMapValidity.hs b/containers-tests/tests/IntMapValidity.hs deleted file mode 100644 index 49b99c0fc..000000000 --- a/containers-tests/tests/IntMapValidity.hs +++ /dev/null @@ -1,37 +0,0 @@ -module IntMapValidity (valid) where - -import Data.IntMap.Internal -import Test.QuickCheck (Property, counterexample, property, (.&&.)) -import Utils.Containers.Internal.BitUtil (bitcount) - -{-------------------------------------------------------------------- - Assertions ---------------------------------------------------------------------} --- | Returns true iff the internal structure of the IntMap is valid. -valid :: IntMap a -> Bool -valid = start - where - start (IntMap Empty) = True - start (IntMap (NonEmpty min _ root)) = allKeys (> boundKey min) root && goL min root - - goL _ Tip = True - goL min (Bin max _ l r) = - allKeys (< boundKey max) l - && allKeys (< boundKey max) r - && allKeys (\k -> xor k min < xor k max) l - && allKeys (\k -> xor k min > xor k max) r - && goL min l - && goR max r - - goR _ Tip = True - goR max (Bin min _ l r) = - allKeys (> boundKey min) l - && allKeys (> boundKey min) r - && allKeys (\k -> xor k min < xor k max) l - && allKeys (\k -> xor k min > xor k max) r - && goL min l - && goR max r - - allKeys :: (Key -> Bool) -> Node t a -> Bool - allKeys _ Tip = True - allKeys p (Bin b _ l r) = p (boundKey b) && allKeys p l && allKeys p r diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index e24bc8cd1..ec43ab01d 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -8,8 +8,7 @@ import Data.IntMap.Lazy as Data.IntMap hiding (showTree) import Data.IntMap.Merge.Lazy #endif import Data.IntMap.Merge.Internal (runWhenMissingAll) -import Data.IntMap.Internal.Debug (showTree) -import IntMapValidity (valid) +import Data.IntMap.Internal.Debug (showTree, valid, validWith) import Control.Applicative (Applicative(..)) import Data.Monoid @@ -270,6 +269,9 @@ tests = [ testGroup "Test Case" [ ] +validProp :: IntMap a -> Property +validProp = validWith (flip counterexample) (.&&.) + ---------------------------------------------------------------- -- Unit tests ---------------------------------------------------------------- @@ -1289,20 +1291,20 @@ forValidUnitTree :: Testable b => (SMap -> b) -> Property forValidUnitTree f = forValid f prop_valid :: Property -prop_valid = forValidUnitTree $ \t -> valid t +prop_valid = forValidUnitTree $ \t -> validProp t ---------------------------------------------------------------- -- QuickCheck ---------------------------------------------------------------- -prop_emptyValid :: Bool -prop_emptyValid = valid empty +prop_emptyValid :: Property +prop_emptyValid = validProp empty prop_singleton :: Int -> Int -> Property prop_singleton k x = case singleton k x of s -> - valid s .&&. + validProp s .&&. s === insert k x empty prop_insertLookup :: Int -> UMap -> Bool @@ -1312,7 +1314,7 @@ prop_insertDelete :: Int -> UMap -> Property prop_insertDelete k t = lookup k t == Nothing ==> case delete k (insert k () t) of - t' -> valid t' .&&. t' === t + t' -> validProp t' .&&. t' === t prop_deleteNonMember :: Int -> UMap -> Property prop_deleteNonMember k t = (lookup k t == Nothing) ==> (delete k t == t) @@ -1323,7 +1325,7 @@ prop_unionModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_unionModel xs ys = case union (fromList xs) (fromList ys) of t -> - valid t .&&. + validProp t .&&. sort (keys t) === sort (nub (Prelude.map fst xs ++ Prelude.map fst ys)) prop_unionSingleton :: IMap -> Int -> Int -> Bool @@ -1344,7 +1346,7 @@ prop_differenceModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_differenceModel xs ys = case difference (fromListWith (+) xs) (fromListWith (+) ys) of t -> - valid t .&&. + validProp t .&&. sort (keys t) === sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys))) @@ -1353,7 +1355,7 @@ prop_intersectionModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_intersectionModel xs ys = case intersection (fromListWith (+) xs) (fromListWith (+) ys) of t -> - valid t .&&. + validProp t .&&. sort (keys t) === sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys))) @@ -1434,9 +1436,9 @@ prop_merge_valid -> Fun (Key, A, B) (Maybe C) -> IntMap A -> IntMap B - -> Bool + -> Property prop_merge_valid whenMissingA whenMissingB whenMatched xs ys - = valid m + = validProp m where m = merge @@ -1496,7 +1498,7 @@ prop_ascDescList xs = toAscList m == reverse (toDescList m) prop_fromList :: [Int] -> Property prop_fromList xs = case fromList (zip xs xs) of - t -> valid t .&&. + t -> validProp t .&&. t === fromAscList (zip sort_xs sort_xs) .&&. t === fromDistinctAscList (zip nub_sort_xs nub_sort_xs) .&&. t === List.foldr (uncurry insert) empty (zip xs xs) @@ -1506,7 +1508,7 @@ prop_fromList xs ---------------------------------------------------------------- prop_alter :: UMap -> Int -> Property -prop_alter t k = valid t' .&&. case lookup k t of +prop_alter t k = validProp t' .&&. case lookup k t of Just _ -> (size t - 1) == size t' && lookup k t' == Nothing Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing where @@ -1617,15 +1619,15 @@ prop_filter :: Fun Int Bool -> [(Int, Int)] -> Property prop_filter p ys = let xs = List.nubBy ((==) `on` fst) ys m = filter (apply p) (fromList xs) - in valid m .&&. + in validProp m .&&. m === fromList (List.filter (apply p . snd) xs) prop_partition :: Fun Int Bool -> [(Int, Int)] -> Property prop_partition p ys = let xs = List.nubBy ((==) `on` fst) ys m@(l, r) = partition (apply p) (fromList xs) - in valid l .&&. - valid r .&&. + in validProp l .&&. + validProp r .&&. m === let (a,b) = (List.partition (apply p . snd) xs) in (fromList a, fromList b) @@ -1633,8 +1635,8 @@ prop_partitionWithKey :: Fun (Int, Int) Bool -> [(Int, Int)] -> Property prop_partitionWithKey p ys = let xs = List.nubBy ((==) `on` fst) ys m@(l, r) = partitionWithKey (curry (apply p)) (fromList xs) - in valid l .&&. - valid r .&&. + in validProp l .&&. + validProp r .&&. m === let (a,b) = (List.partition (apply p) xs) in (fromList a, fromList b) @@ -1660,8 +1662,8 @@ prop_splitModel :: Int -> [(Int, Int)] -> Property prop_splitModel n ys = let xs = List.nubBy ((==) `on` fst) ys (l, r) = split n $ fromList xs - in valid l .&&. - valid r .&&. + in validProp l .&&. + validProp r .&&. toAscList l === sort [(k, v) | (k,v) <- xs, k < n] .&&. toAscList r === sort [(k, v) | (k,v) <- xs, k > n] diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 5bcb05c31..97cda3436 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -644,7 +644,8 @@ newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) -- 'Node' or in one of its descendants. -- -- These invariants imply a unique tree structure for a given set of keys. In fact, they are --- overspecified: the second invariant follows from the other two. +-- overspecified: the second invariant follows from the other two. To check these invariants, +-- use 'Daa.IntMap.Internal.Debug.valid'. data IntMap_ t a = NonEmpty {-# UNPACK #-} !(Bound t) a !(Node t a) | Empty deriving (Eq) -- | A node within a tree mapping integers to value @a@. Unlike an 'IntMap_', a 'Node' cannot diff --git a/containers/src/Data/IntMap/Internal/Debug.hs b/containers/src/Data/IntMap/Internal/Debug.hs index ece1118cc..b6ef79a5c 100644 --- a/containers/src/Data/IntMap/Internal/Debug.hs +++ b/containers/src/Data/IntMap/Internal/Debug.hs @@ -1,8 +1,18 @@ +{-# LANGUAGE CPP, BangPatterns #-} + module Data.IntMap.Internal.Debug ( showTree , showTreeWith + , valid + , validWith ) where +import Numeric (showIntAtBase) +import Data.Char (intToDigit) +#if !MIN_VERSION_base(4,8,0) +import Data.Word (Word) +#endif + import Prelude hiding (min, max) import Data.IntMap.Internal @@ -53,3 +63,65 @@ showTreeWith inorder unicode = unlines . start where vert = if unicode then "│" else "|" horiz = if unicode then "─" else "-" tip = if unicode then "╼" else "-*" + +-- | /O(n)/. Test if the internal map structure is valid. +-- +-- >>> valid (fromAscList [(3,"b"), (5,"a")]) +-- True +-- +-- >>> valid (fromAscList [(5,"a"), (3,"b")]) +-- False +-- +-- For information about the invariants that are checked, see 'IntMap_'. +valid :: IntMap a -> Bool +valid = validWith const (&&) + +-- | /O(n)/. Test if the internal map structure is valid, returning extra +-- information about why the map is invalid if it is so. To return this info, +-- @'validWith' assert (.&&.)@ passes a description of everything it asserts +-- to @assert@ along with the assertion's trutheness, then combines the +-- results of these assertions with @.&&.@. +validWith :: (Bool -> String -> prop) -> (prop -> prop -> prop) -> IntMap a -> prop +validWith assert (.&&.) = start + where + start (IntMap Empty) = assert True "Empty maps are always valid." + start (IntMap (NonEmpty _ _ Tip)) = assert True "Singleton maps are always valid." + start (IntMap (NonEmpty min _ (Bin max _ l r))) = + assertInMinBound (boundKey max) min + .&&. goL min max l + .&&. goR min max r + + goL !_ !_ Tip = assert True "Leaf nodes are always valid." + goL !min !max (Bin innerMax _ l r) = + assertInMinBound (boundKey innerMax) min + .&&. assertInMaxBound (boundKey innerMax) max + .&&. assert (xor (boundKey innerMax) min < xor (boundKey innerMax) max) + (trieError min max (boundKey innerMax) True) + .&&. goL min innerMax l + .&&. goR min innerMax r + + goR !_ !_ Tip = assert True "Leaf nodes are always valid." + goR !min !max (Bin innerMin _ l r) = + assertInMinBound (boundKey innerMin) min + .&&. assertInMaxBound (boundKey innerMin) max + .&&. assert (xor (boundKey innerMin) min > xor (boundKey innerMin) max) + (trieError min max (boundKey innerMin) False) + .&&. goL innerMin max l + .&&. goR innerMin max r + + assertInMinBound k min = assert (inMinBound k min) ("Ordering invariant broken: expected key " ++ show k ++ " > minimum bound " ++ show (boundKey min)) + assertInMaxBound k max = assert (inMaxBound k max) ("Ordering invariant broken: expected key " ++ show k ++ " < maximum bound " ++ show (boundKey max)) + + showBinary k = showIntAtBase 2 intToDigit (fromIntegral k :: Word) "" + + trieError min max k isLeft = "Trie invariant broken: between " ++ show (boundKey min) ++ " and " ++ show (boundKey max) + ++ ", " ++ show k ++ " was expected to share more bits with " ++ show (if isLeft then boundKey min else boundKey max) + ++ " as it is on the " ++ (if isLeft then "left" else "right") ++ " branch:" + ++ "\n min: " ++ replicate (binLength - length binMin) ' ' ++ binMin + ++ "\n k: " ++ replicate (binLength - length binK) ' ' ++ binK + ++ "\n max: " ++ replicate (binLength - length binMax) ' ' ++ binMax + where + binMin = showBinary (boundKey min) + binK = showBinary k + binMax = showBinary (boundKey max) + binLength = maximum [length binMin, length binK, length binMax] From 4ef68793f7292ecbab9453d326a62ff2c1727b3d Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 9 Jan 2020 21:21:01 -0600 Subject: [PATCH 092/147] Tweak validity checking: use neutral language so that explanations apply in both success and failure cases, pad binary representations with 0 instead of spaces, and clarify why the O(n) implementation works --- containers/src/Data/IntMap/Internal/Debug.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/containers/src/Data/IntMap/Internal/Debug.hs b/containers/src/Data/IntMap/Internal/Debug.hs index b6ef79a5c..0bbf088b1 100644 --- a/containers/src/Data/IntMap/Internal/Debug.hs +++ b/containers/src/Data/IntMap/Internal/Debug.hs @@ -91,6 +91,10 @@ validWith assert (.&&.) = start .&&. goL min max l .&&. goR min max r + -- When recursing, we already know that @innerMax < max@, so checking in + -- the subtree that keys are less than @innerMax@ also shows that they + -- are less than @max@. Similarly, we can replace @min@ with @innerMin@ in + -- 'goR'. goL !_ !_ Tip = assert True "Leaf nodes are always valid." goL !min !max (Bin innerMax _ l r) = assertInMinBound (boundKey innerMax) min @@ -109,17 +113,17 @@ validWith assert (.&&.) = start .&&. goL innerMin max l .&&. goR innerMin max r - assertInMinBound k min = assert (inMinBound k min) ("Ordering invariant broken: expected key " ++ show k ++ " > minimum bound " ++ show (boundKey min)) - assertInMaxBound k max = assert (inMaxBound k max) ("Ordering invariant broken: expected key " ++ show k ++ " < maximum bound " ++ show (boundKey max)) + assertInMinBound k min = assert (inMinBound k min) ("Ordering invariant: expected key " ++ show k ++ " > minimum bound " ++ show (boundKey min)) + assertInMaxBound k max = assert (inMaxBound k max) ("Ordering invariant: expected key " ++ show k ++ " < maximum bound " ++ show (boundKey max)) showBinary k = showIntAtBase 2 intToDigit (fromIntegral k :: Word) "" - trieError min max k isLeft = "Trie invariant broken: between " ++ show (boundKey min) ++ " and " ++ show (boundKey max) + trieError min max k isLeft = "Trie invariant: between " ++ show (boundKey min) ++ " and " ++ show (boundKey max) ++ ", " ++ show k ++ " was expected to share more bits with " ++ show (if isLeft then boundKey min else boundKey max) ++ " as it is on the " ++ (if isLeft then "left" else "right") ++ " branch:" - ++ "\n min: " ++ replicate (binLength - length binMin) ' ' ++ binMin - ++ "\n k: " ++ replicate (binLength - length binK) ' ' ++ binK - ++ "\n max: " ++ replicate (binLength - length binMax) ' ' ++ binMax + ++ "\n min: " ++ replicate (binLength - length binMin) '0' ++ binMin + ++ "\n k: " ++ replicate (binLength - length binK) '0' ++ binK + ++ "\n max: " ++ replicate (binLength - length binMax) '0' ++ binMax where binMin = showBinary (boundKey min) binK = showBinary k From 1feff6ce9eaff4c46c99709dc615ea20f0c916e2 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 9 Jan 2020 21:56:46 -0600 Subject: [PATCH 093/147] Delete outdated TODOs --- containers/src/Data/IntMap/Internal.hs | 4 ---- containers/src/Data/IntMap/Lazy.hs | 2 -- containers/src/Data/IntMap/Strict.hs | 2 -- 3 files changed, 8 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 97cda3436..b403686fe 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1202,8 +1202,6 @@ delete !k = start | k == boundKey min = let DR min' minV' root' = deleteMinL max maxV l r in IntMap (NonEmpty min' minV' root') | otherwise = IntMap (NonEmpty min minV (deleteL k (xor k min) root)) --- TODO: Does a strict pair work? My guess is not, as GHC was already --- unboxing the tuple, but it would be simpler to use one of those. -- | Without this specialized type (I was just using a tuple), GHC's -- CPR correctly unboxed the tuple, but it couldn't unbox the returned -- Key, leading to lots of inefficiency (3x slower than stock Data.IntMap) @@ -1860,8 +1858,6 @@ foldlWithKey' f !z = start goR acc Tip = acc goR acc (Bin min minV l r) = goR (goL (f' acc (boundKey min) minV) l) r --- TODO: make the conversion functions good producers - -- | /O(n)/. -- Return all elements of the map in the ascending order of their keys. -- Subject to list fusion. diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 268b80c9d..3e710d9c8 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1230,8 +1230,6 @@ fromListWith f = Data.List.foldl' (\t (k, a) -> insertWith f k a t) empty fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty --- TODO: Use the ordering - -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order. -- diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 5a28e4e62..f41eae8c0 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1264,8 +1264,6 @@ fromListWith f = Data.List.foldl' (\t (k, a) -> insertWith f k a t) empty fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty --- TODO: Use the ordering - -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order. -- From 13b46293e725bba014a1fe7db9b287d3db0c72fc Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Fri, 10 Jan 2020 13:45:09 -0600 Subject: [PATCH 094/147] Replace the boolean bound comparison tests in IntMap with a 3-variant enum result --- containers/src/Data/IntMap/Internal.hs | 360 +++++++++---------- containers/src/Data/IntMap/Internal/Debug.hs | 4 +- containers/src/Data/IntMap/Lazy.hs | 272 +++++++------- containers/src/Data/IntMap/Merge/Internal.hs | 88 +++-- containers/src/Data/IntMap/Strict.hs | 270 +++++++------- 5 files changed, 458 insertions(+), 536 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index b403686fe..60e8d1a64 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -310,12 +310,11 @@ module Data.IntMap.Internal ( -- ** Key Manipulation , Key , Bound(..) + , BoundOrdering(..) , xor , xorBounds - , inMinBound - , inMaxBound - , outOfMinBound - , outOfMaxBound + , compareMinBound + , compareMaxBound , ltMSB , compareMSB , boundsDisjoint @@ -583,17 +582,21 @@ newtype Bound_ = Bound { boundKey :: Key } deriving (Eq, Ord, Show) data Flipped t #endif -inMinBound :: Key -> Bound L -> Bool -inMinBound k (Bound min) = k > min +data BoundOrdering = InBound | OutOfBound | Matched deriving (Eq) -inMaxBound :: Key -> Bound R -> Bool -inMaxBound k (Bound max) = k < max +{-# INLINE compareMinBound #-} +compareMinBound :: Key -> Bound L -> BoundOrdering +compareMinBound k (Bound min) + | k > min = InBound + | k < min = OutOfBound + | otherwise = Matched -outOfMinBound :: Key -> Bound L -> Bool -outOfMinBound k (Bound min) = k < min - -outOfMaxBound :: Key -> Bound R -> Bool -outOfMaxBound k (Bound max) = k > max +{-# INLINE compareMaxBound #-} +compareMaxBound :: Key -> Bound R -> BoundOrdering +compareMaxBound k (Bound max) + | k < max = InBound + | k > max = OutOfBound + | otherwise = Matched -- | A map of integers to values @a@. newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) @@ -925,27 +928,25 @@ lookupChurch :: r -> (a -> r) -> Key -> IntMap a -> r lookupChurch nothing just !k = start where start (IntMap Empty) = nothing - start (IntMap (NonEmpty min minV node)) - | outOfMinBound k min = nothing - | k == boundKey min = just minV - | otherwise = goL (xor k min) node + start (IntMap (NonEmpty min minV node)) = case compareMinBound k min of + OutOfBound -> nothing + Matched -> just minV + InBound -> goL (xor k min) node goL !_ Tip = nothing - goL !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goL xorCache l - else goR xorCacheMax r - | outOfMaxBound k max = nothing - | otherwise = just maxV + goL !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goL xorCache l + | otherwise -> goR xorCacheMax r + OutOfBound -> nothing + Matched -> just maxV where xorCacheMax = xor k max goR !_ Tip = nothing - goR !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goR xorCache r - else goL xorCacheMin l - | outOfMinBound k min = nothing - | otherwise = just minV + goR !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goR xorCache r + | otherwise -> goL xorCacheMin l + OutOfBound -> nothing + Matched -> just minV where xorCacheMin = xor k min -- | /O(min(n,W))/. Is the key a member of the map? @@ -1137,20 +1138,20 @@ insertWithEval :: (a -> ()) -> (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWithEval eval = start where start _ !k v (IntMap Empty) = eval v `seq` IntMap (NonEmpty (Bound k) v Tip) - start combine !k v (IntMap (NonEmpty min minV root)) - | inMinBound k min = IntMap (NonEmpty min minV (goL combine k v (xor k min) min root)) - | outOfMinBound k min = eval v `seq` IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) - | otherwise = let v' = combine v minV - in eval v' `seq` IntMap (NonEmpty (Bound k) v' root) + start combine !k v (IntMap (NonEmpty min minV root)) = case compareMinBound k min of + InBound -> IntMap (NonEmpty min minV (goL combine k v (xor k min) min root)) + OutOfBound -> eval v `seq` IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) + Matched -> let v' = combine v minV + in eval v' `seq` IntMap (NonEmpty (Bound k) v' root) -- | Insert a key/value pair into a left node when the key is known to be larger -- than the minimum bound of the subtree. goL _ !k v !_ !_ Tip = eval v `seq` Bin (Bound k) v Tip Tip - goL combine !k v !xorCache !min (Bin max maxV l r) + goL combine !k v !xorCache !min (Bin max maxV l r) = case compareMaxBound k max of -- In the simple case, we recurse into whichever branch is applicable. - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goL combine k v xorCache min l) r - else Bin max maxV l (goR combine k v xorCacheMax max r) + InBound | xorCache < xorCacheMax -> Bin max maxV (goL combine k v xorCache min l) r + | otherwise -> Bin max maxV l (goR combine k v xorCacheMax max r) + -- If the key is the new maximum, then we have two cases to consider. If -- the split point between 'min' and 'k' is earlier than the split between -- 'min' and 'max', then we can just immediately create a new node. Otherwise, @@ -1161,23 +1162,21 @@ insertWithEval eval = start -- 'min' is the minimum, and 'k' is the maximum. If 'max' belongs on the -- left side, then the entire old subtree belongs on the left side. If -- 'max' belongs on the right side, then we have to push it down. - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then eval v `seq` Bin (Bound k) v (Bin max maxV l r) Tip - else eval v `seq` Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = let v' = combine v maxV - in eval v' `seq` Bin max v' l r + OutOfBound | xor (boundKey max) min < xorCacheMax -> eval v `seq` Bin (Bound k) v (Bin max maxV l r) Tip + | otherwise -> eval v `seq` Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + + Matched -> let v' = combine v maxV + in eval v' `seq` Bin max v' l r where xorCacheMax = xor k max goR _ !k v !_ !_ Tip = eval v `seq` Bin (Bound k) v Tip Tip - goR combine !k v !xorCache !max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goR combine k v xorCache max r) - else Bin min minV (goL combine k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then eval v `seq` Bin (Bound k) v Tip (Bin min minV l r) - else eval v `seq` Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = let v' = combine v minV - in eval v' `seq` Bin min v' l r + goR combine !k v !xorCache !max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goR combine k v xorCache max r) + | otherwise -> Bin min minV (goL combine k v xorCacheMin min l) r + OutOfBound | xor (boundKey min) max < xorCacheMin -> eval v `seq` Bin (Bound k) v Tip (Bin min minV l r) + | otherwise -> eval v `seq` Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + Matched -> let v' = combine v minV + in eval v' `seq` Bin min v' l r where xorCacheMin = xor k min -- Small functions that really ought to be defined in Data.IntMap.Lazy but have @@ -1197,10 +1196,11 @@ delete !k = start start m@(IntMap (NonEmpty min _ Tip)) | k == boundKey min = IntMap Empty | otherwise = m - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | outOfMinBound k min = m - | k == boundKey min = let DR min' minV' root' = deleteMinL max maxV l r in IntMap (NonEmpty min' minV' root') - | otherwise = IntMap (NonEmpty min minV (deleteL k (xor k min) root)) + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of + OutOfBound -> m + Matched -> let DR min' minV' root' = deleteMinL max maxV l r + in IntMap (NonEmpty min' minV' root') + InBound -> IntMap (NonEmpty min minV (deleteL k (xor k min) root)) -- | Without this specialized type (I was just using a tuple), GHC's -- CPR correctly unboxed the tuple, but it couldn't unbox the returned @@ -1301,47 +1301,39 @@ union = start GT -> Bin min1 minV1 l1 (goRFused max r1 n2) goInsertL1 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertL1 k v !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL1 k v xorCache min l) r - else Bin max maxV l (goInsertR1 k v xorCacheMax max r) - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v (Bin max maxV l r) Tip - else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max v l r + goInsertL1 k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goInsertL1 k v xorCache min l) r + | otherwise -> Bin max maxV l (goInsertR1 k v xorCacheMax max r) + OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip + | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + Matched -> Bin max v l r where xorCacheMax = xor k max goInsertR1 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR1 k v !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR1 k v xorCache max r) - else Bin min minV (goInsertL1 k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v Tip (Bin min minV l r) - else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min v l r + goInsertR1 k v !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goInsertR1 k v xorCache max r) + | otherwise -> Bin min minV (goInsertL1 k v xorCacheMin min l) r + OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) + | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + Matched -> Bin min v l r where xorCacheMin = xor k min goInsertL2 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertL2 k v !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL2 k v xorCache min l) r - else Bin max maxV l (goInsertR2 k v xorCacheMax max r) - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v (Bin max maxV l r) Tip - else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max maxV l r + goInsertL2 k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goInsertL2 k v xorCache min l) r + | otherwise -> Bin max maxV l (goInsertR2 k v xorCacheMax max r) + OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip + | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + Matched -> Bin max maxV l r where xorCacheMax = xor k max goInsertR2 k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR2 k v !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR2 k v xorCache max r) - else Bin min minV (goInsertL2 k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v Tip (Bin min minV l r) - else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min minV l r + goInsertR2 k v !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goInsertR2 k v xorCache max r) + | otherwise -> Bin min minV (goInsertL2 k v xorCacheMin min l) r + OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) + | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + Matched -> Bin min minV l r where xorCacheMin = xor k min unionDisjointL :: a -> Bound L -> Node L a -> Bound L -> Node L a -> Node L a @@ -1475,21 +1467,19 @@ difference = start GT -> binR (NonEmpty min1 minV1 l1) (goRFused max r1 n2) goLookupL k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupL k v !xorCache (Bin max _ l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL k v xorCache l - else goLookupR k v xorCacheMax r - | outOfMaxBound k max = NonEmpty (Bound k) v Tip - | otherwise = Empty + goLookupL k v !xorCache (Bin max _ l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL k v xorCache l + | otherwise -> goLookupR k v xorCacheMax r + OutOfBound -> NonEmpty (Bound k) v Tip + Matched -> Empty where xorCacheMax = xor k max goLookupR k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupR k v !xorCache (Bin min _ l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR k v xorCache r - else goLookupL k v xorCacheMin l - | outOfMinBound k min = NonEmpty (Bound k) v Tip - | otherwise = Empty + goLookupR k v !xorCache (Bin min _ l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR k v xorCache r + | otherwise -> goLookupL k v xorCacheMin l + OutOfBound -> NonEmpty (Bound k) v Tip + Matched -> Empty where xorCacheMin = xor k min dummyV = error "impossible" @@ -1600,39 +1590,35 @@ intersection = start GT -> goRFused max r1 n2 goLookupL1 !_ _ !_ Tip = Empty - goLookupL1 k v !xorCache (Bin max _ l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL1 k v xorCache l - else goLookupR1 k v xorCacheMax r - | outOfMaxBound k max = Empty - | otherwise = NonEmpty (Bound k) v Tip + goLookupL1 k v !xorCache (Bin max _ l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL1 k v xorCache l + | otherwise -> goLookupR1 k v xorCacheMax r + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) v Tip where xorCacheMax = xor k max goLookupR1 !_ _ !_ Tip = Empty - goLookupR1 k v !xorCache (Bin min _ l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR1 k v xorCache r - else goLookupL1 k v xorCacheMin l - | outOfMinBound k min = Empty - | otherwise = NonEmpty (Bound k) v Tip + goLookupR1 k v !xorCache (Bin min _ l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR1 k v xorCache r + | otherwise -> goLookupL1 k v xorCacheMin l + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) v Tip where xorCacheMin = xor k min goLookupL2 !_ !_ Tip = Empty - goLookupL2 k !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL2 k xorCache l - else goLookupR2 k xorCacheMax r - | outOfMaxBound k max = Empty - | otherwise = NonEmpty (Bound k) maxV Tip + goLookupL2 k !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL2 k xorCache l + | otherwise -> goLookupR2 k xorCacheMax r + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) maxV Tip where xorCacheMax = xor k max goLookupR2 !_ !_ Tip = Empty - goLookupR2 k !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR2 k xorCache r - else goLookupL2 k xorCacheMin l - | outOfMinBound k min = Empty - | otherwise = NonEmpty (Bound k) minV Tip + goLookupR2 k !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR2 k xorCache r + | otherwise -> goLookupL2 k xorCacheMin l + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) minV Tip where xorCacheMin = xor k min dummyV = error "impossible" @@ -1686,21 +1672,19 @@ disjoint = start GT -> goR max1 r1 max2 n2 goLookupL !_ !_ Tip = True - goLookupL k !xorCache (Bin max _ l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL k xorCache l - else goLookupR k xorCacheMax r - | outOfMaxBound k max = True - | otherwise = False + goLookupL k !xorCache (Bin max _ l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL k xorCache l + | otherwise -> goLookupR k xorCacheMax r + OutOfBound -> True + Matched -> False where xorCacheMax = xor k max goLookupR !_ !_ Tip = True - goLookupR k !xorCache (Bin min _ l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR k xorCache r - else goLookupL k xorCacheMin l - | outOfMinBound k min = True - | otherwise = False + goLookupR k !xorCache (Bin min _ l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR k xorCache r + | otherwise -> goLookupL k xorCacheMin l + OutOfBound -> True + Matched -> False where xorCacheMin = xor k min dummyV = error "impossible" @@ -2141,17 +2125,17 @@ splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a) splitLookup !k = start where start (IntMap Empty) = (IntMap Empty, Nothing, IntMap Empty) - start m@(IntMap (NonEmpty min minV root)) - | inMinBound k min = case root of + start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of + InBound -> case root of Tip -> (m, Nothing, IntMap Empty) - Bin max maxV l r | inMaxBound k max -> let (DR glb glbV lt, eq, DR lub lubV gt) = go (xor k min) min minV (xor k max) max maxV l r - in (IntMap (r2lMap (NonEmpty glb glbV lt)), eq, IntMap (NonEmpty lub lubV gt)) - | outOfMaxBound k max -> (m, Nothing, IntMap Empty) - | otherwise -> let DR max' maxV' root' = deleteMaxR min minV l r - in (IntMap (r2lMap (NonEmpty max' maxV' root')), Just maxV, IntMap Empty) - - | outOfMinBound k min = (IntMap Empty, Nothing, m) - | otherwise = case root of + Bin max maxV l r -> case compareMaxBound k max of + InBound -> let (DR glb glbV lt, eq, DR lub lubV gt) = go (xor k min) min minV (xor k max) max maxV l r + in (IntMap (r2lMap (NonEmpty glb glbV lt)), eq, IntMap (NonEmpty lub lubV gt)) + OutOfBound -> (m, Nothing, IntMap Empty) + Matched -> let DR max' maxV' root' = deleteMaxR min minV l r + in (IntMap (r2lMap (NonEmpty max' maxV' root')), Just maxV, IntMap Empty) + OutOfBound -> (IntMap Empty, Nothing, m) + Matched -> case root of Tip -> (IntMap Empty, Just minV, IntMap Empty) Bin max maxV l r -> let DR min' minV' root' = deleteMinL max maxV l r in (IntMap Empty, Just minV, IntMap (NonEmpty min' minV' root')) @@ -2159,18 +2143,18 @@ splitLookup !k = start go xorCacheMin min minV xorCacheMax max maxV l r | xorCacheMin < xorCacheMax = case l of Tip -> (DR (minToMax min) minV Tip, Nothing, r2lDR (DR max maxV r)) - Bin maxI maxVI lI rI - | inMaxBound k maxI -> let (lt, eq, DR minI minVI gt) = go xorCacheMin min minV (xor k maxI) maxI maxVI lI rI - in (lt, eq, DR minI minVI (Bin max maxV gt r)) - | outOfMaxBound k maxI -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) - | otherwise -> (deleteMaxR min minV lI rI, Just maxVI, r2lDR (DR max maxV r)) + Bin maxI maxVI lI rI -> case compareMaxBound k maxI of + InBound -> let (lt, eq, DR minI minVI gt) = go xorCacheMin min minV (xor k maxI) maxI maxVI lI rI + in (lt, eq, DR minI minVI (Bin max maxV gt r)) + OutOfBound -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) + Matched -> (deleteMaxR min minV lI rI, Just maxVI, r2lDR (DR max maxV r)) | otherwise = case r of Tip -> (l2rDR (DR min minV l), Nothing, DR (maxToMin max) maxV Tip) - Bin minI minVI lI rI - | inMinBound k minI -> let (DR maxI maxVI lt, eq, gt) = go (xor k minI) minI minVI xorCacheMax max maxV lI rI + Bin minI minVI lI rI -> case compareMinBound k minI of + InBound -> let (DR maxI maxVI lt, eq, gt) = go (xor k minI) minI minVI xorCacheMax max maxV lI rI in (DR maxI maxVI (Bin min minV l lt), eq, gt) - | outOfMinBound k minI -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) - | otherwise -> (l2rDR (DR min minV l), Just minVI, deleteMinL max maxV lI rI) + OutOfBound -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) + Matched -> (l2rDR (DR min minV l), Just minVI, deleteMinL max maxV lI rI) -- | /O(1)/. Decompose a map into pieces based on the structure of the underlying -- tree. This function is useful for consuming a map in parallel. @@ -2284,21 +2268,19 @@ isSubmapOfBy p = start | otherwise = p minV1 minV2 && goLFused min1 l1 l2 && goRFused max r1 r2 goLookupL _ _ !_ Tip = False - goLookupL k v !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL k v xorCache l - else goLookupR k v xorCacheMax r - | outOfMaxBound k max = False - | otherwise = p v maxV + goLookupL k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL k v xorCache l + | otherwise -> goLookupR k v xorCacheMax r + OutOfBound -> False + Matched -> p v maxV where xorCacheMax = xor k max goLookupR _ _ !_ Tip = False - goLookupR k v !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR k v xorCache r - else goLookupL k v xorCacheMin l - | outOfMinBound k min = False - | otherwise = p v minV + goLookupR k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR k v xorCache r + | otherwise -> goLookupL k v xorCacheMin l + OutOfBound -> False + Matched -> p v minV where xorCacheMin = xor k min -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). @@ -2402,21 +2384,19 @@ submapCmp p = start | otherwise = p minV1 minV2 && goLFusedBool min1 l1 l2 && goRFusedBool max r1 r2 goLookupL _ _ !_ Tip = False - goLookupL k v !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL k v xorCache l - else goLookupR k v xorCacheMax r - | outOfMaxBound k max = False - | otherwise = p v maxV + goLookupL k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL k v xorCache l + | otherwise -> goLookupR k v xorCacheMax r + OutOfBound -> False + Matched -> p v maxV where xorCacheMax = xor k max goLookupR _ _ !_ Tip = False - goLookupR k v !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR k v xorCache r - else goLookupL k v xorCacheMin l - | outOfMinBound k min = False - | otherwise = p v minV + goLookupR k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR k v xorCache r + | otherwise -> goLookupL k v xorCacheMin l + OutOfBound -> False + Matched -> p v minV where xorCacheMin = xor k min fromBool True = LT @@ -2642,22 +2622,20 @@ nodeToMapR (Bin min minV innerL innerR) = -- the minimum bound of that node. deleteL :: Key -> Word -> Node L a -> Node L a deleteL !_ !_ Tip = Tip -deleteL !k !xorCache n@(Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (deleteL k xorCache l) r - else Bin max maxV l (deleteR k xorCacheMax r) - | outOfMaxBound k max = n - | otherwise = extractBinL l r +deleteL !k !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (deleteL k xorCache l) r + | otherwise -> Bin max maxV l (deleteR k xorCacheMax r) + OutOfBound -> n + Matched -> extractBinL l r where xorCacheMax = xor k max -- | Delete a key from a right node. Takes the xor of the deleted key and -- the maximum bound of that node. deleteR :: Key -> Word -> Node R a -> Node R a deleteR !_ !_ Tip = Tip -deleteR !k !xorCache n@(Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (deleteR k xorCache r) - else Bin min minV (deleteL k xorCacheMin l) r - | outOfMinBound k min = n - | otherwise = extractBinR l r +deleteR !k !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (deleteR k xorCache r) + | otherwise -> Bin min minV (deleteL k xorCacheMin l) r + OutOfBound -> n + Matched -> extractBinR l r where xorCacheMin = xor k min diff --git a/containers/src/Data/IntMap/Internal/Debug.hs b/containers/src/Data/IntMap/Internal/Debug.hs index 0bbf088b1..c908e4767 100644 --- a/containers/src/Data/IntMap/Internal/Debug.hs +++ b/containers/src/Data/IntMap/Internal/Debug.hs @@ -113,8 +113,8 @@ validWith assert (.&&.) = start .&&. goL innerMin max l .&&. goR innerMin max r - assertInMinBound k min = assert (inMinBound k min) ("Ordering invariant: expected key " ++ show k ++ " > minimum bound " ++ show (boundKey min)) - assertInMaxBound k max = assert (inMaxBound k max) ("Ordering invariant: expected key " ++ show k ++ " < maximum bound " ++ show (boundKey max)) + assertInMinBound k min = assert (compareMinBound k min == InBound) ("Ordering invariant: expected key " ++ show k ++ " > minimum bound " ++ show (boundKey min)) + assertInMaxBound k max = assert (compareMaxBound k max == InBound) ("Ordering invariant: expected key " ++ show k ++ " < maximum bound " ++ show (boundKey max)) showBinary k = showIntAtBase 2 intToDigit (fromIntegral k :: Word) "" diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 3e710d9c8..4e9c60b53 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -293,36 +293,32 @@ insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, insertLookupWithKey combine !k !v = toPair . start where start (IntMap Empty) = Nothing :*: IntMap (NonEmpty (Bound k) v Tip) - start (IntMap (NonEmpty min minV root)) - | inMinBound k min = let mv :*: root' = goL (xor k min) min root - in mv :*: IntMap (NonEmpty min minV root') - | outOfMinBound k min = Nothing :*: IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) - | otherwise = Just minV :*: IntMap (NonEmpty (Bound k) (combine k v minV) root) + start (IntMap (NonEmpty min minV root)) = case compareMinBound k min of + InBound -> let mv :*: root' = goL (xor k min) min root + in mv :*: IntMap (NonEmpty min minV root') + OutOfBound -> Nothing :*: IntMap (NonEmpty (Bound k) v (insertMinL (xor k min) min minV root)) + Matched -> Just minV :*: IntMap (NonEmpty (Bound k) (combine k v minV) root) goL !_ _ Tip = Nothing :*: Bin (Bound k) v Tip Tip - goL !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then let mv :*: l' = goL xorCache min l - in mv :*: Bin max maxV l' r - else let mv :*: r' = goR xorCacheMax max r - in mv :*: Bin max maxV l r' - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Nothing :*: Bin (Bound k) v (Bin max maxV l r) Tip - else Nothing :*: Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Just maxV :*: Bin max (combine k v maxV) l r + goL !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> let mv :*: l' = goL xorCache min l + in mv :*: Bin max maxV l' r + | otherwise -> let mv :*: r' = goR xorCacheMax max r + in mv :*: Bin max maxV l r' + OutOfBound | xor (boundKey max) min < xorCacheMax -> Nothing :*: Bin (Bound k) v (Bin max maxV l r) Tip + | otherwise -> Nothing :*: Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + Matched -> Just maxV :*: Bin max (combine k v maxV) l r where xorCacheMax = xor k max goR !_ _ Tip = Nothing :*: Bin (Bound k) v Tip Tip - goR !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then let mv :*: r' = goR xorCache max r - in mv :*: Bin min minV l r' - else let mv :*: l' = goL xorCacheMin min l - in mv :*: Bin min minV l' r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Nothing :*: Bin (Bound k) v Tip (Bin min minV l r) - else Nothing :*: Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Just minV :*: Bin min (combine k v minV) l r + goR !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> let mv :*: r' = goR xorCache max r + in mv :*: Bin min minV l r' + | otherwise -> let mv :*: l' = goL xorCacheMin min l + in mv :*: Bin min minV l' r + OutOfBound | xor (boundKey min) max < xorCacheMin -> Nothing :*: Bin (Bound k) v Tip (Bin min minV l r) + | otherwise -> Nothing :*: Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + Matched -> Just minV :*: Bin min (combine k v minV) l r where xorCacheMin = xor k min -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not @@ -335,27 +331,25 @@ adjust :: (a -> a) -> Key -> IntMap a -> IntMap a adjust f !k = start where start (IntMap Empty) = IntMap Empty - start m@(IntMap (NonEmpty min minV node)) - | inMinBound k min = IntMap (NonEmpty min minV (goL (xor k min) min node)) - | outOfMinBound k min = m - | otherwise = IntMap (NonEmpty min (f minV) node) + start m@(IntMap (NonEmpty min minV node)) = case compareMinBound k min of + InBound -> IntMap (NonEmpty min minV (goL (xor k min) min node)) + OutOfBound -> m + Matched -> IntMap (NonEmpty min (f minV) node) goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goL xorCache min l) r - else Bin max maxV l (goR xorCacheMax max r) - | outOfMaxBound k max = n - | otherwise = Bin max (f maxV) l r + goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache min l) r + | otherwise -> Bin max maxV l (goR xorCacheMax max r) + OutOfBound -> n + Matched -> Bin max (f maxV) l r where xorCacheMax = xor k max goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goR xorCache max r) - else Bin min minV (goL xorCacheMin min l) r - | outOfMinBound k min = n - | otherwise = Bin min (f minV) l r + goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache max r) + | otherwise -> Bin min minV (goL xorCacheMin min l) r + OutOfBound -> n + Matched -> Bin min (f minV) l r where xorCacheMin = xor k min -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not @@ -385,32 +379,30 @@ update f !k = start Nothing -> IntMap Empty Just minV' -> IntMap (NonEmpty min minV' Tip) | otherwise = m - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | outOfMinBound k min = m - | k == boundKey min = case f minV of + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of + OutOfBound -> m + Matched -> case f minV of Nothing -> let DR min' minV' root' = deleteMinL max maxV l r - in IntMap (NonEmpty min' minV' root') + in IntMap (NonEmpty min' minV' root') Just minV' -> IntMap (NonEmpty min minV' root) - | otherwise = IntMap (NonEmpty min minV (goL (xor k min) min root)) + InBound -> IntMap (NonEmpty min minV (goL (xor k min) min root)) goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goL xorCache min l) r - else Bin max maxV l (goR xorCacheMax max r) - | outOfMaxBound k max = n - | otherwise = case f maxV of + goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache min l) r + | otherwise -> Bin max maxV l (goR xorCacheMax max r) + OutOfBound -> n + Matched -> case f maxV of Nothing -> extractBinL l r Just maxV' -> Bin max maxV' l r where xorCacheMax = xor k max goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goR xorCache max r) - else Bin min minV (goL xorCacheMin min l) r - | outOfMinBound k min = n - | otherwise = case f minV of + goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache max r) + | otherwise -> Bin min minV (goL xorCacheMin min l) r + OutOfBound -> n + Matched -> case f minV of Nothing -> extractBinR l r Just minV' -> Bin min minV' l r where xorCacheMin = xor k min @@ -444,37 +436,35 @@ updateLookupWithKey f !k = start Nothing -> (Just minV, IntMap Empty) Just minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) | otherwise = (Nothing, m) - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | outOfMinBound k min = (Nothing, m) - | k == boundKey min = case f (boundKey min) minV of + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of + OutOfBound -> (Nothing, m) + Matched -> case f (boundKey min) minV of Nothing -> let DR min' minV' root' = deleteMinL max maxV l r - in (Just minV, IntMap (NonEmpty min' minV' root')) + in (Just minV, IntMap (NonEmpty min' minV' root')) Just minV' -> (Just minV, IntMap (NonEmpty min minV' root)) - | otherwise = let (mv, root') = goL (xor k min) min root - in (mv, IntMap (NonEmpty min minV root')) + InBound -> let (mv, root') = goL (xor k min) min root + in (mv, IntMap (NonEmpty min minV root')) goL !_ _ Tip = (Nothing, Tip) - goL !xorCache min n@(Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then let (mv, l') = goL xorCache min l - in (mv, Bin max maxV l' r) - else let (mv, r') = goR xorCacheMax max r - in (mv, Bin max maxV l r') - | outOfMaxBound k max = (Nothing, n) - | otherwise = case f (boundKey max) maxV of + goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> let (mv, l') = goL xorCache min l + in (mv, Bin max maxV l' r) + | otherwise -> let (mv, r') = goR xorCacheMax max r + in (mv, Bin max maxV l r') + OutOfBound -> (Nothing, n) + Matched -> case f (boundKey max) maxV of Nothing -> (Just maxV, extractBinL l r) Just maxV' -> (Just maxV, Bin max maxV' l r) where xorCacheMax = xor k max goR !_ _ Tip = (Nothing, Tip) - goR !xorCache max n@(Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then let (mv, r') = goR xorCache max r - in (mv, Bin min minV l r') - else let (mv, l') = goL xorCacheMin min l - in (mv, Bin min minV l' r) - | outOfMinBound k min = (Nothing, n) - | otherwise = case f (boundKey min) minV of + goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> let (mv, r') = goR xorCache max r + in (mv, Bin min minV l r') + | otherwise -> let (mv, l') = goL xorCacheMin min l + in (mv, Bin min minV l' r) + OutOfBound -> (Nothing, n) + Matched -> case f (boundKey min) minV of Nothing -> (Just minV, extractBinR l r) Just minV' -> (Just minV, Bin min minV' l r) where xorCacheMin = xor k min @@ -626,47 +616,39 @@ unionWithKey = start GT -> Bin min1 minV1 l1 (goRFused combine max r1 n2) goInsertL1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertL1 combine k v !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL1 combine k v xorCache min l) r - else Bin max maxV l (goInsertR1 combine k v xorCacheMax max r) - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v (Bin max maxV l r) Tip - else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max (combine k v maxV) l r + goInsertL1 combine k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goInsertL1 combine k v xorCache min l) r + | otherwise -> Bin max maxV l (goInsertR1 combine k v xorCacheMax max r) + OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip + | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + Matched -> Bin max (combine k v maxV) l r where xorCacheMax = xor k max goInsertR1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR1 combine k v !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR1 combine k v xorCache max r) - else Bin min minV (goInsertL1 combine k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v Tip (Bin min minV l r) - else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min (combine k v minV) l r + goInsertR1 combine k v !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goInsertR1 combine k v xorCache max r) + | otherwise -> Bin min minV (goInsertL1 combine k v xorCacheMin min l) r + OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) + | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + Matched -> Bin min (combine k v minV) l r where xorCacheMin = xor k min goInsertL2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertL2 combine k v !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL2 combine k v xorCache min l) r - else Bin max maxV l (goInsertR2 combine k v xorCacheMax max r) - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v (Bin max maxV l r) Tip - else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max (combine k maxV v) l r + goInsertL2 combine k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goInsertL2 combine k v xorCache min l) r + | otherwise -> Bin max maxV l (goInsertR2 combine k v xorCacheMax max r) + OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip + | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + Matched -> Bin max (combine k maxV v) l r where xorCacheMax = xor k max goInsertR2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR2 combine k v !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR2 combine k v xorCache max r) - else Bin min minV (goInsertL2 combine k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v Tip (Bin min minV l r) - else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min (combine k minV v) l r + goInsertR2 combine k v !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goInsertR2 combine k v xorCache max r) + | otherwise -> Bin min minV (goInsertL2 combine k v xorCacheMin min l) r + OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) + | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + Matched -> Bin min (combine k minV v) l r where xorCacheMin = xor k min -- | The union of a list of maps, with a combining operation. @@ -851,23 +833,21 @@ differenceWithKey combine = start GT -> Bin min1 minV1 l1 (loop r1 n2) goLookupL k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupL k v !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL k v xorCache l - else goLookupR k v xorCacheMax r - | outOfMaxBound k max = NonEmpty (Bound k) v Tip - | otherwise = case combine k v maxV of + goLookupL k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL k v xorCache l + | otherwise -> goLookupR k v xorCacheMax r + OutOfBound -> NonEmpty (Bound k) v Tip + Matched -> case combine k v maxV of Nothing -> Empty Just v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max goLookupR k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupR k v !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR k v xorCache r - else goLookupL k v xorCacheMin l - | outOfMinBound k min = NonEmpty (Bound k) v Tip - | otherwise = case combine k v minV of + goLookupR k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR k v xorCache r + | otherwise -> goLookupL k v xorCacheMin l + OutOfBound -> NonEmpty (Bound k) v Tip + Matched -> case combine k v minV of Nothing -> Empty Just v' -> NonEmpty (Bound k) v' Tip where xorCacheMin = xor k min @@ -983,39 +963,35 @@ intersectionWithKey = start GT -> goRFused combine max r1 n2 goLookupL1 _ !_ _ !_ Tip = Empty - goLookupL1 combine k v !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL1 combine k v xorCache l - else goLookupR1 combine k v xorCacheMax r - | outOfMaxBound k max = Empty - | otherwise = NonEmpty (Bound k) (combine k v maxV) Tip + goLookupL1 combine k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL1 combine k v xorCache l + | otherwise -> goLookupR1 combine k v xorCacheMax r + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) (combine k v maxV) Tip where xorCacheMax = xor k max goLookupR1 _ !_ _ !_ Tip = Empty - goLookupR1 combine k v !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR1 combine k v xorCache r - else goLookupL1 combine k v xorCacheMin l - | outOfMinBound k min = Empty - | otherwise = NonEmpty (Bound k) (combine k v minV) Tip + goLookupR1 combine k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR1 combine k v xorCache r + | otherwise -> goLookupL1 combine k v xorCacheMin l + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) (combine k v minV) Tip where xorCacheMin = xor k min goLookupL2 _ !_ _ !_ Tip = Empty - goLookupL2 combine k v !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL2 combine k v xorCache l - else goLookupR2 combine k v xorCacheMax r - | outOfMaxBound k max = Empty - | otherwise = NonEmpty (Bound k) (combine k maxV v) Tip + goLookupL2 combine k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL2 combine k v xorCache l + | otherwise -> goLookupR2 combine k v xorCacheMax r + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) (combine k maxV v) Tip where xorCacheMax = xor k max goLookupR2 _ !_ _ !_ Tip = Empty - goLookupR2 combine k v !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR2 combine k v xorCache r - else goLookupL2 combine k v xorCacheMin l - | outOfMinBound k min = Empty - | otherwise = NonEmpty (Bound k) (combine k minV v) Tip + goLookupR2 combine k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR2 combine k v xorCache r + | otherwise -> goLookupL2 combine k v xorCacheMin l + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) (combine k minV v) Tip where xorCacheMin = xor k min -- | /O(n+m)/. An unsafe general combining function. diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index e9420c9f2..b7bf06f0d 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -627,16 +627,15 @@ merge miss1 miss2 match = start where goInsertL1 !k v !_ _ Tip = case missSingle miss1 k v of Nothing -> Tip Just v' -> Bin (Bound k) v' Tip Tip - goInsertL1 !k v !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then binL2 max maxV (goInsertL1 k v xorCache min l) (missRight miss2 r) - else binL2 max maxV (missLeft miss2 l) (goInsertR1 k v xorCacheMax max r) - | outOfMaxBound k max = case missSingle miss1 k v of + goInsertL1 !k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> binL2 max maxV (goInsertL1 k v xorCache min l) (missRight miss2 r) + | otherwise -> binL2 max maxV (missLeft miss2 l) (goInsertR1 k v xorCacheMax max r) + OutOfBound -> case missSingle miss1 k v of Nothing -> missLeft miss2 (Bin max maxV l r) Just v' -> if xor (boundKey max) min < xorCacheMax then Bin (Bound k) v' (missLeft miss2 (Bin max maxV l r)) Tip else Bin (Bound k) v' (missLeft miss2 l) (missRight miss2 (insertMaxR xorCacheMax max maxV r)) - | otherwise = case matchSingle match k v maxV of + Matched -> case matchSingle match k v maxV of Nothing -> extractBinL (missLeft miss2 l) (missRight miss2 r) -- TODO: do extractBin first? Just maxV' -> Bin max maxV' (missLeft miss2 l) (missRight miss2 r) where xorCacheMax = xor k max @@ -644,16 +643,15 @@ merge miss1 miss2 match = start where goInsertL2 !k v !_ _ Tip = case missSingle miss2 k v of Nothing -> Tip Just v' -> Bin (Bound k) v' Tip Tip - goInsertL2 !k v !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then binL1 max maxV (goInsertL2 k v xorCache min l) (missRight miss1 r) - else binL1 max maxV (missLeft miss1 l) (goInsertR2 k v xorCacheMax max r) - | outOfMaxBound k max = case missSingle miss2 k v of + goInsertL2 !k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> binL1 max maxV (goInsertL2 k v xorCache min l) (missRight miss1 r) + | otherwise -> binL1 max maxV (missLeft miss1 l) (goInsertR2 k v xorCacheMax max r) + OutOfBound -> case missSingle miss2 k v of Nothing -> missLeft miss1 (Bin max maxV l r) Just v' -> if xor (boundKey max) min < xorCacheMax then Bin (Bound k) v' (missLeft miss1 (Bin max maxV l r)) Tip else Bin (Bound k) v' (missLeft miss1 l) (missRight miss1 (insertMaxR xorCacheMax max maxV r)) - | otherwise = case matchSingle match k maxV v of + Matched -> case matchSingle match k maxV v of Nothing -> extractBinL (missLeft miss1 l) (missRight miss1 r) -- TODO: do extractBin first? Just maxV' -> Bin max maxV' (missLeft miss1 l) (missRight miss1 r) where xorCacheMax = xor k max @@ -661,16 +659,15 @@ merge miss1 miss2 match = start where goInsertR1 k v !_ _ Tip = case missSingle miss1 k v of Nothing -> Tip Just v' -> Bin (Bound k) v' Tip Tip - goInsertR1 k v !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then binR2 min minV (missLeft miss2 l) (goInsertR1 k v xorCache max r) - else binR2 min minV (goInsertL1 k v xorCacheMin min l) (missRight miss2 r) - | outOfMinBound k min = case missSingle miss1 k v of + goInsertR1 k v !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> binR2 min minV (missLeft miss2 l) (goInsertR1 k v xorCache max r) + | otherwise -> binR2 min minV (goInsertL1 k v xorCacheMin min l) (missRight miss2 r) + OutOfBound -> case missSingle miss1 k v of Nothing -> missRight miss2 (Bin min minV l r) Just v' -> if xor (boundKey min) max < xorCacheMin then Bin (Bound k) v' Tip (missRight miss2 (Bin min minV l r)) else Bin (Bound k) v' (missLeft miss2 (insertMinL xorCacheMin min minV l)) (missRight miss2 r) - | otherwise = case matchSingle match k v minV of + Matched -> case matchSingle match k v minV of Nothing -> extractBinR (missLeft miss2 l) (missRight miss2 r) -- TODO: do extractBin first? Just minV' -> Bin min minV' (missLeft miss2 l) (missRight miss2 r) where xorCacheMin = xor k min @@ -678,16 +675,15 @@ merge miss1 miss2 match = start where goInsertR2 !k v !_ _ Tip = case missSingle miss2 k v of Nothing -> Tip Just v' -> Bin (Bound k) v' Tip Tip - goInsertR2 !k v !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then binR1 min minV (missLeft miss1 l) (goInsertR2 k v xorCache max r) - else binR1 min minV (goInsertL2 k v xorCacheMin min l) (missRight miss1 r) - | outOfMinBound k min = case missSingle miss2 k v of + goInsertR2 !k v !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> binR1 min minV (missLeft miss1 l) (goInsertR2 k v xorCache max r) + | otherwise -> binR1 min minV (goInsertL2 k v xorCacheMin min l) (missRight miss1 r) + OutOfBound -> case missSingle miss2 k v of Nothing -> missRight miss1 (Bin min minV l r) Just v' -> if xor (boundKey min) max < xorCacheMin then Bin (Bound k) v' Tip (missRight miss1 (Bin min minV l r)) else Bin (Bound k) v' (missLeft miss1 (insertMinL xorCacheMin min minV l)) (missRight miss1 r) - | otherwise = case matchSingle match k minV v of + Matched -> case matchSingle match k minV v of Nothing -> extractBinR (missLeft miss1 l) (missRight miss1 r) -- TODO: do extractBin first? Just minV' -> Bin min minV' (missLeft miss1 l) (missRight miss1 r) where xorCacheMin = xor k min @@ -877,39 +873,35 @@ mergeA miss1 miss2 match = start where GT -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goRFused max r1 n2 goInsertL1 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss1 k v - goInsertL1 !k v !xorCache min n@(Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then binL <$> goInsertL1 k v xorCache min l <*> missingAllR miss2 (NonEmpty max maxV r) - else (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss2 l <*> goInsertR1 k v xorCacheMax max r <*> missingSingle miss2 (boundKey max) maxV - | outOfMaxBound k max = (\n' v' -> r2lMap (maybeInsertMax (Bound k) v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss2 n <*> missingSingle miss1 k v - | otherwise = (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss2 l <*> missingRight miss2 r <*> matchedSingle match k v maxV + goInsertL1 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> binL <$> goInsertL1 k v xorCache min l <*> missingAllR miss2 (NonEmpty max maxV r) + | otherwise -> (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss2 l <*> goInsertR1 k v xorCacheMax max r <*> missingSingle miss2 (boundKey max) maxV + OutOfBound -> (\n' v' -> r2lMap (maybeInsertMax (Bound k) v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss2 n <*> missingSingle miss1 k v + Matched -> (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss2 l <*> missingRight miss2 r <*> matchedSingle match k v maxV where xorCacheMax = xor k max goInsertL2 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss2 k v - goInsertL2 !k v !xorCache min n@(Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then binL <$> goInsertL2 k v xorCache min l <*> missingAllR miss1 (NonEmpty max maxV r) - else (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss1 l <*> goInsertR2 k v xorCacheMax max r <*> missingSingle miss1 (boundKey max) maxV - | outOfMaxBound k max = (\n' v' -> r2lMap (maybeInsertMax (Bound k) v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss1 n <*> missingSingle miss2 k v - | otherwise = (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss1 l <*> missingRight miss1 r <*> matchedSingle match k maxV v + goInsertL2 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> binL <$> goInsertL2 k v xorCache min l <*> missingAllR miss1 (NonEmpty max maxV r) + | otherwise -> (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss1 l <*> goInsertR2 k v xorCacheMax max r <*> missingSingle miss1 (boundKey max) maxV + OutOfBound -> (\n' v' -> r2lMap (maybeInsertMax (Bound k) v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss1 n <*> missingSingle miss2 k v + Matched -> (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss1 l <*> missingRight miss1 r <*> matchedSingle match k maxV v where xorCacheMax = xor k max goInsertR1 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss1 k v - goInsertR1 !k v !xorCache max n@(Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then binR <$> missingAllL miss2 (NonEmpty min minV l) <*> goInsertR1 k v xorCache max r - else (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss2 (boundKey min) minV <*> goInsertL1 k v xorCacheMin min l <*> missingRight miss2 r - | outOfMinBound k min = (\v' n' -> l2rMap (maybeInsertMin (Bound k) v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss1 k v <*> missingRight miss2 n - | otherwise = (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match k v minV <*> missingLeft miss2 l <*> missingRight miss2 r + goInsertR1 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> binR <$> missingAllL miss2 (NonEmpty min minV l) <*> goInsertR1 k v xorCache max r + | otherwise -> (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss2 (boundKey min) minV <*> goInsertL1 k v xorCacheMin min l <*> missingRight miss2 r + OutOfBound -> (\v' n' -> l2rMap (maybeInsertMin (Bound k) v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss1 k v <*> missingRight miss2 n + Matched -> (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match k v minV <*> missingLeft miss2 l <*> missingRight miss2 r where xorCacheMin = xor k min goInsertR2 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss2 k v - goInsertR2 !k v !xorCache max n@(Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then binR <$> missingAllL miss1 (NonEmpty min minV l) <*> goInsertR2 k v xorCache max r - else (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss1 (boundKey min) minV <*> goInsertL2 k v xorCacheMin min l <*> missingRight miss1 r - | outOfMinBound k min = (\v' n' -> l2rMap (maybeInsertMin (Bound k) v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss2 k v <*> missingRight miss1 n - | otherwise = (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match k minV v <*> missingLeft miss1 l <*> missingRight miss1 r + goInsertR2 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> binR <$> missingAllL miss1 (NonEmpty min minV l) <*> goInsertR2 k v xorCache max r + | otherwise -> (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss1 (boundKey min) minV <*> goInsertL2 k v xorCacheMin min l <*> missingRight miss1 r + OutOfBound -> (\v' n' -> l2rMap (maybeInsertMin (Bound k) v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss2 k v <*> missingRight miss1 n + Matched -> (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match k minV v <*> missingLeft miss1 l <*> missingRight miss1 r where xorCacheMin = xor k min missingAllR whenMiss = fmap l2rMap . missingAllL whenMiss . r2lMap diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index f41eae8c0..a6ef0fbe3 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -318,36 +318,32 @@ insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, insertLookupWithKey combine !k v = toPair . start where start (IntMap Empty) = Nothing :*: IntMap (NonEmpty (Bound k) #! v # Tip) - start (IntMap (NonEmpty min minV root)) - | inMinBound k min = let mv :*: root' = goL (xor k min) min root - in mv :*: IntMap (NonEmpty min minV root') - | outOfMinBound k min = Nothing :*: IntMap (NonEmpty (Bound k) #! v # insertMinL (xor k min) min minV root) - | otherwise = Just minV :*: IntMap (NonEmpty (Bound k) #! combine k v minV # root) + start (IntMap (NonEmpty min minV root)) = case compareMinBound k min of + InBound -> let mv :*: root' = goL (xor k min) min root + in mv :*: IntMap (NonEmpty min minV root') + OutOfBound -> Nothing :*: IntMap (NonEmpty (Bound k) #! v # insertMinL (xor k min) min minV root) + Matched -> Just minV :*: IntMap (NonEmpty (Bound k) #! combine k v minV # root) goL !_ _ Tip = Nothing :*: (Bin (Bound k) #! v # Tip # Tip) - goL !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then let mv :*: l' = goL xorCache min l - in mv :*: Bin max maxV l' r - else let mv :*: r' = goR xorCacheMax max r - in mv :*: Bin max maxV l r' - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Nothing :*: (Bin (Bound k) #! v # Bin max maxV l r # Tip) - else Nothing :*: (Bin (Bound k) #! v # l # insertMaxR xorCacheMax max maxV r) - | otherwise = Just maxV :*: (Bin max #! combine k v maxV # l # r) + goL !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> let mv :*: l' = goL xorCache min l + in mv :*: Bin max maxV l' r + | otherwise -> let mv :*: r' = goR xorCacheMax max r + in mv :*: Bin max maxV l r' + OutOfBound | xor (boundKey max) min < xorCacheMax -> Nothing :*: (Bin (Bound k) #! v # Bin max maxV l r # Tip) + | otherwise -> Nothing :*: (Bin (Bound k) #! v # l # insertMaxR xorCacheMax max maxV r) + Matched -> Just maxV :*: (Bin max #! combine k v maxV # l # r) where xorCacheMax = xor k max goR !_ _ Tip = Nothing :*: (Bin (Bound k) #! v # Tip # Tip) - goR !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then let mv :*: r' = goR xorCache max r - in mv :*: Bin min minV l r' - else let mv :*: l' = goL xorCacheMin min l - in mv :*: Bin min minV l' r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Nothing :*: (Bin (Bound k) #! v # Tip # Bin min minV l r) - else Nothing :*: (Bin (Bound k) #! v # insertMinL xorCacheMin min minV l # r) - | otherwise = Just minV :*: (Bin min #! combine k v minV # l # r) + goR !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> let mv :*: r' = goR xorCache max r + in mv :*: Bin min minV l r' + | otherwise -> let mv :*: l' = goL xorCacheMin min l + in mv :*: Bin min minV l' r + OutOfBound | xor (boundKey min) max < xorCacheMin -> Nothing :*: (Bin (Bound k) #! v # Tip # Bin min minV l r) + | otherwise -> Nothing :*: (Bin (Bound k) #! v # insertMinL xorCacheMin min minV l # r) + Matched -> Just minV :*: (Bin min #! combine k v minV # l # r) where xorCacheMin = xor k min -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not @@ -360,27 +356,25 @@ adjust :: (a -> a) -> Key -> IntMap a -> IntMap a adjust f !k = start where start (IntMap Empty) = IntMap Empty - start m@(IntMap (NonEmpty min minV node)) - | inMinBound k min = IntMap (NonEmpty min minV (goL (xor k min) min node)) - | outOfMinBound k min = m - | otherwise = IntMap (NonEmpty min #! f minV # node) + start m@(IntMap (NonEmpty min minV node)) = case compareMinBound k min of + InBound -> IntMap (NonEmpty min minV (goL (xor k min) min node)) + OutOfBound -> m + Matched -> IntMap (NonEmpty min #! f minV # node) goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goL xorCache min l) r - else Bin max maxV l (goR xorCacheMax max r) - | outOfMaxBound k max = n - | otherwise = Bin max #! f maxV # l # r + goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache min l) r + | otherwise -> Bin max maxV l (goR xorCacheMax max r) + OutOfBound -> n + Matched -> Bin max #! f maxV # l # r where xorCacheMax = xor k max goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goR xorCache max r) - else Bin min minV (goL xorCacheMin min l) r - | outOfMinBound k min = n - | otherwise = Bin min #! f minV # l # r + goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache max r) + | otherwise -> Bin min minV (goL xorCacheMin min l) r + OutOfBound -> n + Matched -> Bin min #! f minV # l # r where xorCacheMin = xor k min -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not @@ -410,32 +404,30 @@ update f !k = start Nothing -> IntMap Empty Just !minV' -> IntMap (NonEmpty min minV' Tip) | otherwise = m - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | outOfMinBound k min = m - | k == boundKey min = case f minV of + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of + OutOfBound -> m + Matched -> case f minV of Nothing -> let DR min' minV' root' = deleteMinL max maxV l r - in IntMap (NonEmpty min' minV' root') + in IntMap (NonEmpty min' minV' root') Just !minV' -> IntMap (NonEmpty min minV' root) - | otherwise = IntMap (NonEmpty min minV (goL (xor k min) min root)) + InBound -> IntMap (NonEmpty min minV (goL (xor k min) min root)) goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goL xorCache min l) r - else Bin max maxV l (goR xorCacheMax max r) - | outOfMaxBound k max = n - | otherwise = case f maxV of + goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache min l) r + | otherwise -> Bin max maxV l (goR xorCacheMax max r) + OutOfBound -> n + Matched -> case f maxV of Nothing -> extractBinL l r Just !maxV' -> Bin max maxV' l r where xorCacheMax = xor k max goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goR xorCache max r) - else Bin min minV (goL xorCacheMin min l) r - | outOfMinBound k min = n - | otherwise = case f minV of + goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache max r) + | otherwise -> Bin min minV (goL xorCacheMin min l) r + OutOfBound -> n + Matched -> case f minV of Nothing -> extractBinR l r Just !minV' -> Bin min minV' l r where xorCacheMin = xor k min @@ -469,37 +461,35 @@ updateLookupWithKey f !k = start Nothing -> (Just minV, IntMap Empty) Just !minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) | otherwise = (Nothing, m) - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) - | outOfMinBound k min = (Nothing, m) - | k == boundKey min = case f k minV of + start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of + OutOfBound -> (Nothing, m) + Matched -> case f k minV of Nothing -> let DR min' minV' root' = deleteMinL max maxV l r in (Just minV, IntMap (NonEmpty min' minV' root')) Just !minV' -> (Just minV, IntMap (NonEmpty min minV' root)) - | otherwise = let (mv, root') = goL (xor k min) min root - in (mv, IntMap (NonEmpty min minV root')) + InBound -> let (mv, root') = goL (xor k min) min root + in (mv, IntMap (NonEmpty min minV root')) goL !_ _ Tip = (Nothing, Tip) - goL !xorCache min n@(Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then let (mv, l') = goL xorCache min l - in (mv, Bin max maxV l' r) - else let (mv, r') = goR xorCacheMax max r - in (mv, Bin max maxV l r') - | outOfMaxBound k max = (Nothing, n) - | otherwise = case f k maxV of + goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> let (mv, l') = goL xorCache min l + in (mv, Bin max maxV l' r) + | otherwise -> let (mv, r') = goR xorCacheMax max r + in (mv, Bin max maxV l r') + OutOfBound -> (Nothing, n) + Matched -> case f k maxV of Nothing -> (Just maxV, extractBinL l r) Just !maxV' -> (Just maxV, Bin max maxV' l r) where xorCacheMax = xor k max goR !_ _ Tip = (Nothing, Tip) - goR !xorCache max n@(Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then let (mv, r') = goR xorCache max r - in (mv, Bin min minV l r') - else let (mv, l') = goL xorCacheMin min l - in (mv, Bin min minV l' r) - | outOfMinBound k min = (Nothing, n) - | otherwise = case f k minV of + goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> let (mv, r') = goR xorCache max r + in (mv, Bin min minV l r') + | otherwise -> let (mv, l') = goL xorCacheMin min l + in (mv, Bin min minV l' r) + OutOfBound -> (Nothing, n) + Matched -> case f k minV of Nothing -> (Just minV, extractBinR l r) Just !minV' -> (Just minV, Bin min minV' l r) where xorCacheMin = xor k min @@ -651,47 +641,39 @@ unionWithKey = start GT -> Bin min1 minV1 l1 (goRFused combine max r1 n2) goInsertL1 _ k v !_ _ Tip = Bin (Bound k) #! v # Tip # Tip - goInsertL1 combine k v !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL1 combine k v xorCache min l) r - else Bin max maxV l (goInsertR1 combine k v xorCacheMax max r) - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v (Bin max maxV l r) Tip - else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max #! combine k v maxV # l # r + goInsertL1 combine k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goInsertL1 combine k v xorCache min l) r + | otherwise -> Bin max maxV l (goInsertR1 combine k v xorCacheMax max r) + OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip + | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + Matched -> Bin max #! combine k v maxV # l # r where xorCacheMax = xor k max goInsertR1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR1 combine k v !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR1 combine k v xorCache max r) - else Bin min minV (goInsertL1 combine k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v Tip (Bin min minV l r) - else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min #! combine k v minV # l # r + goInsertR1 combine k v !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goInsertR1 combine k v xorCache max r) + | otherwise -> Bin min minV (goInsertL1 combine k v xorCacheMin min l) r + OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) + | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + Matched -> Bin min #! combine k v minV # l # r where xorCacheMin = xor k min goInsertL2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertL2 combine k v !xorCache min (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then Bin max maxV (goInsertL2 combine k v xorCache min l) r - else Bin max maxV l (goInsertR2 combine k v xorCacheMax max r) - | outOfMaxBound k max = if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v (Bin max maxV l r) Tip - else Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - | otherwise = Bin max #! combine k maxV v # l # r + goInsertL2 combine k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goInsertL2 combine k v xorCache min l) r + | otherwise -> Bin max maxV l (goInsertR2 combine k v xorCacheMax max r) + OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip + | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) + Matched -> Bin max #! combine k maxV v # l # r where xorCacheMax = xor k max goInsertR2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip - goInsertR2 combine k v !xorCache max (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then Bin min minV l (goInsertR2 combine k v xorCache max r) - else Bin min minV (goInsertL2 combine k v xorCacheMin min l) r - | outOfMinBound k min = if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v Tip (Bin min minV l r) - else Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - | otherwise = Bin min #! combine k minV v # l # r + goInsertR2 combine k v !xorCache max (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goInsertR2 combine k v xorCache max r) + | otherwise -> Bin min minV (goInsertL2 combine k v xorCacheMin min l) r + OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) + | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r + Matched -> Bin min #! combine k minV v # l # r where xorCacheMin = xor k min -- | The union of a list of maps, with a combining operation. @@ -876,23 +858,21 @@ differenceWithKey combine = start GT -> Bin min1 minV1 l1 (loop r1 n2) goLookupL k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupL k v !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL k v xorCache l - else goLookupR k v xorCacheMax r - | outOfMaxBound k max = NonEmpty (Bound k) v Tip - | otherwise = case combine k v maxV of + goLookupL k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL k v xorCache l + | otherwise -> goLookupR k v xorCacheMax r + OutOfBound -> NonEmpty (Bound k) v Tip + Matched -> case combine k v maxV of Nothing -> Empty Just !v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max goLookupR k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupR k v !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR k v xorCache r - else goLookupL k v xorCacheMin l - | outOfMinBound k min = NonEmpty (Bound k) v Tip - | otherwise = case combine k v minV of + goLookupR k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR k v xorCache r + | otherwise -> goLookupL k v xorCacheMin l + OutOfBound -> NonEmpty (Bound k) v Tip + Matched -> case combine k v minV of Nothing -> Empty Just !v' -> NonEmpty (Bound k) v' Tip where xorCacheMin = xor k min @@ -1008,39 +988,35 @@ intersectionWithKey = start GT -> goRFused combine max r1 n2 goLookupL1 _ !_ _ !_ Tip = Empty - goLookupL1 combine k v !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL1 combine k v xorCache l - else goLookupR1 combine k v xorCacheMax r - | outOfMaxBound k max = Empty - | otherwise = NonEmpty (Bound k) #! combine k v maxV # Tip + goLookupL1 combine k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL1 combine k v xorCache l + | otherwise -> goLookupR1 combine k v xorCacheMax r + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) #! combine k v maxV # Tip where xorCacheMax = xor k max goLookupR1 _ !_ _ !_ Tip = Empty - goLookupR1 combine k v !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR1 combine k v xorCache r - else goLookupL1 combine k v xorCacheMin l - | outOfMinBound k min = Empty - | otherwise = NonEmpty (Bound k) #! combine k v minV # Tip + goLookupR1 combine k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR1 combine k v xorCache r + | otherwise -> goLookupL1 combine k v xorCacheMin l + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) #! combine k v minV # Tip where xorCacheMin = xor k min goLookupL2 _ !_ _ !_ Tip = Empty - goLookupL2 combine k v !xorCache (Bin max maxV l r) - | inMaxBound k max = if xorCache < xorCacheMax - then goLookupL2 combine k v xorCache l - else goLookupR2 combine k v xorCacheMax r - | outOfMaxBound k max = Empty - | otherwise = NonEmpty (Bound k) #! combine k maxV v # Tip + goLookupL2 combine k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL2 combine k v xorCache l + | otherwise -> goLookupR2 combine k v xorCacheMax r + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) #! combine k maxV v # Tip where xorCacheMax = xor k max goLookupR2 _ !_ _ !_ Tip = Empty - goLookupR2 combine k v !xorCache (Bin min minV l r) - | inMinBound k min = if xorCache < xorCacheMin - then goLookupR2 combine k v xorCache r - else goLookupL2 combine k v xorCacheMin l - | outOfMinBound k min = Empty - | otherwise = NonEmpty (Bound k) #! combine k minV v # Tip + goLookupR2 combine k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR2 combine k v xorCache r + | otherwise -> goLookupL2 combine k v xorCacheMin l + OutOfBound -> Empty + Matched -> NonEmpty (Bound k) #! combine k minV v # Tip where xorCacheMin = xor k min -- | /O(n+m)/. An unsafe general combining function. From 553e5ecbdb6b5a95491436688a0ba84b4b1e6fc9 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Fri, 10 Jan 2020 14:07:36 -0600 Subject: [PATCH 095/147] Unify the handling of singleton maps in IntMap.delete and update{,LookupWithKey} --- containers/src/Data/IntMap/Internal.hs | 15 ++++---------- containers/src/Data/IntMap/Lazy.hs | 28 ++++++++------------------ containers/src/Data/IntMap/Strict.hs | 28 ++++++++------------------ 3 files changed, 20 insertions(+), 51 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 60e8d1a64..1a4c8a526 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1193,14 +1193,10 @@ delete :: Key -> IntMap a -> IntMap a delete !k = start where start (IntMap Empty) = IntMap Empty - start m@(IntMap (NonEmpty min _ Tip)) - | k == boundKey min = IntMap Empty - | otherwise = m - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of - OutOfBound -> m - Matched -> let DR min' minV' root' = deleteMinL max maxV l r - in IntMap (NonEmpty min' minV' root') + start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of InBound -> IntMap (NonEmpty min minV (deleteL k (xor k min) root)) + OutOfBound -> m + Matched -> IntMap (nodeToMapL root) -- | Without this specialized type (I was just using a tuple), GHC's -- CPR correctly unboxed the tuple, but it couldn't unbox the returned @@ -2135,10 +2131,7 @@ splitLookup !k = start Matched -> let DR max' maxV' root' = deleteMaxR min minV l r in (IntMap (r2lMap (NonEmpty max' maxV' root')), Just maxV, IntMap Empty) OutOfBound -> (IntMap Empty, Nothing, m) - Matched -> case root of - Tip -> (IntMap Empty, Just minV, IntMap Empty) - Bin max maxV l r -> let DR min' minV' root' = deleteMinL max maxV l r - in (IntMap Empty, Just minV, IntMap (NonEmpty min' minV' root')) + Matched -> (IntMap Empty, Just minV, IntMap (nodeToMapL root)) go xorCacheMin min minV xorCacheMax max maxV l r | xorCacheMin < xorCacheMax = case l of diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 4e9c60b53..4a075fb95 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -374,18 +374,12 @@ update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a update f !k = start where start (IntMap Empty) = IntMap Empty - start m@(IntMap (NonEmpty min minV Tip)) - | k == boundKey min = case f minV of - Nothing -> IntMap Empty - Just minV' -> IntMap (NonEmpty min minV' Tip) - | otherwise = m - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of + start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of + InBound -> IntMap (NonEmpty min minV (goL (xor k min) min root)) OutOfBound -> m Matched -> case f minV of - Nothing -> let DR min' minV' root' = deleteMinL max maxV l r - in IntMap (NonEmpty min' minV' root') + Nothing -> IntMap (nodeToMapL root) Just minV' -> IntMap (NonEmpty min minV' root) - InBound -> IntMap (NonEmpty min minV (goL (xor k min) min root)) goL !_ _ Tip = Tip goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of @@ -431,19 +425,13 @@ updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, Int updateLookupWithKey f !k = start where start (IntMap Empty) = (Nothing, IntMap Empty) - start m@(IntMap (NonEmpty min minV Tip)) - | k == boundKey min = case f (boundKey min) minV of - Nothing -> (Just minV, IntMap Empty) - Just minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) - | otherwise = (Nothing, m) - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of - OutOfBound -> (Nothing, m) - Matched -> case f (boundKey min) minV of - Nothing -> let DR min' minV' root' = deleteMinL max maxV l r - in (Just minV, IntMap (NonEmpty min' minV' root')) - Just minV' -> (Just minV, IntMap (NonEmpty min minV' root)) + start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of InBound -> let (mv, root') = goL (xor k min) min root in (mv, IntMap (NonEmpty min minV root')) + OutOfBound -> (Nothing, m) + Matched -> (Just minV, case f (boundKey min) minV of + Nothing -> IntMap (nodeToMapL root) + Just minV' -> IntMap (NonEmpty min minV' root)) goL !_ _ Tip = (Nothing, Tip) goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index a6ef0fbe3..217300c28 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -399,18 +399,12 @@ update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a update f !k = start where start (IntMap Empty) = IntMap Empty - start m@(IntMap (NonEmpty min minV Tip)) - | k == boundKey min = case f minV of - Nothing -> IntMap Empty - Just !minV' -> IntMap (NonEmpty min minV' Tip) - | otherwise = m - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of + start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of + InBound -> IntMap (NonEmpty min minV (goL (xor k min) min root)) OutOfBound -> m Matched -> case f minV of - Nothing -> let DR min' minV' root' = deleteMinL max maxV l r - in IntMap (NonEmpty min' minV' root') + Nothing -> IntMap (nodeToMapL root) Just !minV' -> IntMap (NonEmpty min minV' root) - InBound -> IntMap (NonEmpty min minV (goL (xor k min) min root)) goL !_ _ Tip = Tip goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of @@ -456,19 +450,13 @@ updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, Int updateLookupWithKey f !k = start where start (IntMap Empty) = (Nothing, IntMap Empty) - start m@(IntMap (NonEmpty min minV Tip)) - | k == boundKey min = case f k minV of - Nothing -> (Just minV, IntMap Empty) - Just !minV' -> (Just minV, IntMap (NonEmpty min minV' Tip)) - | otherwise = (Nothing, m) - start m@(IntMap (NonEmpty min minV root@(Bin max maxV l r))) = case compareMinBound k min of - OutOfBound -> (Nothing, m) - Matched -> case f k minV of - Nothing -> let DR min' minV' root' = deleteMinL max maxV l r - in (Just minV, IntMap (NonEmpty min' minV' root')) - Just !minV' -> (Just minV, IntMap (NonEmpty min minV' root)) + start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of InBound -> let (mv, root') = goL (xor k min) min root in (mv, IntMap (NonEmpty min minV root')) + OutOfBound -> (Nothing, m) + Matched -> (Just minV, case f k minV of + Nothing -> IntMap (nodeToMapL root) + Just !minV' -> IntMap (NonEmpty min minV' root)) goL !_ _ Tip = (Nothing, Tip) goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of From 1e8abad95549d55ec07509620681ce4d14613c0f Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Fri, 10 Jan 2020 18:01:39 -0600 Subject: [PATCH 096/147] Simplify IntMap.delete by inlining the useless internal function --- containers/src/Data/IntMap/Internal.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 1a4c8a526..457cd0ce0 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1190,13 +1190,11 @@ fromListLazy = Data.List.foldl' (\t (k, a) -> insertLazy k a t) empty -- | /O(min(n,W))/. Delete a key and its value from the map. -- When the key is not a member of the map, the original map is returned. delete :: Key -> IntMap a -> IntMap a -delete !k = start - where - start (IntMap Empty) = IntMap Empty - start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of - InBound -> IntMap (NonEmpty min minV (deleteL k (xor k min) root)) - OutOfBound -> m - Matched -> IntMap (nodeToMapL root) +delete !_ (IntMap Empty) = IntMap Empty +delete !k m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of + InBound -> IntMap (NonEmpty min minV (deleteL k (xor k min) root)) + OutOfBound -> m + Matched -> IntMap (nodeToMapL root) -- | Without this specialized type (I was just using a tuple), GHC's -- CPR correctly unboxed the tuple, but it couldn't unbox the returned From 4fd6f018fabef54c395abde31b8f4539a8ffcb6c Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Fri, 10 Jan 2020 18:10:18 -0600 Subject: [PATCH 097/147] Use strict pairs for intermediates and don't bind arguments in updateLookupWithKey. ``` Benchmark Runtime change Original runtime updateLookupWithKey hit -45.78% 1.32e-03 updateLookupWithKey miss -49.10% 1.41e-03 ``` --- containers/src/Data/IntMap/Lazy.hs | 48 ++++++++++++++-------------- containers/src/Data/IntMap/Strict.hs | 48 ++++++++++++++-------------- 2 files changed, 48 insertions(+), 48 deletions(-) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 4a075fb95..34dfd0cd9 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -422,39 +422,39 @@ updateWithKey f k = update (f k) k -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) -updateLookupWithKey f !k = start +updateLookupWithKey = start where - start (IntMap Empty) = (Nothing, IntMap Empty) - start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of - InBound -> let (mv, root') = goL (xor k min) min root + start _ !_ (IntMap Empty) = (Nothing, IntMap Empty) + start f !k m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of + InBound -> let mv :*: root' = goL f k (xor k min) min root in (mv, IntMap (NonEmpty min minV root')) OutOfBound -> (Nothing, m) Matched -> (Just minV, case f (boundKey min) minV of Nothing -> IntMap (nodeToMapL root) Just minV' -> IntMap (NonEmpty min minV' root)) - goL !_ _ Tip = (Nothing, Tip) - goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> let (mv, l') = goL xorCache min l - in (mv, Bin max maxV l' r) - | otherwise -> let (mv, r') = goR xorCacheMax max r - in (mv, Bin max maxV l r') - OutOfBound -> (Nothing, n) - Matched -> case f (boundKey max) maxV of - Nothing -> (Just maxV, extractBinL l r) - Just maxV' -> (Just maxV, Bin max maxV' l r) + goL _ !_ !_ _ Tip = Nothing :*: Tip + goL f !k !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> let mv :*: l' = goL f k xorCache min l + in mv :*: Bin max maxV l' r + | otherwise -> let mv :*: r' = goR f k xorCacheMax max r + in mv :*: Bin max maxV l r' + OutOfBound -> Nothing :*: n + Matched -> Just maxV :*: case f (boundKey max) maxV of + Nothing -> extractBinL l r + Just maxV' -> Bin max maxV' l r where xorCacheMax = xor k max - goR !_ _ Tip = (Nothing, Tip) - goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> let (mv, r') = goR xorCache max r - in (mv, Bin min minV l r') - | otherwise -> let (mv, l') = goL xorCacheMin min l - in (mv, Bin min minV l' r) - OutOfBound -> (Nothing, n) - Matched -> case f (boundKey min) minV of - Nothing -> (Just minV, extractBinR l r) - Just minV' -> (Just minV, Bin min minV' l r) + goR _ !_ !_ _ Tip = Nothing :*: Tip + goR f !k !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> let mv :*: r' = goR f k xorCache max r + in mv :*: Bin min minV l r' + | otherwise -> let mv :*: l' = goL f k xorCacheMin min l + in mv :*: Bin min minV l' r + OutOfBound -> Nothing :*: n + Matched -> Just minV :*: case f (boundKey min) minV of + Nothing -> extractBinR l r + Just minV' -> Bin min minV' l r where xorCacheMin = xor k min -- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 217300c28..4dad24742 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -447,39 +447,39 @@ updateWithKey f k = update (f k) k -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) -updateLookupWithKey f !k = start +updateLookupWithKey = start where - start (IntMap Empty) = (Nothing, IntMap Empty) - start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of - InBound -> let (mv, root') = goL (xor k min) min root + start _ !_ (IntMap Empty) = (Nothing, IntMap Empty) + start f !k m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of + InBound -> let mv :*: root' = goL f k (xor k min) min root in (mv, IntMap (NonEmpty min minV root')) OutOfBound -> (Nothing, m) Matched -> (Just minV, case f k minV of Nothing -> IntMap (nodeToMapL root) Just !minV' -> IntMap (NonEmpty min minV' root)) - goL !_ _ Tip = (Nothing, Tip) - goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> let (mv, l') = goL xorCache min l - in (mv, Bin max maxV l' r) - | otherwise -> let (mv, r') = goR xorCacheMax max r - in (mv, Bin max maxV l r') - OutOfBound -> (Nothing, n) - Matched -> case f k maxV of - Nothing -> (Just maxV, extractBinL l r) - Just !maxV' -> (Just maxV, Bin max maxV' l r) + goL _ !_ !_ _ Tip = Nothing :*: Tip + goL f !k !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> let mv :*: l' = goL f k xorCache min l + in mv :*: Bin max maxV l' r + | otherwise -> let mv :*: r' = goR f k xorCacheMax max r + in mv :*: Bin max maxV l r' + OutOfBound -> Nothing :*: n + Matched -> Just maxV :*: case f k maxV of + Nothing -> extractBinL l r + Just !maxV' -> Bin max maxV' l r where xorCacheMax = xor k max - goR !_ _ Tip = (Nothing, Tip) - goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> let (mv, r') = goR xorCache max r - in (mv, Bin min minV l r') - | otherwise -> let (mv, l') = goL xorCacheMin min l - in (mv, Bin min minV l' r) - OutOfBound -> (Nothing, n) - Matched -> case f k minV of - Nothing -> (Just minV, extractBinR l r) - Just !minV' -> (Just minV, Bin min minV' l r) + goR _ !_ !_ _ Tip = Nothing :*: Tip + goR f !k !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> let mv :*: r' = goR f k xorCache max r + in mv :*: Bin min minV l r' + | otherwise -> let mv :*: l' = goL f k xorCacheMin min l + in mv :*: Bin min minV l' r + OutOfBound -> Nothing :*: n + Matched -> Just minV :*: case f k minV of + Nothing -> extractBinR l r + Just !minV' -> Bin min minV' l r where xorCacheMin = xor k min -- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. From 65962aad755cfc15f943d52ce5a3d146402fe720 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Fri, 10 Jan 2020 20:59:07 -0600 Subject: [PATCH 098/147] Reinstate the remaining IntMap RULES --- containers/src/Data/IntMap/Internal.hs | 39 ++++++++++++++++++++++---- containers/src/Data/IntMap/Lazy.hs | 17 ++++++++++- containers/src/Data/IntMap/Strict.hs | 36 ++++++++++++++++++++++++ 3 files changed, 86 insertions(+), 6 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 457cd0ce0..d9ba330b2 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -379,6 +379,10 @@ module Data.IntMap.Internal ( -- ** Disjoint , disjoint + -- * Traversal + -- ** Map + , mapLazy + -- * Folds , foldr , foldl @@ -742,15 +746,14 @@ instance Read1 IntMap where #endif instance Functor IntMap where - fmap f (IntMap m) = IntMap (fmap f m) + fmap = mapLazy #if defined(__GLASGOW_HASKELL__) a <$ (IntMap m) = IntMap (a <$ m) #endif instance Functor (IntMap_ t) where - fmap _ Empty = Empty - fmap f (NonEmpty min minV node) = NonEmpty min (f minV) (fmap f node) + fmap = mapLazy_ #if defined(__GLASGOW_HASKELL__) _ <$ Empty = Empty @@ -758,8 +761,7 @@ instance Functor (IntMap_ t) where #endif instance Functor (Node t) where - fmap _ Tip = Tip - fmap f (Bin k v l r) = Bin k (f v) (fmap f l) (fmap f r) + fmap = mapNodeLazy #if defined(__GLASGOW_HASKELL__) _ <$ Tip = Tip @@ -1186,6 +1188,33 @@ insertLazy :: Key -> a -> IntMap a -> IntMap a insertLazy = insertWithEval (const ()) const fromListLazy :: [(Key, a)] -> IntMap a fromListLazy = Data.List.foldl' (\t (k, a) -> insertLazy k a t) empty +mapLazy :: (a -> b) -> IntMap a -> IntMap b +mapLazy f (IntMap m) = IntMap (mapLazy_ f m) +mapLazy_ :: (a -> b) -> IntMap_ t a -> IntMap_ t b +mapLazy_ _ Empty = Empty +mapLazy_ f (NonEmpty min minV root) = NonEmpty min (f minV) (mapNodeLazy f root) +mapNodeLazy :: (a -> b) -> Node t a -> Node t b +mapNodeLazy _ Tip = Tip +mapNodeLazy f (Bin bound value l r) = Bin bound (f value) (mapNodeLazy f l) (mapNodeLazy f r) + +#if USE_REWRITE_RULES +{-# NOINLINE[1] mapLazy #-} +{-# NOINLINE[1] mapLazy_ #-} +{-# NOINLINE[1] mapNodeLazy #-} +{-# RULES +"map/map" forall f g m . mapLazy f (mapLazy g m) = mapLazy (f . g) m +"map_/map_" forall f g m . mapLazy_ f (mapLazy_ g m) = mapLazy_ (f . g) m +"mapNode/mapNode" forall f g n . mapNodeLazy f (mapNodeLazy g n) = mapNodeLazy (f . g) n + #-} +#if __GLASGOW_HASKELL >= 709 +-- Safe coercions were introduced in 7.8, but did not play well with RULES yes. +{-# RULES +"map/coerce" mapLazy coerce = coerce +"map_/coerce" mapLazy_ coerce = coerce +"mapNode/coerce" mapNodeLazy coerce = coerce + #-} +#endif +#endif -- | /O(min(n,W))/. Delete a key and its value from the map. -- When the key is not a member of the map, the original map is returned. diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 34dfd0cd9..b82031dc8 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1,7 +1,14 @@ {-# LANGUAGE CPP, BangPatterns #-} + +#include "containers.h" + #if !defined(TESTING) && defined(__GLASGOW_HASKELL__) +#if USE_REWRITE_RULES +{-# LANGUAGE Trustworthy #-} +#else {-# LANGUAGE Safe #-} #endif +#endif ----------------------------------------------------------------------------- -- | @@ -1025,7 +1032,7 @@ mergeWithKey matched miss1 miss2 = Merge.merge (Merge.mapMaybeMissing (single mi -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] map :: (a -> b) -> IntMap a -> IntMap b -map = fmap +map = mapLazy -- | /O(n)/. Map a function over all values in the map. -- @@ -1043,6 +1050,14 @@ mapWithKey f = start goR Tip = Tip goR (Bin k v l r) = Bin k (f (boundKey k) v) (goL l) (goR r) +#if USE_REWRITE_RULES +{-# NOINLINE[1] mapWithKey #-} +{-# RULES +"map/mapWithKey" forall f g m . mapLazy f (mapWithKey g m) = mapWithKey (\k -> f . g k) m +"mapWithKey/map" forall f g m . mapWithKey f (mapLazy g m) = mapWithKey (\k -> f k . g) m +"mapWithKey/mapWithKey" forall f g m . mapWithKey f (mapWithKey g m) = mapWithKey (\k -> f k . g k) m + #-} +#endif -- | /O(n)/. -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 4dad24742..f7d475c9d 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1,7 +1,14 @@ {-# LANGUAGE CPP, BangPatterns #-} + +#include "containers.h" + #if !defined(TESTING) && defined(__GLASGOW_HASKELL__) +#if USE_REWRITE_RULES +{-# LANGUAGE Trustworthy #-} +#else {-# LANGUAGE Safe #-} #endif +#endif ----------------------------------------------------------------------------- -- | @@ -234,6 +241,9 @@ module Data.IntMap.Strict ( ) where import Data.IntMap.Internal +#if USE_REWRITE_RULES +import qualified Data.IntMap.Lazy as L +#endif import qualified Data.IntMap.Merge.Strict as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) #if !MIN_VERSION_base(4,8,0) @@ -1077,6 +1087,32 @@ mapWithKey f = start goR Tip = Tip goR (Bin k v l r) = Bin k #! f (boundKey k) v # goL l # goR r +#if USE_REWRITE_RULES +-- Pay close attention to strictness here. We need to force the +-- intermediate result for @'map' f . 'map' g@, and we need to refrain +-- from forcing it for @'map' f . 'L.map' g@, etc. +-- +-- TODO Consider writing RULES for things like @'L.map' f ('map' g m)@. We'd +-- need a new function for this, and we'd have to pay attention to simplifier +-- phases. Somthing like +-- +-- > lsmap :: (b -> c) -> (a -> b) -> Node t a -> Node t c +-- > lsmap _ _ Tip = Tip +-- > lsmap f g (Bin bound value l r) = let !gvalue = g value +-- > in Bin bound (f gvalue) (lsmap f g l) (lsmap f g r) +{-# NOINLINE[1] map #-} +{-# NOINLINE[1] mapWithKey #-} +{-# RULES +"map/map" forall f g m . map f (map g m) = map (\v -> f $! g v) m +"map/mapL" forall f g m . map f (mapLazy g m) = map (f . g) m +"mapWithKey/map" forall f g m . mapWithKey f (map g m) = mapWithKey (\k v -> f k $! g v) m +"mapWithKey/mapL" forall f g m . mapWithKey f (mapLazy g m) = mapWithKey (\k -> f k . g) m +"map/mapWithKey" forall f g m . map f (mapWithKey g m) = mapWithKey (\k v -> f $! g k v) m +"map/mapWithKeyL" forall f g m . map f (L.mapWithKey g m) = mapWithKey (\k -> f . g k) m +"mapWithKey/mapWithKey" forall f g m . mapWithKey f (mapWithKey g m) = mapWithKey (\k v -> f k $! g k v) m +"mapWithKey/mapWithKeyL" forall f g m . mapWithKey f (L.mapWithKey g m) = mapWithKey (\k -> f k . g k) m + #-} +#endif -- | /O(n)/. -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ From 93180eec635e994a5449641d8a40957b15a2b150 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 11 Jan 2020 13:09:25 -0600 Subject: [PATCH 099/147] Don't bind arguments in differenceWith ``` Benchmark Runtime change Original runtime differenceWith (keep)-block_nn -22.60% 1.95e-05 differenceWith (keep)-block_nn_swap -18.24% 1.92e-05 differenceWith (keep)-block_ns -35.83% 2.62e-06 differenceWith (keep)-block_sn_swap -13.16% 2.77e-06 differenceWith (keep)-common_nn -3.49% 5.48e-03 differenceWith (keep)-common_nn_swap -2.99% 7.18e-03 differenceWith (keep)-common_ns -4.64% 1.44e-03 differenceWith (keep)-common_nt -0.88% 5.41e-05 differenceWith (keep)-common_sn_swap +11.81% 1.20e-03 differenceWith (keep)-common_tn_swap +1.17% 3.22e-05 differenceWith (keep)-disj_nn -82.20% 1.54e-07 differenceWith (keep)-disj_nn_swap -83.40% 1.56e-07 differenceWith (keep)-disj_ns -82.21% 1.54e-07 differenceWith (keep)-disj_nt -82.58% 1.58e-07 differenceWith (keep)-disj_sn_swap -83.52% 1.57e-07 differenceWith (keep)-disj_tn_swap -83.50% 1.57e-07 differenceWith (keep)-mix_nn -9.18% 9.35e-03 differenceWith (keep)-mix_nn_swap -6.46% 9.11e-03 differenceWith (keep)-mix_ns -3.96% 1.09e-03 differenceWith (keep)-mix_nt -3.89% 4.07e-05 differenceWith (keep)-mix_sn_swap +9.39% 6.57e-04 differenceWith (keep)-mix_tn_swap -16.46% 2.87e-05 differenceWith (delete)-block_nn -19.70% 1.95e-05 differenceWith (delete)-block_nn_swap -17.68% 1.92e-05 differenceWith (delete)-block_ns -35.15% 2.61e-06 differenceWith (delete)-block_sn_swap -12.95% 2.75e-06 differenceWith (delete)-common_nn -7.01% 4.87e-03 differenceWith (delete)-common_nn_swap +20.32% 1.40e-03 differenceWith (delete)-common_ns -1.97% 1.60e-03 differenceWith (delete)-common_nt -0.15% 5.39e-05 differenceWith (delete)-common_sn_swap +5.78% 4.16e-04 differenceWith (delete)-common_tn_swap -3.96% 2.71e-05 differenceWith (delete)-disj_nn -82.09% 1.55e-07 differenceWith (delete)-disj_nn_swap -83.01% 1.57e-07 differenceWith (delete)-disj_ns -82.11% 1.55e-07 differenceWith (delete)-disj_nt -82.07% 1.55e-07 differenceWith (delete)-disj_sn_swap -83.00% 1.57e-07 differenceWith (delete)-disj_tn_swap -82.80% 1.57e-07 differenceWith (delete)-mix_nn -8.09% 9.35e-03 differenceWith (delete)-mix_nn_swap -6.58% 9.17e-03 differenceWith (delete)-mix_ns +10.79% 1.08e-03 differenceWith (delete)-mix_nt +1.87% 4.06e-05 differenceWith (delete)-mix_sn_swap +11.86% 6.65e-04 differenceWith (delete)-mix_tn_swap -15.67% 2.84e-05 Minimum -83.52% Average -41.26% Maximum +20.32% ``` --- .../SetOperations/SetOperations-IntMap.hs | 8 +- containers/src/Data/IntMap/Lazy.hs | 286 +++++++++--------- containers/src/Data/IntMap/Strict.hs | 286 +++++++++--------- 3 files changed, 284 insertions(+), 296 deletions(-) diff --git a/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs b/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs index a3bf40824..4f5a1bd65 100644 --- a/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs +++ b/containers-tests/benchmarks/SetOperations/SetOperations-IntMap.hs @@ -4,7 +4,11 @@ import Data.IntMap as C import SetOperations main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True - [ ("union", C.union), ("unionWith", C.unionWith (+)) + [ ("union", C.union) + , ("unionWith", C.unionWith (+)) , ("difference", C.difference) - , ("intersection", C.intersection), ("intersectionWith", C.intersectionWith (+)) + , ("differenceWith (keep)", C.differenceWith (\a b -> Just (a + b))) + , ("differenceWith (delete)", C.differenceWith (\_ _ -> Nothing)) + , ("intersection", C.intersection) + , ("intersectionWith", C.intersectionWith (+)) ] diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index b82031dc8..9f1417db6 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -670,177 +670,169 @@ differenceWith f = differenceWithKey (const f) -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) -- > == singleton 3 "3:b|B" differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWithKey combine = start +differenceWithKey = start where - start (IntMap Empty) !_ = IntMap Empty - start !m (IntMap Empty) = m - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 min1 root1 min2 root2)) - | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + start _ (IntMap Empty) !_ = IntMap Empty + start _ !m (IntMap Empty) = m + start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine min1 root1 min2 root2)) + | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) | otherwise = case combine (boundKey min1) minV1 minV2 of - Nothing -> IntMap (goLFused min1 root1 root2) - Just minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep min1 root1 root2)) - - goL1 minV1 min1 Tip min2 n2 = goLookupL (boundKey min1) minV1 (xor (boundKey min1) min2) n2 - goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + Nothing -> IntMap (goLFused combine min1 root1 root2) + Just minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep combine min1 root1 root2)) + + goL1 combine minV1 min1 Tip min2 n2 = goLookupL combine (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 _ minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 + goL1 _ minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 + goL1 combine minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 - Just maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) - | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + Nothing -> r2lMap $ goRFused combine max1 (Bin min1 minV1 l1 r1) r2 + Just maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep combine max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine max1 r1 max2 r2)) + | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) - Just maxV1' -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) - GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) - - goL2 !_ Tip !_ !_ = Tip - goL2 min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 - goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 - goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goL2 min1 n1 min2 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> goL2 min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + Nothing -> binL (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) + Just maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) + GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) + + goL2 _ !_ Tip !_ !_ = Tip + goL2 _ min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 + goL2 _ _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 combine min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goL2 combine min1 n1 min2 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine min1 l1 min2 l2) (goR2 combine max1 r1 max2 r2) + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of + Empty -> goL2 combine min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine min1 l1 min2 l2) r' | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> case goRFused max1 r1 r2 of - Empty -> goL2 min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' - Just maxV1' -> Bin max1 maxV1' (goL2 min1 l1 min2 l2) (goRFusedKeep max1 r1 r2) - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of + Nothing -> case goRFused combine max1 r1 r2 of + Empty -> goL2 combine min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine min1 l1 min2 l2) r' + Just maxV1' -> Bin max1 maxV1' (goL2 combine min1 l1 min2 l2) (goRFusedKeep combine max1 r1 r2) + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine max1 r1 max2 (Bin min2 dummyV l2 r2)) + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of + Nothing -> case goRFused combine max1 r1 (Bin min2 dummyV l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - Just maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep max1 r1 (Bin min2 dummyV l2 r2)) - - goLFused min = loop - where - loop Tip !_ = Empty - loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of - DR min' minV' n' -> NonEmpty min' minV' n' - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) - | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - Just maxV1' -> binL (loop l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) - GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) - - goLFusedKeep min = loop - where - loop n1 Tip = n1 - loop Tip !_ = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (loop l1 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> case goRFused max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - Just maxV1' -> Bin max1 maxV1' (loop l1 l2) (goRFusedKeep max1 r1 r2) - GT -> Bin max1 maxV1 (loop l1 n2) r1 - - goR1 maxV1 max1 Tip max2 n2 = goLookupR (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 - goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) - | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + Just maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep combine max1 r1 (Bin min2 dummyV l2 r2)) + + goLFused _ !_ Tip !_ = Empty + goLFused _ !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of + DR min' minV' n' -> NonEmpty min' minV' n' + goLFused combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of + LT -> goLFused combine min n1 l2 + EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine max1 r1 max2 r2)) + | max1 < max2 -> binL (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + Nothing -> binL (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + Just maxV1' -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) + GT -> binL (goLFused combine min l1 n2) (NonEmpty max1 maxV1 r1) + + goLFusedKeep _ !_ n1 Tip = n1 + goLFusedKeep _ !_ Tip !_ = Tip + goLFusedKeep combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of + LT -> goLFusedKeep combine min n1 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goLFusedKeep combine min l1 l2) (goR2 combine max1 r1 max2 r2) + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of + Empty -> goLFusedKeep combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + Nothing -> case goRFused combine max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 + Empty -> goLFusedKeep combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' + Just maxV1' -> Bin max1 maxV1' (goLFusedKeep combine min l1 l2) (goRFusedKeep combine max1 r1 r2) + GT -> Bin max1 maxV1 (goLFusedKeep combine min l1 n2) r1 + + goR1 combine maxV1 max1 Tip max2 n2 = goLookupR combine (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 _ maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 + goR1 _ maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 + goR1 combine maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine min1 (Bin max1 maxV1 l1 r1) min2 l2) + | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 - Just minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + Nothing -> l2rMap $ goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 + Just minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep combine min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) - Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (goR1 maxV1 max1 r1 max2 r2) - GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) - - goR2 !_ Tip !_ !_ = Tip - goR2 max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 - goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 - goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goR2 max1 n1 max2 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> goR2 max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + Nothing -> binR (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) + Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) + GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) + + goR2 _ !_ Tip !_ !_ = Tip + goR2 _ max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 + goR2 _ _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 combine max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goR2 combine max1 n1 max2 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 l2) (goR2 combine max1 r1 max2 r2) + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of + Empty -> goR2 combine max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine max1 r1 max2 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> case goLFused min1 l1 l2 of - Empty -> goR2 max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) - Just minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (goR2 max1 r1 max2 r2) - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 - | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of + Nothing -> case goLFused combine min1 l1 l2 of + Empty -> goR2 combine max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine max1 r1 max2 r2) + Just minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goR2 combine max1 r1 max2 r2) + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of + Nothing -> case goLFused combine min1 l1 (Bin max2 dummyV l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - Just minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 (Bin max2 dummyV l2 r2)) r1 - - goRFused max = loop - where - loop Tip !_ = Empty - loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of - DR max' maxV' n' -> NonEmpty max' maxV' n' - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 - Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (loop r1 r2) - GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) - - goRFusedKeep max = loop - where - loop n1 Tip = n1 - loop Tip !_ = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (loop r1 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 - Nothing -> case goLFused min1 l1 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - Just minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (loop r1 r2) - GT -> Bin min1 minV1 l1 (loop r1 n2) - - goLookupL k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupL k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> goLookupL k v xorCache l - | otherwise -> goLookupR k v xorCacheMax r + Just minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 (Bin max2 dummyV l2 r2)) r1 + + goRFused _ !_ Tip !_ = Empty + goRFused _ !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of + DR max' maxV' n' -> NonEmpty max' maxV' n' + goRFused combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of + LT -> goRFused combine max n1 r2 + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine min1 l1 min2 l2)) (goRFused combine max r1 r2) + | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) + | otherwise -> case combine (boundKey min1) minV1 minV2 of + Nothing -> binR (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goRFused combine max r1 r2) + GT -> binR (NonEmpty min1 minV1 l1) (goRFused combine max r1 n2) + + goRFusedKeep _ !_ n1 Tip = n1 + goRFusedKeep _ !_ Tip !_ = Tip + goRFusedKeep combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of + LT -> goRFusedKeep combine max n1 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 l2) (goRFusedKeep combine max r1 r2) + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of + Empty -> goRFusedKeep combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) + | otherwise -> case combine (boundKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + Nothing -> case goLFused combine min1 l1 l2 of + Empty -> goRFusedKeep combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) + Just minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goRFusedKeep combine max r1 r2) + GT -> Bin min1 minV1 l1 (goRFusedKeep combine max r1 n2) + + goLookupL _ k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupL combine k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL combine k v xorCache l + | otherwise -> goLookupR combine k v xorCacheMax r OutOfBound -> NonEmpty (Bound k) v Tip Matched -> case combine k v maxV of Nothing -> Empty Just v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max - goLookupR k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupR k v !xorCache (Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> goLookupR k v xorCache r - | otherwise -> goLookupL k v xorCacheMin l + goLookupR _ k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupR combine k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR combine k v xorCache r + | otherwise -> goLookupL combine k v xorCacheMin l OutOfBound -> NonEmpty (Bound k) v Tip Matched -> case combine k v minV of Nothing -> Empty diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index f7d475c9d..266645c5c 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -698,177 +698,169 @@ differenceWith f = differenceWithKey (const f) -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) -- > == singleton 3 "3:b|B" differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWithKey combine = start +differenceWithKey = start where - start (IntMap Empty) !_ = IntMap Empty - start !m (IntMap Empty) = m - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 min1 root1 min2 root2)) - | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) + start _ (IntMap Empty) !_ = IntMap Empty + start _ !m (IntMap Empty) = m + start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine min1 root1 min2 root2)) + | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) | otherwise = case combine (boundKey min1) minV1 minV2 of - Nothing -> IntMap (goLFused min1 root1 root2) - Just !minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep min1 root1 root2)) - - goL1 minV1 min1 Tip min2 n2 = goLookupL (boundKey min1) minV1 (xor (boundKey min1) min2) n2 - goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 + Nothing -> IntMap (goLFused combine min1 root1 root2) + Just !minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep combine min1 root1 root2)) + + goL1 combine minV1 min1 Tip min2 n2 = goLookupL combine (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 _ minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 + goL1 _ minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 + goL1 combine minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 + | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> r2lMap $ goRFused max1 (Bin min1 minV1 l1 r1) r2 - Just !maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) - | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + Nothing -> r2lMap $ goRFused combine max1 (Bin min1 minV1 l1 r1) r2 + Just !maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep combine max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine max1 r1 max2 r2)) + | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) - Just !maxV1' -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) - GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) - - goL2 !_ Tip !_ !_ = Tip - goL2 min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 - goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 - goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goL2 min1 n1 min2 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> goL2 min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + Nothing -> binL (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) + Just !maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) + GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) + + goL2 _ !_ Tip !_ !_ = Tip + goL2 _ min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 + goL2 _ _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 combine min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goL2 combine min1 n1 min2 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine min1 l1 min2 l2) (goR2 combine max1 r1 max2 r2) + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of + Empty -> goL2 combine min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine min1 l1 min2 l2) r' | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> case goRFused max1 r1 r2 of - Empty -> goL2 min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' - Just !maxV1' -> Bin max1 maxV1' (goL2 min1 l1 min2 l2) (goRFusedKeep max1 r1 r2) - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of + Nothing -> case goRFused combine max1 r1 r2 of + Empty -> goL2 combine min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine min1 l1 min2 l2) r' + Just !maxV1' -> Bin max1 maxV1' (goL2 combine min1 l1 min2 l2) (goRFusedKeep combine max1 r1 r2) + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine max1 r1 max2 (Bin min2 dummyV l2 r2)) + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of + Nothing -> case goRFused combine max1 r1 (Bin min2 dummyV l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - Just !maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep max1 r1 (Bin min2 dummyV l2 r2)) - - goLFused min = loop - where - loop Tip !_ = Empty - loop (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of - DR min' minV' n' -> NonEmpty min' minV' n' - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> binL (loop l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) - | max1 < max2 -> binL (loop l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> binL (loop l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - Just !maxV1' -> binL (loop l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep max1 r1 r2)) - GT -> binL (loop l1 n2) (NonEmpty max1 maxV1 r1) - - goLFusedKeep min = loop - where - loop n1 Tip = n1 - loop Tip !_ = Tip - loop n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> loop n1 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (loop l1 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> case goRFused max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 - Empty -> loop l1 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (loop l1 l2) r' - Just !maxV1' -> Bin max1 maxV1' (loop l1 l2) (goRFusedKeep max1 r1 r2) - GT -> Bin max1 maxV1 (loop l1 n2) r1 - - goR1 maxV1 max1 Tip max2 n2 = goLookupR (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 - goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) - | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 + Just !maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep combine max1 r1 (Bin min2 dummyV l2 r2)) + + goLFused _ !_ Tip !_ = Empty + goLFused _ !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of + DR min' minV' n' -> NonEmpty min' minV' n' + goLFused combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of + LT -> goLFused combine min n1 l2 + EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine max1 r1 max2 r2)) + | max1 < max2 -> binL (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + Nothing -> binL (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + Just !maxV1' -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) + GT -> binL (goLFused combine min l1 n2) (NonEmpty max1 maxV1 r1) + + goLFusedKeep _ !_ n1 Tip = n1 + goLFusedKeep _ !_ Tip !_ = Tip + goLFusedKeep combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of + LT -> goLFusedKeep combine min n1 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goLFusedKeep combine min l1 l2) (goR2 combine max1 r1 max2 r2) + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of + Empty -> goLFusedKeep combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' + | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + Nothing -> case goRFused combine max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 + Empty -> goLFusedKeep combine min l1 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' + Just !maxV1' -> Bin max1 maxV1' (goLFusedKeep combine min l1 l2) (goRFusedKeep combine max1 r1 r2) + GT -> Bin max1 maxV1 (goLFusedKeep combine min l1 n2) r1 + + goR1 combine maxV1 max1 Tip max2 n2 = goLookupR combine (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 _ maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 + goR1 _ maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 + goR1 combine maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 + | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine min1 (Bin max1 maxV1 l1 r1) min2 l2) + | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> l2rMap $ goLFused min1 (Bin max1 maxV1 l1 r1) l2 - Just !minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + Nothing -> l2rMap $ goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 + Just !minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep combine min1 (Bin max1 maxV1 l1 r1) l2) + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) + | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) - Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (goR1 maxV1 max1 r1 max2 r2) - GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) - - goR2 !_ Tip !_ !_ = Tip - goR2 max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 - goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 - goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goR2 max1 n1 max2 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> goR2 max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + Nothing -> binR (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) + Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) + GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) + + goR2 _ !_ Tip !_ !_ = Tip + goR2 _ max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 + goR2 _ _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 combine max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goR2 combine max1 n1 max2 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 l2) (goR2 combine max1 r1 max2 r2) + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of + Empty -> goR2 combine max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine max1 r1 max2 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> case goLFused min1 l1 l2 of - Empty -> goR2 max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) - Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (goR2 max1 r1 max2 r2) - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 - | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of + Nothing -> case goLFused combine min1 l1 l2 of + Empty -> goR2 combine max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine max1 r1 max2 r2) + Just !minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goR2 combine max1 r1 max2 r2) + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of + Nothing -> case goLFused combine min1 l1 (Bin max2 dummyV l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 (Bin max2 dummyV l2 r2)) r1 - - goRFused max = loop - where - loop Tip !_ = Empty - loop (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of - DR max' maxV' n' -> NonEmpty max' maxV' n' - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (loop r1 r2) - | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (loop r1 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> binR (goLFused min1 l1 l2) (loop r1 r2) -- we choose min1 arbitrarily, as min1 == min2 - Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep min1 l1 l2)) (loop r1 r2) - GT -> binR (NonEmpty min1 minV1 l1) (loop r1 n2) - - goRFusedKeep max = loop - where - loop n1 Tip = n1 - loop Tip !_ = Tip - loop n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> loop n1 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (loop r1 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 - Nothing -> case goLFused min1 l1 l2 of - Empty -> loop r1 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (loop r1 r2) - Just !minV1' -> Bin min1 minV1' (goLFusedKeep min1 l1 l2) (loop r1 r2) - GT -> Bin min1 minV1 l1 (loop r1 n2) - - goLookupL k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupL k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> goLookupL k v xorCache l - | otherwise -> goLookupR k v xorCacheMax r + Just !minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 (Bin max2 dummyV l2 r2)) r1 + + goRFused _ !_ Tip !_ = Empty + goRFused _ !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of + DR max' maxV' n' -> NonEmpty max' maxV' n' + goRFused combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of + LT -> goRFused combine max n1 r2 + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine min1 l1 min2 l2)) (goRFused combine max r1 r2) + | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) + | otherwise -> case combine (boundKey min1) minV1 minV2 of + Nothing -> binR (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goRFused combine max r1 r2) + GT -> binR (NonEmpty min1 minV1 l1) (goRFused combine max r1 n2) + + goRFusedKeep _ !_ n1 Tip = n1 + goRFusedKeep _ !_ Tip !_ = Tip + goRFusedKeep combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of + LT -> goRFusedKeep combine max n1 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 l2) (goRFusedKeep combine max r1 r2) + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of + Empty -> goRFusedKeep combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) + | otherwise -> case combine (boundKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + Nothing -> case goLFused combine min1 l1 l2 of + Empty -> goRFusedKeep combine max r1 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) + Just !minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goRFusedKeep combine max r1 r2) + GT -> Bin min1 minV1 l1 (goRFusedKeep combine max r1 n2) + + goLookupL _ k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupL combine k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goLookupL combine k v xorCache l + | otherwise -> goLookupR combine k v xorCacheMax r OutOfBound -> NonEmpty (Bound k) v Tip Matched -> case combine k v maxV of Nothing -> Empty Just !v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max - goLookupR k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupR k v !xorCache (Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> goLookupR k v xorCache r - | otherwise -> goLookupL k v xorCacheMin l + goLookupR _ k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupR combine k v !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goLookupR combine k v xorCache r + | otherwise -> goLookupL combine k v xorCacheMin l OutOfBound -> NonEmpty (Bound k) v Tip Matched -> case combine k v minV of Nothing -> Empty From 637ac76733862b5dad2f8bbab3cdb11c71c0058d Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 11 Jan 2020 14:07:29 -0600 Subject: [PATCH 100/147] Fix major bug in IntMap.differenceWith: parts of the code matched difference, assuming that a key in the second map would result in that key being deleted from the first. --- containers-tests/tests/intmap-properties.hs | 12 +++ containers/src/Data/IntMap/Internal.hs | 2 - containers/src/Data/IntMap/Lazy.hs | 102 ++++++++++++-------- containers/src/Data/IntMap/Strict.hs | 102 ++++++++++++-------- 4 files changed, 132 insertions(+), 86 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index ec43ab01d..6574b25ff 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -151,6 +151,7 @@ main = defaultMain , testProperty "union+unionWith" prop_unionWith , testProperty "union sum" prop_unionSum , testProperty "difference model" prop_differenceModel + , testProperty "differenceWithKey model" prop_differenceWithKeyModel , testProperty "intersection model" prop_intersectionModel , testProperty "intersectionWith model" prop_intersectionWithModel , testProperty "intersectionWithKey model" prop_intersectionWithKeyModel @@ -1351,6 +1352,17 @@ prop_differenceModel xs ys = (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys))) +prop_differenceWithKeyModel :: Fun (Int, Int, Int) (Maybe Int) -> [(Int,Int)] -> [(Int,Int)] -> Property +prop_differenceWithKeyModel f xs ys + = toList (differenceWithKey (\k x y -> apply f (k, x, y)) (fromList xs') (fromList ys')) + === Maybe.mapMaybe diffSingle (sort xs') + where + xs' = List.nubBy ((==) `on` fst) xs + ys' = List.nubBy ((==) `on` fst) ys + diffSingle (k, x) = case List.lookup k ys' of + Nothing -> Just (k, x) + Just y -> fmap (\r -> (k, r)) (apply f (k, x, y)) + prop_intersectionModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_intersectionModel xs ys = case intersection (fromListWith (+) xs) (fromListWith (+) ys) of diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index d9ba330b2..a41cef9da 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -340,8 +340,6 @@ module Data.IntMap.Internal ( -- * Deletion\/Update , delete - , deleteL - , deleteR , deleteMinL , deleteMaxR diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 9f1417db6..d78ee30ed 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -675,7 +675,7 @@ differenceWithKey = start start _ (IntMap Empty) !_ = IntMap Empty start _ !m (IntMap Empty) = m start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine min1 root1 min2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) | otherwise = case combine (boundKey min1) minV1 minV2 of Nothing -> IntMap (goLFused combine min1 root1 root2) @@ -686,49 +686,49 @@ differenceWithKey = start goL1 _ minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 goL1 combine minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> r2lMap $ goRFused combine max1 (Bin min1 minV1 l1 r1) r2 Just maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep combine max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine max1 r1 max2 r2)) + EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> binL (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) Just maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) - goL2 _ !_ Tip !_ !_ = Tip - goL2 _ min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 - goL2 _ _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 - goL2 combine min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goL2 combine min1 n1 min2 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine min1 l1 min2 l2) (goR2 combine max1 r1 max2 r2) + goL2 _ _ !_ Tip !_ !_ = Tip + goL2 combine minV2 min1 n1 min2 Tip = goDeleteL combine (boundKey min2) minV2 (xor (boundKey min2) min1) n1 + goL2 _ _ _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 combine minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goL2 combine minV2 min1 n1 min2 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of - Empty -> goL2 combine min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine min1 l1 min2 l2) r' + Empty -> goL2 combine minV2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of - Empty -> goL2 combine min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine min1 l1 min2 l2) r' - Just maxV1' -> Bin max1 maxV1' (goL2 combine min1 l1 min2 l2) (goRFusedKeep combine max1 r1 r2) - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine max1 r1 max2 (Bin min2 dummyV l2 r2)) - | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of + Empty -> goL2 combine minV2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' + Just maxV1' -> Bin max1 maxV1' (goL2 combine minV2 min1 l1 min2 l2) (goRFusedKeep combine max1 r1 r2) + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> case goRFused combine max1 r1 (Bin min2 dummyV l2 r2) of + Nothing -> case goRFused combine max1 r1 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - Just maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep combine max1 r1 (Bin min2 dummyV l2 r2)) + Just maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep combine max1 r1 (Bin min2 minV2 l2 r2)) goLFused _ !_ Tip !_ = Empty goLFused _ !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of DR min' minV' n' -> NonEmpty min' minV' n' goLFused combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFused combine min n1 l2 - EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine max1 r1 max2 r2)) + EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> binL (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 @@ -739,7 +739,7 @@ differenceWithKey = start goLFusedKeep _ !_ Tip !_ = Tip goLFusedKeep combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFusedKeep combine min n1 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (goLFusedKeep combine min l1 l2) (goR2 combine max1 r1 max2 r2) + EQ | max1 > max2 -> Bin max1 maxV1 (goLFusedKeep combine min l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' @@ -755,49 +755,49 @@ differenceWithKey = start goR1 _ maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 goR1 combine maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine min1 (Bin max1 maxV1 l1 r1) min2 l2) + | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> l2rMap $ goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 Just minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep combine min1 (Bin max1 maxV1 l1 r1) l2) - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) - goR2 _ !_ Tip !_ !_ = Tip - goR2 _ max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 - goR2 _ _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 - goR2 combine max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goR2 combine max1 n1 max2 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 l2) (goR2 combine max1 r1 max2 r2) + goR2 _ _ !_ Tip !_ !_ = Tip + goR2 combine maxV2 max1 n1 max2 Tip = goDeleteR combine (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 + goR2 _ _ _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 combine maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goR2 combine maxV2 max1 n1 max2 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of - Empty -> goR2 combine max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine max1 r1 max2 r2) + Empty -> goR2 combine maxV2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> case goLFused combine min1 l1 l2 of - Empty -> goR2 combine max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine max1 r1 max2 r2) - Just minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goR2 combine max1 r1 max2 r2) - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 - | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of + Empty -> goR2 combine maxV2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) + Just minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine maxV2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> case goLFused combine min1 l1 (Bin max2 dummyV l2 r2) of + Nothing -> case goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - Just minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 (Bin max2 dummyV l2 r2)) r1 + Just minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 (Bin max2 maxV2 l2 r2)) r1 goRFused _ !_ Tip !_ = Empty goRFused _ !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of DR max' maxV' n' -> NonEmpty max' maxV' n' goRFused combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFused combine max n1 r2 - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine min1 l1 min2 l2)) (goRFused combine max r1 r2) + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goRFused combine max r1 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 @@ -808,7 +808,7 @@ differenceWithKey = start goRFusedKeep _ !_ Tip !_ = Tip goRFusedKeep combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFusedKeep combine max n1 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 l2) (goRFusedKeep combine max r1 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goRFusedKeep combine max r1 r2) | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) @@ -839,7 +839,25 @@ differenceWithKey = start Just v' -> NonEmpty (Bound k) v' Tip where xorCacheMin = xor k min - dummyV = error "impossible" + goDeleteL _ !_ _ !_ Tip = Tip + goDeleteL combine !k v !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goDeleteL combine k v xorCache l) r + | otherwise -> Bin max maxV l (goDeleteR combine k v xorCacheMax r) + OutOfBound -> n + Matched -> case combine k maxV v of + Nothing -> extractBinL l r + Just maxV' -> Bin max maxV' l r + where xorCacheMax = xor k max + + goDeleteR _ !_ _ !_ Tip = Tip + goDeleteR combine !k v !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goDeleteR combine k v xorCache r) + | otherwise -> Bin min minV (goDeleteL combine k v xorCacheMin l) r + OutOfBound -> n + Matched -> case combine k minV v of + Nothing -> extractBinR l r + Just minV' -> Bin min minV' l r + where xorCacheMin = xor k min -- | /O(n+m)/. The intersection with a combining function. -- diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 266645c5c..2749f5850 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -703,7 +703,7 @@ differenceWithKey = start start _ (IntMap Empty) !_ = IntMap Empty start _ !m (IntMap Empty) = m start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine min1 root1 min2 root2)) + | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) | otherwise = case combine (boundKey min1) minV1 minV2 of Nothing -> IntMap (goLFused combine min1 root1 root2) @@ -714,49 +714,49 @@ differenceWithKey = start goL1 _ minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 goL1 combine minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 - | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> r2lMap $ goRFused combine max1 (Bin min1 minV1 l1 r1) r2 Just !maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep combine max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine max1 r1 max2 r2)) + EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> binL (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) Just !maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) - goL2 _ !_ Tip !_ !_ = Tip - goL2 _ min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 - goL2 _ _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 - goL2 combine min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goL2 combine min1 n1 min2 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine min1 l1 min2 l2) (goR2 combine max1 r1 max2 r2) + goL2 _ _ !_ Tip !_ !_ = Tip + goL2 combine minV2 min1 n1 min2 Tip = goDeleteL combine (boundKey min2) minV2 (xor (boundKey min2) min1) n1 + goL2 _ _ _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 combine minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goL2 combine minV2 min1 n1 min2 l2 + EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of - Empty -> goL2 combine min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine min1 l1 min2 l2) r' + Empty -> goL2 combine minV2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of - Empty -> goL2 combine min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine min1 l1 min2 l2) r' - Just !maxV1' -> Bin max1 maxV1' (goL2 combine min1 l1 min2 l2) (goRFusedKeep combine max1 r1 r2) - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 - | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine max1 r1 max2 (Bin min2 dummyV l2 r2)) - | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of + Empty -> goL2 combine minV2 min1 l1 min2 l2 + NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' + Just !maxV1' -> Bin max1 maxV1' (goL2 combine minV2 min1 l1 min2 l2) (goRFusedKeep combine max1 r1 r2) + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 + | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' | otherwise -> case combine (boundKey max1) maxV1 maxV2 of - Nothing -> case goRFused combine max1 r1 (Bin min2 dummyV l2 r2) of + Nothing -> case goRFused combine max1 r1 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - Just !maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep combine max1 r1 (Bin min2 dummyV l2 r2)) + Just !maxV1' -> Bin max1 maxV1' l1 (goRFusedKeep combine max1 r1 (Bin min2 minV2 l2 r2)) goLFused _ !_ Tip !_ = Empty goLFused _ !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of DR min' minV' n' -> NonEmpty min' minV' n' goLFused combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFused combine min n1 l2 - EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine max1 r1 max2 r2)) + EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey max1) maxV1 maxV2 of Nothing -> binL (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 @@ -767,7 +767,7 @@ differenceWithKey = start goLFusedKeep _ !_ Tip !_ = Tip goLFusedKeep combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFusedKeep combine min n1 l2 - EQ | max1 > max2 -> Bin max1 maxV1 (goLFusedKeep combine min l1 l2) (goR2 combine max1 r1 max2 r2) + EQ | max1 > max2 -> Bin max1 maxV1 (goLFusedKeep combine min l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' @@ -783,49 +783,49 @@ differenceWithKey = start goR1 _ maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 goR1 combine maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 - | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine min1 (Bin max1 maxV1 l1 r1) min2 l2) + | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> l2rMap $ goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 Just !minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep combine min1 (Bin max1 maxV1 l1 r1) l2) - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) - goR2 _ !_ Tip !_ !_ = Tip - goR2 _ max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 - goR2 _ _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 - goR2 combine max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT -> goR2 combine max1 n1 max2 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 l2) (goR2 combine max1 r1 max2 r2) + goR2 _ _ !_ Tip !_ !_ = Tip + goR2 combine maxV2 max1 n1 max2 Tip = goDeleteR combine (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 + goR2 _ _ _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 combine maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + LT -> goR2 combine maxV2 max1 n1 max2 r2 + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of - Empty -> goR2 combine max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine max1 r1 max2 r2) + Empty -> goR2 combine maxV2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> case goLFused combine min1 l1 l2 of - Empty -> goR2 combine max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine max1 r1 max2 r2) - Just !minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goR2 combine max1 r1 max2 r2) - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 - | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 - | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of + Empty -> goR2 combine maxV2 max1 r1 max2 r2 + NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) + Just !minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine maxV2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 + | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 + | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 | otherwise -> case combine (boundKey min1) minV1 minV2 of - Nothing -> case goLFused combine min1 l1 (Bin max2 dummyV l2 r2) of + Nothing -> case goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - Just !minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 (Bin max2 dummyV l2 r2)) r1 + Just !minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 (Bin max2 maxV2 l2 r2)) r1 goRFused _ !_ Tip !_ = Empty goRFused _ !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of DR max' maxV' n' -> NonEmpty max' maxV' n' goRFused combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFused combine max n1 r2 - EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine min1 l1 min2 l2)) (goRFused combine max r1 r2) + EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goRFused combine max r1 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) | otherwise -> case combine (boundKey min1) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 @@ -836,7 +836,7 @@ differenceWithKey = start goRFusedKeep _ !_ Tip !_ = Tip goRFusedKeep combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFusedKeep combine max n1 r2 - EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine min1 l1 min2 l2) (goRFusedKeep combine max r1 r2) + EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goRFusedKeep combine max r1 r2) | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) @@ -867,7 +867,25 @@ differenceWithKey = start Just !v' -> NonEmpty (Bound k) v' Tip where xorCacheMin = xor k min - dummyV = error "impossible" + goDeleteL _ !_ _ !_ Tip = Tip + goDeleteL combine !k v !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goDeleteL combine k v xorCache l) r + | otherwise -> Bin max maxV l (goDeleteR combine k v xorCacheMax r) + OutOfBound -> n + Matched -> case combine k maxV v of + Nothing -> extractBinL l r + Just !maxV' -> Bin max maxV' l r + where xorCacheMax = xor k max + + goDeleteR _ !_ _ !_ Tip = Tip + goDeleteR combine !k v !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goDeleteR combine k v xorCache r) + | otherwise -> Bin min minV (goDeleteL combine k v xorCacheMin l) r + OutOfBound -> n + Matched -> case combine k minV v of + Nothing -> extractBinR l r + Just !minV' -> Bin min minV' l r + where xorCacheMin = xor k min -- | /O(n+m)/. The intersection with a combining function. -- From 535e44cbdcdb18b3f6855ed60cb5b82e197ef027 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 11 Jan 2020 14:50:26 -0600 Subject: [PATCH 101/147] Improve IntMap tests, using a faster 'sort'-based 'nub' and using '===', '.&&.', and 'conjoin' where possible --- containers-tests/tests/intmap-properties.hs | 216 ++++++++++---------- 1 file changed, 108 insertions(+), 108 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 6574b25ff..b8b1a4fea 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -262,17 +262,19 @@ type SMap = IntMap String ---------------------------------------------------------------- -tests :: [Test] -tests = [ testGroup "Test Case" [ - ] - , testGroup "Property Test" [ - ] - ] +-- | Like @'nub' . 'sort'@, but more efficient +sortNub :: Ord a => [a] -> [a] +sortNub = sortNubBy compare +sortNubBy :: (a -> a -> Ordering) -> [a] -> [a] +sortNubBy comp = fmap List.head . List.groupBy (\x y -> comp x y == EQ) . List.sortBy comp validProp :: IntMap a -> Property validProp = validWith (flip counterexample) (.&&.) +allProp :: Testable prop => (a -> prop) -> [a] -> Property +allProp f xs = conjoin (fmap f xs) + ---------------------------------------------------------------- -- Unit tests ---------------------------------------------------------------- @@ -1318,7 +1320,7 @@ prop_insertDelete k t = t' -> validProp t' .&&. t' === t prop_deleteNonMember :: Int -> UMap -> Property -prop_deleteNonMember k t = (lookup k t == Nothing) ==> (delete k t == t) +prop_deleteNonMember k t = notMember k t ==> (delete k t === t) ---------------------------------------------------------------- @@ -1327,16 +1329,16 @@ prop_unionModel xs ys = case union (fromList xs) (fromList ys) of t -> validProp t .&&. - sort (keys t) === sort (nub (Prelude.map fst xs ++ Prelude.map fst ys)) + keys t === sortNub (Prelude.map fst xs ++ Prelude.map fst ys) -prop_unionSingleton :: IMap -> Int -> Int -> Bool -prop_unionSingleton t k x = union (singleton k x) t == insert k x t +prop_unionSingleton :: IMap -> Int -> Int -> Property +prop_unionSingleton t k x = union (singleton k x) t === insert k x t -prop_unionAssoc :: IMap -> IMap -> IMap -> Bool -prop_unionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3 +prop_unionAssoc :: IMap -> IMap -> IMap -> Property +prop_unionAssoc t1 t2 t3 = union t1 (union t2 t3) === union (union t1 t2) t3 -prop_unionWith :: IMap -> IMap -> Bool -prop_unionWith t1 t2 = (union t1 t2 == unionWith (\_ y -> y) t2 t1) +prop_unionWith :: IMap -> IMap -> Property +prop_unionWith t1 t2 = union t1 t2 === unionWith (\_ y -> y) t2 t1 prop_unionSum :: [(Int,Int)] -> [(Int,Int)] -> Bool prop_unionSum xs ys @@ -1348,17 +1350,16 @@ prop_differenceModel xs ys = case difference (fromListWith (+) xs) (fromListWith (+) ys) of t -> validProp t .&&. - sort (keys t) === sort ((List.\\) - (nub (Prelude.map fst xs)) - (nub (Prelude.map fst ys))) + keys t === (List.\\) (sortNub (Prelude.map fst xs)) + (sortNub (Prelude.map fst ys)) prop_differenceWithKeyModel :: Fun (Int, Int, Int) (Maybe Int) -> [(Int,Int)] -> [(Int,Int)] -> Property prop_differenceWithKeyModel f xs ys = toList (differenceWithKey (\k x y -> apply f (k, x, y)) (fromList xs') (fromList ys')) === Maybe.mapMaybe diffSingle (sort xs') where - xs' = List.nubBy ((==) `on` fst) xs - ys' = List.nubBy ((==) `on` fst) ys + xs' = sortNubBy (compare `on` fst) xs + ys' = sortNubBy (compare `on` fst) ys diffSingle (k, x) = case List.lookup k ys' of Nothing -> Just (k, x) Just y -> fmap (\r -> (k, r)) (apply f (k, x, y)) @@ -1368,24 +1369,23 @@ prop_intersectionModel xs ys = case intersection (fromListWith (+) xs) (fromListWith (+) ys) of t -> validProp t .&&. - sort (keys t) === sort (nub ((List.intersect) - (Prelude.map fst xs) - (Prelude.map fst ys))) + keys t === (List.intersect) (sortNub (Prelude.map fst xs)) + (sortNub (Prelude.map fst ys)) -prop_intersectionWithModel :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_intersectionWithModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_intersectionWithModel xs ys = toList (intersectionWith f (fromList xs') (fromList ys')) - == [(kx, f vx vy ) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky] - where xs' = List.nubBy ((==) `on` fst) xs - ys' = List.nubBy ((==) `on` fst) ys + === [(kx, f vx vy ) | (kx, vx) <- xs', (ky, vy) <- ys', kx == ky] + where xs' = sortNubBy (compare `on` fst) xs + ys' = sortNubBy (compare `on` fst) ys f l r = l + 2 * r -prop_intersectionWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_intersectionWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_intersectionWithKeyModel xs ys = toList (intersectionWithKey f (fromList xs') (fromList ys')) - == [(kx, f kx vx vy) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky] - where xs' = List.nubBy ((==) `on` fst) xs - ys' = List.nubBy ((==) `on` fst) ys + === [(kx, f kx vx vy) | (kx, vx) <- xs', (ky, vy) <- ys', kx == ky] + where xs' = sortNubBy (compare `on` fst) xs + ys' = sortNubBy (compare `on` fst) ys f k l r = k + 2 * l + 3 * r prop_disjoint :: UMap -> UMap -> Property @@ -1407,20 +1407,20 @@ prop_withoutKeys m s0 = where s = keysSet s0 -prop_mergeWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_mergeWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_mergeWithKeyModel xs ys - = and [ testMergeWithKey f keep_x keep_y - | f <- [ \_k x1 _x2 -> Just x1 - , \_k _x1 x2 -> Just x2 - , \_k _x1 _x2 -> Nothing - , \k x1 x2 -> if k `mod` 2 == 0 then Nothing else Just (2 * x1 + 3 * x2) - ] - , keep_x <- [ True, False ] - , keep_y <- [ True, False ] - ] - - where xs' = List.nubBy ((==) `on` fst) xs - ys' = List.nubBy ((==) `on` fst) ys + = conjoin [ testMergeWithKey f keep_x keep_y + | f <- [ \_k x1 _x2 -> Just x1 + , \_k _x1 x2 -> Just x2 + , \_k _x1 _x2 -> Nothing + , \k x1 x2 -> if k `mod` 2 == 0 then Nothing else Just (2 * x1 + 3 * x2) + ] + , keep_x <- [ True, False ] + , keep_y <- [ True, False ] + ] + + where xs' = sortNubBy (compare `on` fst) xs + ys' = sortNubBy (compare `on` fst) ys xm = fromList xs' ym = fromList ys' @@ -1495,16 +1495,16 @@ prop_ordered :: Property prop_ordered = forAll (choose (5,100)) $ \n -> let xs = [(x,()) | x <- [0..n::Int]] - in fromAscList xs == fromList xs + in fromAscList xs === fromList xs -prop_list :: [Int] -> Bool -prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])]) +prop_list :: [Int] -> Property +prop_list xs = sortNub xs === [x | (x,()) <- toList (fromList [(x,()) | x <- xs])] -prop_descList :: [Int] -> Bool -prop_descList xs = (reverse (sort (nub xs)) == [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])]) +prop_descList :: [Int] -> Property +prop_descList xs = reverse (sortNub xs) === [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])] -prop_ascDescList :: [Int] -> Bool -prop_ascDescList xs = toAscList m == reverse (toDescList m) +prop_ascDescList :: [Int] -> Property +prop_ascDescList xs = toAscList m === reverse (toDescList m) where m = fromList $ zip xs $ repeat () prop_fromList :: [Int] -> Property @@ -1521,8 +1521,8 @@ prop_fromList xs prop_alter :: UMap -> Int -> Property prop_alter t k = validProp t' .&&. case lookup k t of - Just _ -> (size t - 1) == size t' && lookup k t' == Nothing - Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing + Just _ -> (size t - 1) === size t' .&&. lookup k t' === Nothing + Nothing -> (size t + 1) === size t' .&&. lookup k t' =/= Nothing where t' = alter f k t f Nothing = Just () @@ -1549,58 +1549,58 @@ prop_size im = sz === foldl' (\i _ -> i + 1) (0 :: Int) im .&&. sz === List.length (toList im) where sz = size im -prop_member :: [Int] -> Int -> Bool +prop_member :: [Int] -> Int -> Property prop_member xs n = let m = fromList (zip xs xs) - in all (\k -> k `member` m == (k `elem` xs)) (n : xs) + in allProp (\k -> k `member` m === (k `elem` xs)) (n : xs) -prop_notmember :: [Int] -> Int -> Bool +prop_notmember :: [Int] -> Int -> Property prop_notmember xs n = let m = fromList (zip xs xs) - in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs) + in allProp (\k -> k `notMember` m === (k `notElem` xs)) (n : xs) -prop_lookup :: [(Int, Int)] -> Int -> Bool +prop_lookup :: [(Int, Int)] -> Int -> Property prop_lookup xs n = - let xs' = List.nubBy ((==) `on` fst) xs + let xs' = sortNubBy (compare `on` fst) xs m = fromList xs' - in all (\k -> lookup k m == List.lookup k xs') (n : List.map fst xs') + in allProp (\k -> lookup k m === List.lookup k xs') (n : List.map fst xs') -prop_find :: [(Int, Int)] -> Bool +prop_find :: [(Int, Int)] -> Property prop_find xs = - let xs' = List.nubBy ((==) `on` fst) xs + let xs' = sortNubBy (compare `on` fst) xs m = fromList xs' - in all (\(k, v) -> m ! k == v) xs' + in allProp (\(k, v) -> m ! k === v) xs' -prop_findWithDefault :: [(Int, Int)] -> Int -> Int -> Bool +prop_findWithDefault :: [(Int, Int)] -> Int -> Int -> Property prop_findWithDefault xs n x = - let xs' = List.nubBy ((==) `on` fst) xs + let xs' = sortNubBy (compare `on` fst) xs m = fromList xs' - in all (\k -> findWithDefault x k m == maybe x id (List.lookup k xs')) (n : List.map fst xs') + in allProp (\k -> findWithDefault x k m === maybe x id (List.lookup k xs')) (n : List.map fst xs') -test_lookupSomething :: (Int -> IntMap Int -> Maybe (Int, Int)) -> (Int -> Int -> Bool) -> [(Int, Int)] -> Bool +test_lookupSomething :: (Int -> IntMap Int -> Maybe (Int, Int)) -> (Int -> Int -> Bool) -> [(Int, Int)] -> Property test_lookupSomething lookup' cmp xs = - let odd_sorted_xs = filter_odd $ sort $ List.nubBy ((==) `on` fst) xs + let odd_sorted_xs = filter_odd $ sortNubBy (compare `on` fst) xs t = fromList odd_sorted_xs test k = case List.filter ((`cmp` k) . fst) odd_sorted_xs of - [] -> lookup' k t == Nothing - cs | 0 `cmp` 1 -> lookup' k t == Just (last cs) -- we want largest such element - | otherwise -> lookup' k t == Just (head cs) -- we want smallest such element - in all test (List.map fst xs) + [] -> lookup' k t === Nothing + cs | 0 `cmp` 1 -> lookup' k t === Just (last cs) -- we want largest such element + | otherwise -> lookup' k t === Just (head cs) -- we want smallest such element + in allProp test (List.map fst xs) where filter_odd [] = [] filter_odd [_] = [] filter_odd (_ : o : xs) = o : filter_odd xs -prop_lookupLT :: [(Int, Int)] -> Bool +prop_lookupLT :: [(Int, Int)] -> Property prop_lookupLT = test_lookupSomething lookupLT (<) -prop_lookupGT :: [(Int, Int)] -> Bool +prop_lookupGT :: [(Int, Int)] -> Property prop_lookupGT = test_lookupSomething lookupGT (>) -prop_lookupLE :: [(Int, Int)] -> Bool +prop_lookupLE :: [(Int, Int)] -> Property prop_lookupLE = test_lookupSomething lookupLE (<=) -prop_lookupGE :: [(Int, Int)] -> Bool +prop_lookupGE :: [(Int, Int)] -> Property prop_lookupGE = test_lookupSomething lookupGE (>=) prop_lookupMin :: IntMap Int -> Property @@ -1617,26 +1617,26 @@ prop_findMax (NonEmptyIntMap im) = findMax im === head (toDescList im) prop_deleteMinModel :: [(Int, Int)] -> Property prop_deleteMinModel ys = length ys > 0 ==> - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = fromList xs - in toAscList (deleteMin m) == tail (sort xs) + in toAscList (deleteMin m) === tail (sort xs) prop_deleteMaxModel :: [(Int, Int)] -> Property prop_deleteMaxModel ys = length ys > 0 ==> - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = fromList xs - in toAscList (deleteMax m) == init (sort xs) + in toAscList (deleteMax m) === init (sort xs) prop_filter :: Fun Int Bool -> [(Int, Int)] -> Property prop_filter p ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = filter (apply p) (fromList xs) in validProp m .&&. m === fromList (List.filter (apply p . snd) xs) prop_partition :: Fun Int Bool -> [(Int, Int)] -> Property prop_partition p ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m@(l, r) = partition (apply p) (fromList xs) in validProp l .&&. validProp r .&&. @@ -1645,7 +1645,7 @@ prop_partition p ys = prop_partitionWithKey :: Fun (Int, Int) Bool -> [(Int, Int)] -> Property prop_partitionWithKey p ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m@(l, r) = partitionWithKey (curry (apply p)) (fromList xs) in validProp l .&&. validProp r .&&. @@ -1654,33 +1654,33 @@ prop_partitionWithKey p ys = prop_map :: Fun Int Int -> [(Int, Int)] -> Property prop_map f ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = fromList xs in map (apply f) m === fromList [ (a, apply f b) | (a,b) <- xs ] prop_fmap :: Fun Int Int -> [(Int, Int)] -> Property prop_fmap f ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = fromList xs in fmap (apply f) m === fromList [ (a, apply f b) | (a,b) <- xs ] prop_mapkeys :: Fun Int Int -> [(Int, Int)] -> Property prop_mapkeys f ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = fromList xs - in mapKeys (apply f) m === (fromList $ List.nubBy ((==) `on` fst) $ reverse [ (apply f a, b) | (a,b) <- sort xs]) + in mapKeys (apply f) m === (fromList $ sortNubBy (compare `on` fst) $ reverse [ (apply f a, b) | (a,b) <- xs]) prop_splitModel :: Int -> [(Int, Int)] -> Property prop_splitModel n ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys (l, r) = split n $ fromList xs in validProp l .&&. validProp r .&&. - toAscList l === sort [(k, v) | (k,v) <- xs, k < n] .&&. - toAscList r === sort [(k, v) | (k,v) <- xs, k > n] + toAscList l === takeWhile ((< n) . fst) xs .&&. + toAscList r === dropWhile ((<= n) . fst) xs -prop_splitRoot :: IMap -> Bool -prop_splitRoot s = loop ls && (s == unions ls) +prop_splitRoot :: IMap -> Property +prop_splitRoot s = loop ls .&&. (s === unions ls) where ls = splitRoot s loop [] = True @@ -1714,44 +1714,44 @@ prop_isProperSubmapOfBy p m1 m2 = increaseTests $ isProperSubmapOfBy (curry (app prop_foldr :: Int -> [(Int, Int)] -> Property prop_foldr n ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = fromList xs in foldr (+) n m === List.foldr (+) n (List.map snd xs) .&&. - foldr (:) [] m === List.map snd (List.sort xs) .&&. + foldr (:) [] m === List.map snd xs .&&. foldrWithKey (\_ a b -> a + b) n m === List.foldr (+) n (List.map snd xs) .&&. foldrWithKey (\k _ b -> k + b) n m === List.foldr (+) n (List.map fst xs) .&&. - foldrWithKey (\k x xs -> (k,x):xs) [] m === List.sort xs + foldrWithKey (\k x xs -> (k,x):xs) [] m === xs prop_foldr' :: Int -> [(Int, Int)] -> Property prop_foldr' n ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = fromList xs in foldr' (+) n m === List.foldr (+) n (List.map snd xs) .&&. - foldr' (:) [] m === List.map snd (List.sort xs) .&&. + foldr' (:) [] m === List.map snd xs .&&. foldrWithKey' (\_ a b -> a + b) n m === List.foldr (+) n (List.map snd xs) .&&. foldrWithKey' (\k _ b -> k + b) n m === List.foldr (+) n (List.map fst xs) .&&. - foldrWithKey' (\k x xs -> (k,x):xs) [] m === List.sort xs + foldrWithKey' (\k x xs -> (k,x):xs) [] m === xs prop_foldl :: Int -> [(Int, Int)] -> Property prop_foldl n ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = fromList xs in foldl (+) n m === List.foldr (+) n (List.map snd xs) .&&. - foldl (flip (:)) [] m === reverse (List.map snd (List.sort xs)) .&&. + foldl (flip (:)) [] m === reverse (List.map snd xs) .&&. foldlWithKey (\b _ a -> a + b) n m === List.foldr (+) n (List.map snd xs) .&&. foldlWithKey (\b k _ -> k + b) n m === List.foldr (+) n (List.map fst xs) .&&. - foldlWithKey (\xs k x -> (k,x):xs) [] m === reverse (List.sort xs) + foldlWithKey (\xs k x -> (k,x):xs) [] m === reverse xs prop_foldl' :: Int -> [(Int, Int)] -> Property prop_foldl' n ys = - let xs = List.nubBy ((==) `on` fst) ys + let xs = sortNubBy (compare `on` fst) ys m = fromList xs in foldl' (+) n m === List.foldr (+) n (List.map snd xs) .&&. - foldl' (flip (:)) [] m === reverse (List.map snd (List.sort xs)) .&&. + foldl' (flip (:)) [] m === reverse (List.map snd xs) .&&. foldlWithKey' (\b _ a -> a + b) n m === List.foldr (+) n (List.map snd xs) .&&. foldlWithKey' (\b k _ -> k + b) n m === List.foldr (+) n (List.map fst xs) .&&. - foldlWithKey' (\xs k x -> (k,x):xs) [] m === reverse (List.sort xs) + foldlWithKey' (\xs k x -> (k,x):xs) [] m === reverse xs prop_foldrEqFoldMap :: IntMap Int -> Property prop_foldrEqFoldMap m = @@ -1770,14 +1770,14 @@ prop_elem :: Int -> IMap -> Property prop_elem v m = Foldable.elem v m === List.elem v (elems m) #endif -prop_keysSet :: [(Int, Int)] -> Bool +prop_keysSet :: [(Int, Int)] -> Property prop_keysSet xs = - keysSet (fromList xs) == IntSet.fromList (List.map fst xs) + keysSet (fromList xs) === IntSet.fromList (List.map fst xs) -prop_fromSet :: [(Int, Int)] -> Bool +prop_fromSet :: [(Int, Int)] -> Property prop_fromSet ys = - let xs = List.nubBy ((==) `on` fst) ys - in fromSet (\k -> fromJust $ List.lookup k xs) (IntSet.fromList $ List.map fst xs) == fromList xs + let xs = sortNubBy (compare `on` fst) ys + in fromSet (\k -> fromJust $ List.lookup k xs) (IntSet.fromList $ List.map fst xs) === fromList xs prop_traverseWithKey_identity :: IntMap A -> Property prop_traverseWithKey_identity mp = mp === newMap From 814eb670ff87b399c346b793811aef935c3c63ed Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 11 Jan 2020 21:46:15 -0600 Subject: [PATCH 102/147] Handle zeros a bit more cleanly in bench-cmp.sh --- containers-tests/benchmarks/bench-cmp.pl | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/containers-tests/benchmarks/bench-cmp.pl b/containers-tests/benchmarks/bench-cmp.pl index 41d0959fd..10875c94f 100755 --- a/containers-tests/benchmarks/bench-cmp.pl +++ b/containers-tests/benchmarks/bench-cmp.pl @@ -23,7 +23,16 @@ $parts1[0] eq $parts2[0] or die "CSV files do not correspond -- $parts1[0] and $parts2[0]"; - my $factor = $parts2[1] / $parts1[1]; + my $factor; + if ($parts1[1] == 0) { + if ($parts2[1] == 0) { + $factor = 1; + } else { + $factor = 'inf'; + } + } else { + $factor = $parts2[1] / $parts1[1]; + } $count = $count + 1; $mult = $mult * $factor; if ($factor > $max) { @@ -33,7 +42,11 @@ $min = $factor; } - printf "%s;%+7.2f%%;%.2e\n", $parts1[0], 100 * $parts2[1] / $parts1[1] - 100, $parts1[1]; + if ($factor == 'inf') { + printf "%s;%.2e;%.2e\n", $parts1[0], $parts2[1], $parts1[1]; + } else { + printf "%s;%+7.2f%%;%.2e\n", $parts1[0], 100 * $factor - 100, $parts1[1]; + } } printf ";\n"; From 7ba86c8d7c0ed7d7fb3ba80e87c01429651d0c0a Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sun, 12 Jan 2020 12:42:24 -0600 Subject: [PATCH 103/147] Slightly simplify IntMap.Internal.compareMSB to not bother checking for equality. Benchmark changes are within measurement error bounds and probably meaningless. --- containers/src/Data/IntMap/Internal.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index a41cef9da..4cc3b4e55 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -2521,9 +2521,9 @@ ltMSB x y = x < y && x < Data.Bits.xor x y -- See 'ltMSB' for why this works {-# INLINE compareMSB #-} compareMSB :: Word -> Word -> Ordering -compareMSB x y = case compare x y of - LT | x < Data.Bits.xor x y -> LT - GT | y < Data.Bits.xor x y -> GT +compareMSB x y = case x < y of + True | x < Data.Bits.xor x y -> LT + False | y < Data.Bits.xor x y -> GT _ -> EQ {-# INLINE binL #-} From dc0ee84a8b383e4392c8a7520ee716d369a4d988 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sun, 12 Jan 2020 14:36:23 -0600 Subject: [PATCH 104/147] Manually worker-wrapper transform IntMap.{union,difference,intersection}WithKey to force them to leave integers unboxed --- containers/src/Data/IntMap/Internal.hs | 46 +++++++-- containers/src/Data/IntMap/Lazy.hs | 126 ++++++++++++++----------- containers/src/Data/IntMap/Strict.hs | 126 ++++++++++++++----------- 3 files changed, 181 insertions(+), 117 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 4cc3b4e55..de8c3c3a1 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP, BangPatterns, EmptyDataDecls #-} #if defined(__GLASGOW_HASKELL__) -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, MagicHash #-} #endif #include "containers.h" @@ -9,11 +9,7 @@ {-# LANGUAGE TypeFamilies #-} #endif #if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -#if USE_REWRITE_RULES {-# LANGUAGE Trustworthy #-} -#else -{-# LANGUAGE Safe #-} -#endif #endif {-# OPTIONS_HADDOCK not-home #-} @@ -309,6 +305,9 @@ module Data.IntMap.Internal ( -- ** Key Manipulation , Key + , UKey + , box + , unbox , Bound(..) , BoundOrdering(..) , xor @@ -472,6 +471,7 @@ import Data.Typeable import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType) import Text.Read +import GHC.Exts (Int(..), Int#) #endif #if __GLASGOW_HASKELL__ >= 708 import qualified Utils.Containers.Internal.IsList as IsList @@ -495,12 +495,40 @@ import Utils.Containers.Internal.StrictPair (StrictPair(..)) import Prelude hiding (foldr, foldl, filter, lookup, null, map, min, max) --- These two definitions are the only things defining that this map applies to 'Int' keys. Using --- 'Int8' or 'Word' or some other two's complement integer type would produce a working, equally --- efficient map from that type. +-- These definitions are the only things defining that this map applies to +-- 'Int' keys. Using 'Int8' or 'Word' or some other two's complement integer +-- type would produce a working, equally efficient map from that type. type Key = Int +#if defined(__GLASGOW_HASKELL__) +-- | An unboxed, unlifted version of 'Key', used for manual worker-wrapper +-- transformations. @WithKey@ functions, particularly those that call their +-- combination function on many keys, should be @INLINE@ and written in terms +-- of a @WithUKey@ variant where the combination function takes a 'UKey'. +type UKey = Int# + +-- | Convert a 'UKey' into the equivalent 'Key'. +box :: UKey -> Key +box = I# + +-- | Convert a 'Key' into the equivalent 'UKey'. +unbox :: Key -> UKey +unbox (I# x) = x +#else +-- | Under GHC, this would be used to force a worker-wrapper transformation on +-- @WithKey@ functions. However, since this compiler doesn't support unlifted +-- types, there is no way to do this manually. +type UKey = Key + +-- | Convert a 'UKey' into the equivalent 'Key'. +box :: UKey -> Key +box = id + +-- | Convert a 'Key' into the equivalent 'UKey'. +unbox :: Key -> UKey +unbox = id +#endif -i2w :: Int -> Word +i2w :: Key -> Word i2w = fromIntegral -- | Xor a key with a bound for the purposes of navigation within the tree. diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index d78ee30ed..7dbf143a9 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -522,15 +522,21 @@ unionWith f = unionWithKey (const f) -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] +{-# INLINE unionWithKey #-} unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWithKey = start +unionWithKey combine = unionWithUKey (\k a b -> combine (box k) a b) + +-- | /O(n+m)/. The union with a combining function taking an unboxed key. +-- Identical in functionality to 'unionWithKey'. +unionWithUKey :: (UKey -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWithUKey = start where start _ (IntMap Empty) m2 = m2 start _ m1 (IntMap Empty) = m1 start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 combine minV1 min1 root1 min2 root2)) - | otherwise = IntMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 goL1 _ minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip goL1 _ minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 @@ -540,10 +546,10 @@ unionWithKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) l2 (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) l2 (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 n2) r1 goL2 _ minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip @@ -554,10 +560,10 @@ unionWithKey = start GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) l1 (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) l1 (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 LT -> Bin max2 maxV2 (goL2 combine minV2 min1 n1 min2 l2) r2 -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same @@ -568,7 +574,7 @@ unionWithKey = start LT -> Bin max2 maxV2 (goLFused combine min n1 l2) r2 EQ | max1 > max2 -> Bin max1 maxV1 (goLFused combine min l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused combine min l1 n2) r1 goR1 _ maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip @@ -579,10 +585,10 @@ unionWithKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 combine maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 combine maxV1 max1 r1 max2 n2) goR2 _ maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip @@ -593,10 +599,10 @@ unionWithKey = start GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 LT -> Bin min2 minV2 l2 (goR2 combine maxV2 max1 n1 max2 r2) -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same @@ -607,7 +613,7 @@ unionWithKey = start LT -> Bin min2 minV2 l2 (goRFused combine max n1 r2) EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max r1 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goRFused combine max r1 n2) goInsertL1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip @@ -616,7 +622,7 @@ unionWithKey = start | otherwise -> Bin max maxV l (goInsertR1 combine k v xorCacheMax max r) OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - Matched -> Bin max (combine k v maxV) l r + Matched -> Bin max (combine (unbox k) v maxV) l r where xorCacheMax = xor k max goInsertR1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip @@ -625,7 +631,7 @@ unionWithKey = start | otherwise -> Bin min minV (goInsertL1 combine k v xorCacheMin min l) r OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - Matched -> Bin min (combine k v minV) l r + Matched -> Bin min (combine (unbox k) v minV) l r where xorCacheMin = xor k min goInsertL2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip @@ -634,7 +640,7 @@ unionWithKey = start | otherwise -> Bin max maxV l (goInsertR2 combine k v xorCacheMax max r) OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - Matched -> Bin max (combine k maxV v) l r + Matched -> Bin max (combine (unbox k) maxV v) l r where xorCacheMax = xor k max goInsertR2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip @@ -643,7 +649,7 @@ unionWithKey = start | otherwise -> Bin min minV (goInsertL2 combine k v xorCacheMin min l) r OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - Matched -> Bin min (combine k minV v) l r + Matched -> Bin min (combine (unbox k) minV v) l r where xorCacheMin = xor k min -- | The union of a list of maps, with a combining operation. @@ -669,15 +675,21 @@ differenceWith f = differenceWithKey (const f) -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) -- > == singleton 3 "3:b|B" +{-# INLINE differenceWithKey #-} differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWithKey = start +differenceWithKey combine = differenceWithUKey (\k a b -> combine (box k) a b) + +-- | /O(n+m)/. The difference with a combining function taking an unboxed +-- key. Identical in functionality to 'differenceWithKey'. +differenceWithUKey :: (UKey -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a +differenceWithUKey = start where start _ (IntMap Empty) !_ = IntMap Empty start _ !m (IntMap Empty) = m start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) - | otherwise = case combine (boundKey min1) minV1 minV2 of + | otherwise = case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> IntMap (goLFused combine min1 root1 root2) Just minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep combine min1 root1 root2)) @@ -688,12 +700,12 @@ differenceWithKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> r2lMap $ goRFused combine max1 (Bin min1 minV1 l1 r1) r2 Just maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep combine max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> binL (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) Just maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) @@ -707,7 +719,7 @@ differenceWithKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goL2 combine minV2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of Empty -> goL2 combine minV2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' @@ -717,7 +729,7 @@ differenceWithKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' @@ -730,7 +742,7 @@ differenceWithKey = start LT -> goLFused combine min n1 l2 EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> binL (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 Just maxV1' -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goLFused combine min l1 n2) (NonEmpty max1 maxV1 r1) @@ -743,7 +755,7 @@ differenceWithKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' @@ -757,12 +769,12 @@ differenceWithKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> l2rMap $ goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 Just minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep combine min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) @@ -776,7 +788,7 @@ differenceWithKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goR2 combine maxV2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> case goLFused combine min1 l1 l2 of Empty -> goR2 combine maxV2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) @@ -786,7 +798,7 @@ differenceWithKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> case goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 @@ -799,7 +811,7 @@ differenceWithKey = start LT -> goRFused combine max n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goRFused combine max r1 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goRFused combine max r1 r2) GT -> binR (NonEmpty min1 minV1 l1) (goRFused combine max r1 n2) @@ -812,7 +824,7 @@ differenceWithKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 Nothing -> case goLFused combine min1 l1 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) @@ -824,7 +836,7 @@ differenceWithKey = start InBound | xorCache < xorCacheMax -> goLookupL combine k v xorCache l | otherwise -> goLookupR combine k v xorCacheMax r OutOfBound -> NonEmpty (Bound k) v Tip - Matched -> case combine k v maxV of + Matched -> case combine (unbox k) v maxV of Nothing -> Empty Just v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max @@ -834,7 +846,7 @@ differenceWithKey = start InBound | xorCache < xorCacheMin -> goLookupR combine k v xorCache r | otherwise -> goLookupL combine k v xorCacheMin l OutOfBound -> NonEmpty (Bound k) v Tip - Matched -> case combine k v minV of + Matched -> case combine (unbox k) v minV of Nothing -> Empty Just v' -> NonEmpty (Bound k) v' Tip where xorCacheMin = xor k min @@ -844,7 +856,7 @@ differenceWithKey = start InBound | xorCache < xorCacheMax -> Bin max maxV (goDeleteL combine k v xorCache l) r | otherwise -> Bin max maxV l (goDeleteR combine k v xorCacheMax r) OutOfBound -> n - Matched -> case combine k maxV v of + Matched -> case combine (unbox k) maxV v of Nothing -> extractBinL l r Just maxV' -> Bin max maxV' l r where xorCacheMax = xor k max @@ -854,7 +866,7 @@ differenceWithKey = start InBound | xorCache < xorCacheMin -> Bin min minV l (goDeleteR combine k v xorCache r) | otherwise -> Bin min minV (goDeleteL combine k v xorCacheMin l) r OutOfBound -> n - Matched -> case combine k minV v of + Matched -> case combine (unbox k) minV v of Nothing -> extractBinR l r Just minV' -> Bin min minV' l r where xorCacheMin = xor k min @@ -869,15 +881,21 @@ intersectionWith f = intersectionWithKey (const f) -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" +{-# INLINE intersectionWithKey #-} intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey = start +intersectionWithKey combine = intersectionWithUKey (\k a b -> combine (box k) a b) + +-- | /O(n+m)/. The intersection with a combining function taking an unboxed +-- key. Identical in functionality to 'intersectionWithKey'. +intersectionWithUKey :: (UKey -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c +intersectionWithUKey = start where start _ (IntMap Empty) !_ = IntMap Empty start _ !_ (IntMap Empty) = IntMap Empty start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (goL2 combine minV2 min1 root1 min2 root2) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) - | otherwise = IntMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. @@ -888,12 +906,12 @@ intersectionWithKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) + | otherwise -> r2lMap $ NonEmpty max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goL1 combine minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused combine max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundKey max1) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) + Empty -> r2lMap (NonEmpty max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goRFused combine max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) GT -> goL1 combine minV1 min1 l1 min2 n2 goL2 _ _ !_ Tip !_ !_ = Empty @@ -904,12 +922,12 @@ intersectionWithKey = start EQ | max1 > max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goL2 combine minV2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused combine max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundKey max1) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) + Empty -> r2lMap (NonEmpty max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goRFused combine max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 combine minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 (combine (boundKey max1) maxV1 maxV2) (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) + | otherwise -> r2lMap $ NonEmpty max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) goLFused _ !_ Tip !_ = Tip goLFused _ !_ !_ Tip = Tip @@ -921,7 +939,7 @@ intersectionWithKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFused combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' - | otherwise -> Bin max1 (combine (boundKey max1) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> goLFused combine min l1 n2 goR1 _ _ !_ !_ !_ Tip = Empty @@ -931,12 +949,12 @@ intersectionWithKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) + | otherwise -> l2rMap $ NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goR1 combine maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) r') + Empty -> l2rMap (NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) r') GT -> goR1 combine maxV1 max1 r1 max2 n2 goR2 _ _ !_ Tip !_ !_ = Empty @@ -947,12 +965,12 @@ intersectionWithKey = start EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | otherwise -> case goR2 combine maxV2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) r') + Empty -> l2rMap (NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) r') GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 combine maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) + | otherwise -> l2rMap $ NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) goRFused _ !_ Tip !_ = Tip goRFused _ !_ !_ Tip = Tip @@ -964,7 +982,7 @@ intersectionWithKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFused combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) - | otherwise -> Bin min1 (combine (boundKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> goRFused combine max r1 n2 goLookupL1 _ !_ _ !_ Tip = Empty @@ -972,7 +990,7 @@ intersectionWithKey = start InBound | xorCache < xorCacheMax -> goLookupL1 combine k v xorCache l | otherwise -> goLookupR1 combine k v xorCacheMax r OutOfBound -> Empty - Matched -> NonEmpty (Bound k) (combine k v maxV) Tip + Matched -> NonEmpty (Bound k) (combine (unbox k) v maxV) Tip where xorCacheMax = xor k max goLookupR1 _ !_ _ !_ Tip = Empty @@ -980,7 +998,7 @@ intersectionWithKey = start InBound | xorCache < xorCacheMin -> goLookupR1 combine k v xorCache r | otherwise -> goLookupL1 combine k v xorCacheMin l OutOfBound -> Empty - Matched -> NonEmpty (Bound k) (combine k v minV) Tip + Matched -> NonEmpty (Bound k) (combine (unbox k) v minV) Tip where xorCacheMin = xor k min goLookupL2 _ !_ _ !_ Tip = Empty @@ -988,7 +1006,7 @@ intersectionWithKey = start InBound | xorCache < xorCacheMax -> goLookupL2 combine k v xorCache l | otherwise -> goLookupR2 combine k v xorCacheMax r OutOfBound -> Empty - Matched -> NonEmpty (Bound k) (combine k maxV v) Tip + Matched -> NonEmpty (Bound k) (combine (unbox k) maxV v) Tip where xorCacheMax = xor k max goLookupR2 _ !_ _ !_ Tip = Empty @@ -996,7 +1014,7 @@ intersectionWithKey = start InBound | xorCache < xorCacheMin -> goLookupR2 combine k v xorCache r | otherwise -> goLookupL2 combine k v xorCacheMin l OutOfBound -> Empty - Matched -> NonEmpty (Bound k) (combine k minV v) Tip + Matched -> NonEmpty (Bound k) (combine (unbox k) minV v) Tip where xorCacheMin = xor k min -- | /O(n+m)/. An unsafe general combining function. diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 2749f5850..5fa5625f4 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -550,15 +550,21 @@ unionWith f = unionWithKey (const f) -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] +{-# INLINE unionWithKey #-} unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a -unionWithKey = start +unionWithKey combine = unionWithUKey (\k a b -> combine (box k) a b) + +-- | /O(n+m)/. The union with a combining function taking an unboxed key. +-- Identical in functionality to 'unionWithKey'. +unionWithUKey :: (UKey -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionWithUKey = start where start _ (IntMap Empty) m2 = m2 start _ m1 (IntMap Empty) = m1 start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 combine minV1 min1 root1 min2 root2)) - | otherwise = IntMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 goL1 _ minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip goL1 _ minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 @@ -568,10 +574,10 @@ unionWithKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # l2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goL1 combine minV1 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goL1 combine minV1 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 n2) r1 goL2 _ minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip @@ -582,10 +588,10 @@ unionWithKey = start GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l1 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # l1 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goL2 combine minV2 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goL2 combine minV2 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 LT -> Bin max2 maxV2 (goL2 combine minV2 min1 n1 min2 l2) r2 -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same @@ -596,7 +602,7 @@ unionWithKey = start LT -> Bin max2 maxV2 (goLFused combine min n1 l2) r2 EQ | max1 > max2 -> Bin max1 maxV1 (goLFused combine min l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused combine min l1 n2) r1 goR1 _ maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip @@ -607,10 +613,10 @@ unionWithKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 combine maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goR1 combine maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # goR1 combine maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 combine maxV1 max1 r1 max2 n2) goR2 _ maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip @@ -621,10 +627,10 @@ unionWithKey = start GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goR2 combine maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # goR2 combine maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 LT -> Bin min2 minV2 l2 (goR2 combine maxV2 max1 n1 max2 r2) -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same @@ -635,7 +641,7 @@ unionWithKey = start LT -> Bin min2 minV2 l2 (goRFused combine max n1 r2) EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max r1 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goRFused combine max r1 n2) goInsertL1 _ k v !_ _ Tip = Bin (Bound k) #! v # Tip # Tip @@ -644,7 +650,7 @@ unionWithKey = start | otherwise -> Bin max maxV l (goInsertR1 combine k v xorCacheMax max r) OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - Matched -> Bin max #! combine k v maxV # l # r + Matched -> Bin max #! combine (unbox k) v maxV # l # r where xorCacheMax = xor k max goInsertR1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip @@ -653,7 +659,7 @@ unionWithKey = start | otherwise -> Bin min minV (goInsertL1 combine k v xorCacheMin min l) r OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - Matched -> Bin min #! combine k v minV # l # r + Matched -> Bin min #! combine (unbox k) v minV # l # r where xorCacheMin = xor k min goInsertL2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip @@ -662,7 +668,7 @@ unionWithKey = start | otherwise -> Bin max maxV l (goInsertR2 combine k v xorCacheMax max r) OutOfBound | xor (boundKey max) min < xorCacheMax -> Bin (Bound k) v (Bin max maxV l r) Tip | otherwise -> Bin (Bound k) v l (insertMaxR xorCacheMax max maxV r) - Matched -> Bin max #! combine k maxV v # l # r + Matched -> Bin max #! combine (unbox k) maxV v # l # r where xorCacheMax = xor k max goInsertR2 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip @@ -671,7 +677,7 @@ unionWithKey = start | otherwise -> Bin min minV (goInsertL2 combine k v xorCacheMin min l) r OutOfBound | xor (boundKey min) max < xorCacheMin -> Bin (Bound k) v Tip (Bin min minV l r) | otherwise -> Bin (Bound k) v (insertMinL xorCacheMin min minV l) r - Matched -> Bin min #! combine k minV v # l # r + Matched -> Bin min #! combine (unbox k) minV v # l # r where xorCacheMin = xor k min -- | The union of a list of maps, with a combining operation. @@ -697,15 +703,21 @@ differenceWith f = differenceWithKey (const f) -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) -- > == singleton 3 "3:b|B" +{-# INLINE differenceWithKey #-} differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a -differenceWithKey = start +differenceWithKey combine = differenceWithUKey (\k a b -> combine (box k) a b) + +-- | /O(n+m)/. The difference with a combining function taking an unboxed +-- key. Identical in functionality to 'differenceWithKey'. +differenceWithUKey :: (UKey -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a +differenceWithUKey = start where start _ (IntMap Empty) !_ = IntMap Empty start _ !m (IntMap Empty) = m start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) - | otherwise = case combine (boundKey min1) minV1 minV2 of + | otherwise = case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> IntMap (goLFused combine min1 root1 root2) Just !minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep combine min1 root1 root2)) @@ -716,12 +728,12 @@ differenceWithKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> r2lMap $ goRFused combine max1 (Bin min1 minV1 l1 r1) r2 Just !maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep combine max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> binL (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) Just !maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) @@ -735,7 +747,7 @@ differenceWithKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goL2 combine minV2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of Empty -> goL2 combine minV2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' @@ -745,7 +757,7 @@ differenceWithKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' @@ -758,7 +770,7 @@ differenceWithKey = start LT -> goLFused combine min n1 l2 EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> binL (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 Just !maxV1' -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goLFused combine min l1 n2) (NonEmpty max1 maxV1 r1) @@ -771,7 +783,7 @@ differenceWithKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' - | otherwise -> case combine (boundKey max1) maxV1 maxV2 of + | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' @@ -785,12 +797,12 @@ differenceWithKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> l2rMap $ goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 Just !minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep combine min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) @@ -804,7 +816,7 @@ differenceWithKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goR2 combine maxV2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> case goLFused combine min1 l1 l2 of Empty -> goR2 combine maxV2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) @@ -814,7 +826,7 @@ differenceWithKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> case goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 @@ -827,7 +839,7 @@ differenceWithKey = start LT -> goRFused combine max n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goRFused combine max r1 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goRFused combine max r1 r2) GT -> binR (NonEmpty min1 minV1 l1) (goRFused combine max r1 n2) @@ -840,7 +852,7 @@ differenceWithKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) - | otherwise -> case combine (boundKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 Nothing -> case goLFused combine min1 l1 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) @@ -852,7 +864,7 @@ differenceWithKey = start InBound | xorCache < xorCacheMax -> goLookupL combine k v xorCache l | otherwise -> goLookupR combine k v xorCacheMax r OutOfBound -> NonEmpty (Bound k) v Tip - Matched -> case combine k v maxV of + Matched -> case combine (unbox k) v maxV of Nothing -> Empty Just !v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max @@ -862,7 +874,7 @@ differenceWithKey = start InBound | xorCache < xorCacheMin -> goLookupR combine k v xorCache r | otherwise -> goLookupL combine k v xorCacheMin l OutOfBound -> NonEmpty (Bound k) v Tip - Matched -> case combine k v minV of + Matched -> case combine (unbox k) v minV of Nothing -> Empty Just !v' -> NonEmpty (Bound k) v' Tip where xorCacheMin = xor k min @@ -872,7 +884,7 @@ differenceWithKey = start InBound | xorCache < xorCacheMax -> Bin max maxV (goDeleteL combine k v xorCache l) r | otherwise -> Bin max maxV l (goDeleteR combine k v xorCacheMax r) OutOfBound -> n - Matched -> case combine k maxV v of + Matched -> case combine (unbox k) maxV v of Nothing -> extractBinL l r Just !maxV' -> Bin max maxV' l r where xorCacheMax = xor k max @@ -882,7 +894,7 @@ differenceWithKey = start InBound | xorCache < xorCacheMin -> Bin min minV l (goDeleteR combine k v xorCache r) | otherwise -> Bin min minV (goDeleteL combine k v xorCacheMin l) r OutOfBound -> n - Matched -> case combine k minV v of + Matched -> case combine (unbox k) minV v of Nothing -> extractBinR l r Just !minV' -> Bin min minV' l r where xorCacheMin = xor k min @@ -897,15 +909,21 @@ intersectionWith f = intersectionWithKey (const f) -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" +{-# INLINE intersectionWithKey #-} intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey = start +intersectionWithKey combine = intersectionWithUKey (\k a b -> combine (box k) a b) + +-- | /O(n+m)/. The intersection with a combining function taking an unboxed +-- key. Identical in functionality to 'intersectionWithKey'. +intersectionWithUKey :: (UKey -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c +intersectionWithUKey = start where start _ (IntMap Empty) !_ = IntMap Empty start _ !_ (IntMap Empty) = IntMap Empty start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (goL2 combine minV2 min1 root1 min2 root2) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) - | otherwise = IntMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. @@ -916,12 +934,12 @@ intersectionWithKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 + | otherwise -> r2lMap $ NonEmpty max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goL1 combine minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused combine max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) + Empty -> r2lMap (NonEmpty max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goRFused combine max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) GT -> goL1 combine minV1 min1 l1 min2 n2 goL2 _ _ !_ Tip !_ !_ = Empty @@ -932,12 +950,12 @@ intersectionWithKey = start EQ | max1 > max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goL2 combine minV2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused combine max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundKey max1) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) + Empty -> r2lMap (NonEmpty max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goRFused combine max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 combine minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundKey max1) maxV1 maxV2 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) goLFused _ !_ Tip !_ = Tip goLFused _ !_ !_ Tip = Tip @@ -949,7 +967,7 @@ intersectionWithKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFused combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' - | otherwise -> Bin max1 #! combine (boundKey max1) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> goLFused combine min l1 n2 goR1 _ _ !_ !_ !_ Tip = Empty @@ -959,12 +977,12 @@ intersectionWithKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 + | otherwise -> l2rMap $ NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goR1 combine maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # r') + Empty -> l2rMap (NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # r') GT -> goR1 combine maxV1 max1 r1 max2 n2 goR2 _ _ !_ Tip !_ !_ = Empty @@ -975,12 +993,12 @@ intersectionWithKey = start EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | otherwise -> case goR2 combine maxV2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # r') + Empty -> l2rMap (NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # r') GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 combine maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) goRFused _ !_ Tip !_ = Tip goRFused _ !_ !_ Tip = Tip @@ -992,7 +1010,7 @@ intersectionWithKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFused combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) - | otherwise -> Bin min1 #! combine (boundKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> goRFused combine max r1 n2 goLookupL1 _ !_ _ !_ Tip = Empty @@ -1000,7 +1018,7 @@ intersectionWithKey = start InBound | xorCache < xorCacheMax -> goLookupL1 combine k v xorCache l | otherwise -> goLookupR1 combine k v xorCacheMax r OutOfBound -> Empty - Matched -> NonEmpty (Bound k) #! combine k v maxV # Tip + Matched -> NonEmpty (Bound k) #! combine (unbox k) v maxV # Tip where xorCacheMax = xor k max goLookupR1 _ !_ _ !_ Tip = Empty @@ -1008,7 +1026,7 @@ intersectionWithKey = start InBound | xorCache < xorCacheMin -> goLookupR1 combine k v xorCache r | otherwise -> goLookupL1 combine k v xorCacheMin l OutOfBound -> Empty - Matched -> NonEmpty (Bound k) #! combine k v minV # Tip + Matched -> NonEmpty (Bound k) #! combine (unbox k) v minV # Tip where xorCacheMin = xor k min goLookupL2 _ !_ _ !_ Tip = Empty @@ -1016,7 +1034,7 @@ intersectionWithKey = start InBound | xorCache < xorCacheMax -> goLookupL2 combine k v xorCache l | otherwise -> goLookupR2 combine k v xorCacheMax r OutOfBound -> Empty - Matched -> NonEmpty (Bound k) #! combine k maxV v # Tip + Matched -> NonEmpty (Bound k) #! combine (unbox k) maxV v # Tip where xorCacheMax = xor k max goLookupR2 _ !_ _ !_ Tip = Empty @@ -1024,7 +1042,7 @@ intersectionWithKey = start InBound | xorCache < xorCacheMin -> goLookupR2 combine k v xorCache r | otherwise -> goLookupL2 combine k v xorCacheMin l OutOfBound -> Empty - Matched -> NonEmpty (Bound k) #! combine k minV v # Tip + Matched -> NonEmpty (Bound k) #! combine (unbox k) minV v # Tip where xorCacheMin = xor k min -- | /O(n+m)/. An unsafe general combining function. From a1827a83ae97e18c812f081992b100ec63db83c8 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 13 Jan 2020 00:00:40 -0600 Subject: [PATCH 105/147] Be explicitly strict in `IntMap.difference*` --- containers/src/Data/IntMap/Internal.hs | 40 +++++++++++------------ containers/src/Data/IntMap/Lazy.hs | 44 +++++++++++++------------- containers/src/Data/IntMap/Strict.hs | 44 +++++++++++++------------- 3 files changed, 64 insertions(+), 64 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index de8c3c3a1..869556707 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1427,10 +1427,10 @@ difference = start | min1 > min2 = IntMap (goL1 minV1 min1 root1 min2 root2) | otherwise = IntMap (goLFused min1 root1 root2) - goL1 minV1 min1 Tip min2 n2 = goLookupL (boundKey min1) minV1 (xor (boundKey min1) min2) n2 - goL1 minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 - goL1 minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goL1 minV1 !min1 Tip !min2 !n2 = goLookupL (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 minV1 !min1 !n1 !_ Tip = NonEmpty min1 minV1 n1 + goL1 minV1 !min1 n1@(Bin _ _ _ _) !_ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 + goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 @@ -1440,10 +1440,10 @@ difference = start | otherwise -> binL (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) GT -> binL (goL1 minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) - goL2 !_ Tip !_ !_ = Tip - goL2 min1 n1 min2 Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 - goL2 _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 - goL2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goL2 !_ Tip !_ !_ = Tip + goL2 !min1 !n1 !min2 !Tip = deleteL (boundKey min2) (xor (boundKey min2) min1) n1 + goL2 !_ n1@(Bin max1 _ _ _) !min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 min1 n1 min2 l2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of @@ -1471,10 +1471,10 @@ difference = start | otherwise -> binL (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> binL (goLFused min l1 n2) (NonEmpty max1 maxV1 r1) - goR1 maxV1 max1 Tip max2 n2 = goLookupR (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 - goR1 maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 - goR1 maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goR1 maxV1 !max1 Tip !max2 !n2 = goLookupR (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 maxV1 !max1 !n1 !_ Tip = NonEmpty max1 maxV1 n1 + goR1 maxV1 !max1 n1@(Bin _ _ _ _) !_ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 + goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 @@ -1484,10 +1484,10 @@ difference = start | otherwise -> binR (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 maxV1 max1 r1 max2 n2) - goR2 !_ Tip !_ !_ = Tip - goR2 max1 n1 max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 - goR2 _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 - goR2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goR2 !_ Tip !_ !_ = Tip + goR2 !max1 !n1 !max2 Tip = deleteR (boundKey max2) (xor (boundKey max2) max1) n1 + goR2 !_ n1@(Bin min1 _ _ _) !max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 max1 n1 max2 r2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of @@ -1515,16 +1515,16 @@ difference = start | otherwise -> binR (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> binR (NonEmpty min1 minV1 l1) (goRFused max r1 n2) - goLookupL k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupL k v !xorCache (Bin max _ l r) = case compareMaxBound k max of + goLookupL !k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupL !k v !xorCache (Bin max _ l r) = case compareMaxBound k max of InBound | xorCache < xorCacheMax -> goLookupL k v xorCache l | otherwise -> goLookupR k v xorCacheMax r OutOfBound -> NonEmpty (Bound k) v Tip Matched -> Empty where xorCacheMax = xor k max - goLookupR k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupR k v !xorCache (Bin min _ l r) = case compareMinBound k min of + goLookupR !k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupR !k v !xorCache (Bin min _ l r) = case compareMinBound k min of InBound | xorCache < xorCacheMin -> goLookupR k v xorCache r | otherwise -> goLookupL k v xorCacheMin l OutOfBound -> NonEmpty (Bound k) v Tip diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 7dbf143a9..621aea565 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -693,10 +693,10 @@ differenceWithUKey = start Nothing -> IntMap (goLFused combine min1 root1 root2) Just minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep combine min1 root1 root2)) - goL1 combine minV1 min1 Tip min2 n2 = goLookupL combine (boundKey min1) minV1 (xor (boundKey min1) min2) n2 - goL1 _ minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 - goL1 _ minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 - goL1 combine minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goL1 combine minV1 !min1 Tip !min2 !n2 = goLookupL combine (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 _ minV1 !min1 !n1 !_ Tip = NonEmpty min1 minV1 n1 + goL1 _ minV1 !min1 n1@(Bin _ _ _ _) !_ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 + goL1 combine minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 @@ -710,10 +710,10 @@ differenceWithUKey = start Just maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) - goL2 _ _ !_ Tip !_ !_ = Tip - goL2 combine minV2 min1 n1 min2 Tip = goDeleteL combine (boundKey min2) minV2 (xor (boundKey min2) min1) n1 - goL2 _ _ _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 - goL2 combine minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goL2 _ _ !_ Tip !_ !_ = Tip + goL2 combine minV2 !min1 !n1 !min2 Tip = goDeleteL combine (boundKey min2) minV2 (xor (boundKey min2) min1) n1 + goL2 _ _ !_ n1@(Bin max1 _ _ _) !min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 combine minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 combine minV2 min1 n1 min2 l2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of @@ -747,7 +747,7 @@ differenceWithUKey = start Just maxV1' -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goLFused combine min l1 n2) (NonEmpty max1 maxV1 r1) - goLFusedKeep _ !_ n1 Tip = n1 + goLFusedKeep _ !_ !n1 Tip = n1 goLFusedKeep _ !_ Tip !_ = Tip goLFusedKeep combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFusedKeep combine min n1 l2 @@ -762,10 +762,10 @@ differenceWithUKey = start Just maxV1' -> Bin max1 maxV1' (goLFusedKeep combine min l1 l2) (goRFusedKeep combine max1 r1 r2) GT -> Bin max1 maxV1 (goLFusedKeep combine min l1 n2) r1 - goR1 combine maxV1 max1 Tip max2 n2 = goLookupR combine (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 - goR1 _ maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 - goR1 _ maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 - goR1 combine maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goR1 combine maxV1 !max1 Tip !max2 !n2 = goLookupR combine (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 _ maxV1 !max1 !n1 !_ Tip = NonEmpty max1 maxV1 n1 + goR1 _ maxV1 !max1 n1@(Bin _ _ _ _) !_ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 + goR1 combine maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 @@ -779,10 +779,10 @@ differenceWithUKey = start Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) - goR2 _ _ !_ Tip !_ !_ = Tip - goR2 combine maxV2 max1 n1 max2 Tip = goDeleteR combine (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 - goR2 _ _ _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 - goR2 combine maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goR2 _ _ !_ Tip !_ !_ = Tip + goR2 combine maxV2 !max1 !n1 !max2 Tip = goDeleteR combine (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 + goR2 _ _ !_ n1@(Bin min1 _ _ _) !max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 combine maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 combine maxV2 max1 n1 max2 r2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of @@ -816,7 +816,7 @@ differenceWithUKey = start Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goRFused combine max r1 r2) GT -> binR (NonEmpty min1 minV1 l1) (goRFused combine max r1 n2) - goRFusedKeep _ !_ n1 Tip = n1 + goRFusedKeep _ !_ !n1 Tip = n1 goRFusedKeep _ !_ Tip !_ = Tip goRFusedKeep combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFusedKeep combine max n1 r2 @@ -831,8 +831,8 @@ differenceWithUKey = start Just minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goRFusedKeep combine max r1 r2) GT -> Bin min1 minV1 l1 (goRFusedKeep combine max r1 n2) - goLookupL _ k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupL combine k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + goLookupL _ !k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupL combine !k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of InBound | xorCache < xorCacheMax -> goLookupL combine k v xorCache l | otherwise -> goLookupR combine k v xorCacheMax r OutOfBound -> NonEmpty (Bound k) v Tip @@ -841,8 +841,8 @@ differenceWithUKey = start Just v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max - goLookupR _ k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupR combine k v !xorCache (Bin min minV l r) = case compareMinBound k min of + goLookupR _ !k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupR combine !k v !xorCache (Bin min minV l r) = case compareMinBound k min of InBound | xorCache < xorCacheMin -> goLookupR combine k v xorCache r | otherwise -> goLookupL combine k v xorCacheMin l OutOfBound -> NonEmpty (Bound k) v Tip diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 5fa5625f4..3687cb12c 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -721,10 +721,10 @@ differenceWithUKey = start Nothing -> IntMap (goLFused combine min1 root1 root2) Just !minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep combine min1 root1 root2)) - goL1 combine minV1 min1 Tip min2 n2 = goLookupL combine (boundKey min1) minV1 (xor (boundKey min1) min2) n2 - goL1 _ minV1 min1 n1 _ Tip = NonEmpty min1 minV1 n1 - goL1 _ minV1 min1 n1@(Bin _ _ _ _) _ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 - goL1 combine minV1 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goL1 combine minV1 !min1 Tip !min2 !n2 = goLookupL combine (boundKey min1) minV1 (xor (boundKey min1) min2) n2 + goL1 _ minV1 !min1 !n1 !_ Tip = NonEmpty min1 minV1 n1 + goL1 _ minV1 !min1 n1@(Bin _ _ _ _) !_ (Bin max2 _ _ _) | boundsDisjoint min1 max2 = NonEmpty min1 minV1 n1 + goL1 combine minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 @@ -738,10 +738,10 @@ differenceWithUKey = start Just !maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) - goL2 _ _ !_ Tip !_ !_ = Tip - goL2 combine minV2 min1 n1 min2 Tip = goDeleteL combine (boundKey min2) minV2 (xor (boundKey min2) min1) n1 - goL2 _ _ _ n1@(Bin max1 _ _ _) min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 - goL2 combine minV2 min1 n1@(Bin max1 maxV1 l1 r1) min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goL2 _ _ !_ Tip !_ !_ = Tip + goL2 combine minV2 !min1 !n1 !min2 Tip = goDeleteL combine (boundKey min2) minV2 (xor (boundKey min2) min1) n1 + goL2 _ _ !_ n1@(Bin max1 _ _ _) !min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 + goL2 combine minV2 1min1 n1@(Bin max1 maxV1 l1 r1)! min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 combine minV2 min1 n1 min2 l2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of @@ -775,7 +775,7 @@ differenceWithUKey = start Just !maxV1' -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goLFused combine min l1 n2) (NonEmpty max1 maxV1 r1) - goLFusedKeep _ !_ n1 Tip = n1 + goLFusedKeep _ !_ !n1 Tip = n1 goLFusedKeep _ !_ Tip !_ = Tip goLFusedKeep combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFusedKeep combine min n1 l2 @@ -790,10 +790,10 @@ differenceWithUKey = start Just !maxV1' -> Bin max1 maxV1' (goLFusedKeep combine min l1 l2) (goRFusedKeep combine max1 r1 r2) GT -> Bin max1 maxV1 (goLFusedKeep combine min l1 n2) r1 - goR1 combine maxV1 max1 Tip max2 n2 = goLookupR combine (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 - goR1 _ maxV1 max1 n1 _ Tip = NonEmpty max1 maxV1 n1 - goR1 _ maxV1 max1 n1@(Bin _ _ _ _) _ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 - goR1 combine maxV1 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goR1 combine maxV1 !max1 Tip !max2 !n2 = goLookupR combine (boundKey max1) maxV1 (xor (boundKey max1) max2) n2 + goR1 _ maxV1 !max1 !n1 !_ Tip = NonEmpty max1 maxV1 n1 + goR1 _ maxV1 !max1 n1@(Bin _ _ _ _) !_ (Bin min2 _ _ _) | boundsDisjoint min2 max1 = NonEmpty max1 maxV1 n1 + goR1 combine maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 @@ -807,10 +807,10 @@ differenceWithUKey = start Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) - goR2 _ _ !_ Tip !_ !_ = Tip - goR2 combine maxV2 max1 n1 max2 Tip = goDeleteR combine (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 - goR2 _ _ _ n1@(Bin min1 _ _ _) max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 - goR2 combine maxV2 max1 n1@(Bin min1 minV1 l1 r1) max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goR2 _ _ !_ Tip !_ !_ = Tip + goR2 combine maxV2 !max1 !n1 !max2 Tip = goDeleteR combine (boundKey max2) maxV2 (xor (boundKey max2) max1) n1 + goR2 _ _ !_ n1@(Bin min1 _ _ _) !max2 (Bin _ _ _ _) | boundsDisjoint min1 max2 = n1 + goR2 combine maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 combine maxV2 max1 n1 max2 r2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of @@ -844,7 +844,7 @@ differenceWithUKey = start Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goRFused combine max r1 r2) GT -> binR (NonEmpty min1 minV1 l1) (goRFused combine max r1 n2) - goRFusedKeep _ !_ n1 Tip = n1 + goRFusedKeep _ !_ !n1 Tip = n1 goRFusedKeep _ !_ Tip !_ = Tip goRFusedKeep combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFusedKeep combine max n1 r2 @@ -859,8 +859,8 @@ differenceWithUKey = start Just !minV1' -> Bin min1 minV1' (goLFusedKeep combine min1 l1 l2) (goRFusedKeep combine max r1 r2) GT -> Bin min1 minV1 l1 (goRFusedKeep combine max r1 n2) - goLookupL _ k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupL combine k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of + goLookupL _ !k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupL combine !k v !xorCache (Bin max maxV l r) = case compareMaxBound k max of InBound | xorCache < xorCacheMax -> goLookupL combine k v xorCache l | otherwise -> goLookupR combine k v xorCacheMax r OutOfBound -> NonEmpty (Bound k) v Tip @@ -869,8 +869,8 @@ differenceWithUKey = start Just !v' -> NonEmpty (Bound k) v' Tip where xorCacheMax = xor k max - goLookupR _ k v !_ Tip = NonEmpty (Bound k) v Tip - goLookupR combine k v !xorCache (Bin min minV l r) = case compareMinBound k min of + goLookupR _ !k v !_ Tip = NonEmpty (Bound k) v Tip + goLookupR combine !k v !xorCache (Bin min minV l r) = case compareMinBound k min of InBound | xorCache < xorCacheMin -> goLookupR combine k v xorCache r | otherwise -> goLookupL combine k v xorCacheMin l OutOfBound -> NonEmpty (Bound k) v Tip From ba7441351ee93ce0e9a5a953469b7549a7c43613 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 13 Jan 2020 01:34:02 -0600 Subject: [PATCH 106/147] Fix IntMap.Strict.differenceWith typo --- containers/src/Data/IntMap/Strict.hs | 2 +- containers/src/Data/Map/Lazy.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 3687cb12c..70b68edaa 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -741,7 +741,7 @@ differenceWithUKey = start goL2 _ _ !_ Tip !_ !_ = Tip goL2 combine minV2 !min1 !n1 !min2 Tip = goDeleteL combine (boundKey min2) minV2 (xor (boundKey min2) min1) n1 goL2 _ _ !_ n1@(Bin max1 _ _ _) !min2 (Bin _ _ _ _) | boundsDisjoint min2 max1 = n1 - goL2 combine minV2 1min1 n1@(Bin max1 maxV1 l1 r1)! min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of + goL2 combine minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 combine minV2 min1 n1 min2 l2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of diff --git a/containers/src/Data/Map/Lazy.hs b/containers/src/Data/Map/Lazy.hs index 37ae931e6..504a4384d 100644 --- a/containers/src/Data/Map/Lazy.hs +++ b/containers/src/Data/Map/Lazy.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} #endif #include "containers.h" From 01dd1c5d27e131f91b5b73ca3dda8486cd97e6e4 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Mon, 13 Jan 2020 02:08:59 -0600 Subject: [PATCH 107/147] Undo unintended change --- containers/src/Data/Map/Lazy.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/containers/src/Data/Map/Lazy.hs b/containers/src/Data/Map/Lazy.hs index 504a4384d..37ae931e6 100644 --- a/containers/src/Data/Map/Lazy.hs +++ b/containers/src/Data/Map/Lazy.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} #endif #include "containers.h" From ea2702a03cd672a82613f0a320b0415761362e16 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 14 Jan 2020 11:20:15 -0600 Subject: [PATCH 108/147] Improve deletion-related documentation --- containers/src/Data/IntMap/Internal.hs | 185 +++++++++++++++---------- containers/src/Data/IntMap/Lazy.hs | 4 +- containers/src/Data/IntMap/Strict.hs | 4 +- 3 files changed, 118 insertions(+), 75 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 869556707..c6b311525 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -299,9 +299,9 @@ module Data.IntMap.Internal ( -- * Map Types IntMap(..) , L, R - , Node(..) , IntMap_(..) - , DeleteResult(..) + , Node(..) + , NonEmptyIntMap_(..) -- ** Key Manipulation , Key @@ -697,6 +697,29 @@ data IntMap_ t a = NonEmpty {-# UNPACK #-} !(Bound t) a !(Node t a) | Empty deri -- and can instead pass the xor-distance between that key and the missing bound. data Node t a = Bin {-# UNPACK #-} !(Bound (Flipped t)) a !(Node L a) !(Node R a) | Tip deriving (Eq, Show) +-- | The non-empty case of 'IntMap_'. +-- +-- Although this may be exposed and used for its own sake (TODO: make 'IntMap_' +-- contain an @UNPACK@ed 'NonEmptyIntMap_' field instead of copy-pasting +-- fields between the two structures), its primary function currently is as an +-- intermediate in routines that involve deletion. +-- +-- A 'Node' is largely meaningless without the context of one external bound +-- (minima for 'L' nodes and maxima for 'R' nodes). When that external bound +-- gets deleted, the 'Node' needs to be rearranged, with a new bouond pulled +-- up and out to the top level. This transformation is implemented in +-- 'deleteMinL' for when the minimum bound is gone and in 'deleteMaxR' when +-- the minimum bound is gone. Although a 'Node' could be 'Tip' and so would +-- most naturally be turned into a possibly-empty 'IntMap_' (and this is what +-- 'nodeToMapL' and 'nodeToMapR' do), it is important to use a product type for +-- the intermediates in the recursive case so that GHC's constructed product +-- result analysis (CPR) can unpack the 'NonEmptyIntMap_' into multiple +-- returned values on the stack. +-- +-- See 'IntMap_' for further discussion of the tag type parameter and the +-- invariants that must hold for this structure. +data NonEmptyIntMap_ t a = NE {-# UNPACK #-} !(Bound t) a !(Node t a) + #if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Eq1 IntMap where @@ -1251,10 +1274,33 @@ delete !k m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of OutOfBound -> m Matched -> IntMap (nodeToMapL root) --- | Without this specialized type (I was just using a tuple), GHC's --- CPR correctly unboxed the tuple, but it couldn't unbox the returned --- Key, leading to lots of inefficiency (3x slower than stock Data.IntMap) -data DeleteResult t a = DR {-# UNPACK #-} !(Bound t) a !(Node t a) +-- | Delete a key from a left node. Takes the xor of the deleted key and +-- the minimum bound of that node. +-- +-- This would normally be a local method of 'delete', but it can be reused in +-- other places. +deleteL :: Key -> Word -> Node L a -> Node L a +deleteL !_ !_ Tip = Tip +deleteL !k !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (deleteL k xorCache l) r + | otherwise -> Bin max maxV l (deleteR k xorCacheMax r) + OutOfBound -> n + Matched -> extractBinL l r + where xorCacheMax = xor k max + +-- | Delete a key from a right node. Takes the xor of the deleted key and +-- the maximum bound of that node. +-- +-- This would normally be a local method of 'delete', but it can be reused in +-- other places. +deleteR :: Key -> Word -> Node R a -> Node R a +deleteR !_ !_ Tip = Tip +deleteR !k !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (deleteR k xorCache r) + | otherwise -> Bin min minV (deleteL k xorCacheMin l) r + OutOfBound -> n + Matched -> extractBinR l r + where xorCacheMin = xor k min -- | /O(n+m)/. The (left-biased) union of two maps. -- It prefers the first map when duplicate keys are encountered, @@ -1463,7 +1509,7 @@ difference = start goLFused !_ Tip !_ = Empty goLFused !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of - DR min' minV' n' -> NonEmpty min' minV' n' + NE min' minV' n' -> NonEmpty min' minV' n' goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFused min n1 l2 EQ | max1 > max2 -> binL (goLFused min l1 l2) (NonEmpty max1 maxV1 (goR2 max1 r1 max2 r2)) @@ -1507,7 +1553,7 @@ difference = start goRFused !_ Tip !_ = Empty goRFused !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of - DR max' maxV' n' -> NonEmpty max' maxV' n' + NE max' maxV' n' -> NonEmpty max' maxV' n' goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFused max n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 min1 l1 min2 l2)) (goRFused max r1 r2) @@ -2178,29 +2224,29 @@ splitLookup !k = start InBound -> case root of Tip -> (m, Nothing, IntMap Empty) Bin max maxV l r -> case compareMaxBound k max of - InBound -> let (DR glb glbV lt, eq, DR lub lubV gt) = go (xor k min) min minV (xor k max) max maxV l r + InBound -> let (NE glb glbV lt, eq, NE lub lubV gt) = go (xor k min) min minV (xor k max) max maxV l r in (IntMap (r2lMap (NonEmpty glb glbV lt)), eq, IntMap (NonEmpty lub lubV gt)) OutOfBound -> (m, Nothing, IntMap Empty) - Matched -> let DR max' maxV' root' = deleteMaxR min minV l r + Matched -> let NE max' maxV' root' = deleteMaxR min minV l r in (IntMap (r2lMap (NonEmpty max' maxV' root')), Just maxV, IntMap Empty) OutOfBound -> (IntMap Empty, Nothing, m) Matched -> (IntMap Empty, Just minV, IntMap (nodeToMapL root)) go xorCacheMin min minV xorCacheMax max maxV l r | xorCacheMin < xorCacheMax = case l of - Tip -> (DR (minToMax min) minV Tip, Nothing, r2lDR (DR max maxV r)) + Tip -> (NE (minToMax min) minV Tip, Nothing, r2lNE (NE max maxV r)) Bin maxI maxVI lI rI -> case compareMaxBound k maxI of - InBound -> let (lt, eq, DR minI minVI gt) = go xorCacheMin min minV (xor k maxI) maxI maxVI lI rI - in (lt, eq, DR minI minVI (Bin max maxV gt r)) - OutOfBound -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) - Matched -> (deleteMaxR min minV lI rI, Just maxVI, r2lDR (DR max maxV r)) + InBound -> let (lt, eq, NE minI minVI gt) = go xorCacheMin min minV (xor k maxI) maxI maxVI lI rI + in (lt, eq, NE minI minVI (Bin max maxV gt r)) + OutOfBound -> (l2rNE (NE min minV l), Nothing, r2lNE (NE max maxV r)) + Matched -> (deleteMaxR min minV lI rI, Just maxVI, r2lNE (NE max maxV r)) | otherwise = case r of - Tip -> (l2rDR (DR min minV l), Nothing, DR (maxToMin max) maxV Tip) + Tip -> (l2rNE (NE min minV l), Nothing, NE (maxToMin max) maxV Tip) Bin minI minVI lI rI -> case compareMinBound k minI of - InBound -> let (DR maxI maxVI lt, eq, gt) = go (xor k minI) minI minVI xorCacheMax max maxV lI rI - in (DR maxI maxVI (Bin min minV l lt), eq, gt) - OutOfBound -> (l2rDR (DR min minV l), Nothing, r2lDR (DR max maxV r)) - Matched -> (l2rDR (DR min minV l), Just minVI, deleteMinL max maxV lI rI) + InBound -> let (NE maxI maxVI lt, eq, gt) = go (xor k minI) minI minVI xorCacheMax max maxV lI rI + in (NE maxI maxVI (Bin min minV l lt), eq, gt) + OutOfBound -> (l2rNE (NE min minV l), Nothing, r2lNE (NE max maxV r)) + Matched -> (l2rNE (NE min minV l), Just minVI, deleteMinL max maxV lI rI) -- | /O(1)/. Decompose a map into pieces based on the structure of the underlying -- tree. This function is useful for consuming a map in parallel. @@ -2586,15 +2632,15 @@ r2lMap Empty = Empty r2lMap (NonEmpty max maxV Tip) = NonEmpty (maxToMin max) maxV Tip r2lMap (NonEmpty max maxV (Bin min minV l r)) = NonEmpty min minV (Bin max maxV l r) -{-# INLINE l2rDR #-} -l2rDR :: DeleteResult L a -> DeleteResult R a -l2rDR (DR min minV Tip) = DR (minToMax min) minV Tip -l2rDR (DR min minV (Bin max maxV l r)) = DR max maxV (Bin min minV l r) +{-# INLINE l2rNE #-} +l2rNE :: NonEmptyIntMap_ L a -> NonEmptyIntMap_ R a +l2rNE (NE min minV Tip) = NE (minToMax min) minV Tip +l2rNE (NE min minV (Bin max maxV l r)) = NE max maxV (Bin min minV l r) -{-# INLINE r2lDR #-} -r2lDR :: DeleteResult R a -> DeleteResult L a -r2lDR (DR max maxV Tip) = DR (maxToMin max) maxV Tip -r2lDR (DR max maxV (Bin min minV l r)) = DR min minV (Bin max maxV l r) +{-# INLINE r2lNE #-} +r2lNE :: NonEmptyIntMap_ R a -> NonEmptyIntMap_ L a +r2lNE (NE max maxV Tip) = NE (maxToMin max) maxV Tip +r2lNE (NE max maxV (Bin min minV l r)) = NE min minV (Bin max maxV l r) -- | Insert a key/value pair to a left node where the key is smaller than -- any present in that node. Requires the xor of the inserted key and the @@ -2620,68 +2666,65 @@ insertMaxR !xorCache !max maxV (Bin min minV l r) | xor (boundKey max) min < xorCache = Bin min minV (Bin max maxV l r) Tip | otherwise = Bin min minV l (insertMaxR xorCache max maxV r) --- | Delete the minimum key/value pair from an unpacked left node, returning --- a new left node in a DeleteResult. -deleteMinL :: Bound R -> a -> Node L a -> Node R a -> DeleteResult L a -deleteMinL !max maxV Tip Tip = DR (maxToMin max) maxV Tip -deleteMinL !max maxV Tip (Bin min minV l r) = DR min minV (Bin max maxV l r) +-- | Rearrange an unpacked (non-empty) left node into a non-empty map, for use +-- when the minimum bound of the node has been deleted. See 'NonEmptyIntMap_' +-- for the reasoning behind this. +deleteMinL :: Bound R -> a -> Node L a -> Node R a -> NonEmptyIntMap_ L a +deleteMinL !max maxV Tip Tip = NE (maxToMin max) maxV Tip +deleteMinL !max maxV Tip (Bin min minV l r) = NE min minV (Bin max maxV l r) deleteMinL !max maxV (Bin innerMax innerMaxV innerL innerR) r = - let DR min minV inner = deleteMinL innerMax innerMaxV innerL innerR - in DR min minV (Bin max maxV inner r) - --- | Delete the maximum key/value pair from an unpacked right node, returning --- a new right node in a DeleteResult. -deleteMaxR :: Bound L -> a -> Node L a -> Node R a -> DeleteResult R a -deleteMaxR !min minV Tip Tip = DR (minToMax min) minV Tip -deleteMaxR !min minV (Bin max maxV l r) Tip = DR max maxV (Bin min minV l r) + let NE min minV inner = deleteMinL innerMax innerMaxV innerL innerR + in NE min minV (Bin max maxV inner r) + +-- | Rearrange an unpacked (non-empty) right node into a non-empty map, for use +-- when the maximum bound of the node has been deleted. See 'NonEmptyIntMap_' +-- for the reasoning behind this. +deleteMaxR :: Bound L -> a -> Node L a -> Node R a -> NonEmptyIntMap_ R a +deleteMaxR !min minV Tip Tip = NE (minToMax min) minV Tip +deleteMaxR !min minV (Bin max maxV l r) Tip = NE max maxV (Bin min minV l r) deleteMaxR !min minV l (Bin innerMin innerMinV innerL innerR) = - let DR max maxV inner = deleteMaxR innerMin innerMinV innerL innerR - in DR max maxV (Bin min minV l inner) + let NE max maxV inner = deleteMaxR innerMin innerMinV innerL innerR + in NE max maxV (Bin min minV l inner) --- | Combine two disjoint nodes into a new left node. This is not cheap. +-- | Combine two nodes that would be on different branches into into a new left +-- node. This is not cheap: since the 'Bin' constructor needs an new bound in +-- addition to two children, that bound must be extracted from a child. The +-- primary use case of this and 'extractBinR' is readjusting a node after the +-- bound that it stores has been deleted, so only the two children remain. +-- +-- 'NonEmptyIntMap_' has more details about this use case. extractBinL :: Node L a -> Node R a -> Node L a extractBinL l Tip = l extractBinL l (Bin min minV innerL innerR) = - let DR max maxV r = deleteMaxR min minV innerL innerR + let NE max maxV r = deleteMaxR min minV innerL innerR in Bin max maxV l r --- | Combine two disjoint nodes into a new right node. This is not cheap. +-- | Combine two nodes that would be on different branches into into a new +-- right node. This is not cheap: since the 'Bin' constructor needs an new +-- bound in addition to two children, that bound must be extracted from a +-- child. The primary use case of this and 'extractBinL' is readjusting a node +-- after the bound that it stores has been deleted, so only the two children +-- remain. +-- +-- 'NonEmptyIntMap_' has more details about this use case. extractBinR :: Node L a -> Node R a -> Node R a extractBinR Tip r = r extractBinR (Bin max maxV innerL innerR) r = - let DR min minV l = deleteMinL max maxV innerL innerR + let NE min minV l = deleteMinL max maxV innerL innerR in Bin min minV l r +-- | Convert a left 'Node' into an 'IntMap_' for use when the external minimum +-- is no longer available. See 'NonEmptyIntMap_' for more details. nodeToMapL :: Node L a -> IntMap_ L a nodeToMapL Tip = Empty nodeToMapL (Bin max maxV innerL innerR) = - let DR min minV l = deleteMinL max maxV innerL innerR + let NE min minV l = deleteMinL max maxV innerL innerR in NonEmpty min minV l +-- | Convert a right 'Node' into an 'IntMap_' for use when the external maximum +-- is no longer available. See 'NonEmptyIntMap_' for more details. nodeToMapR :: Node R a -> IntMap_ R a nodeToMapR Tip = Empty nodeToMapR (Bin min minV innerL innerR) = - let DR max maxV r = deleteMaxR min minV innerL innerR + let NE max maxV r = deleteMaxR min minV innerL innerR in NonEmpty max maxV r - --- | Delete a key from a left node. Takes the xor of the deleted key and --- the minimum bound of that node. -deleteL :: Key -> Word -> Node L a -> Node L a -deleteL !_ !_ Tip = Tip -deleteL !k !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> Bin max maxV (deleteL k xorCache l) r - | otherwise -> Bin max maxV l (deleteR k xorCacheMax r) - OutOfBound -> n - Matched -> extractBinL l r - where xorCacheMax = xor k max - --- | Delete a key from a right node. Takes the xor of the deleted key and --- the maximum bound of that node. -deleteR :: Key -> Word -> Node R a -> Node R a -deleteR !_ !_ Tip = Tip -deleteR !k !xorCache n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> Bin min minV l (deleteR k xorCache r) - | otherwise -> Bin min minV (deleteL k xorCacheMin l) r - OutOfBound -> n - Matched -> extractBinR l r - where xorCacheMin = xor k min diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 621aea565..cba4d82cc 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -737,7 +737,7 @@ differenceWithUKey = start goLFused _ !_ Tip !_ = Empty goLFused _ !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of - DR min' minV' n' -> NonEmpty min' minV' n' + NE min' minV' n' -> NonEmpty min' minV' n' goLFused combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFused combine min n1 l2 EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) @@ -806,7 +806,7 @@ differenceWithUKey = start goRFused _ !_ Tip !_ = Empty goRFused _ !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of - DR max' maxV' n' -> NonEmpty max' maxV' n' + NE max' maxV' n' -> NonEmpty max' maxV' n' goRFused combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFused combine max n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goRFused combine max r1 r2) diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 70b68edaa..908739898 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -765,7 +765,7 @@ differenceWithUKey = start goLFused _ !_ Tip !_ = Empty goLFused _ !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of - DR min' minV' n' -> NonEmpty min' minV' n' + NE min' minV' n' -> NonEmpty min' minV' n' goLFused combine !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFused combine min n1 l2 EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) @@ -834,7 +834,7 @@ differenceWithUKey = start goRFused _ !_ Tip !_ = Empty goRFused _ !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of - DR max' maxV' n' -> NonEmpty max' maxV' n' + NE max' maxV' n' -> NonEmpty max' maxV' n' goRFused combine !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFused combine max n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goRFused combine max r1 r2) From b6e12e66a3d24e3206f0bad257b7652b2d07f460 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 14 Jan 2020 11:48:13 -0600 Subject: [PATCH 109/147] Address small documentation nits --- containers/src/Data/IntMap/Internal.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index c6b311525..3cfc2d0f6 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -673,12 +673,12 @@ newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) -- /right/ side since it has a 0 in the sign bit. -- -- Note that one of these minimum and maximum bounds is inherited from the parent of the 'Node'. --- The terms do not refer to the minimum and maximum keys actually stored somewhere withing the +-- The terms do not refer to the minimum and maximum keys actually stored somewhere within the -- 'Node' or in one of its descendants. -- -- These invariants imply a unique tree structure for a given set of keys. In fact, they are -- overspecified: the second invariant follows from the other two. To check these invariants, --- use 'Daa.IntMap.Internal.Debug.valid'. +-- use 'Data.IntMap.Internal.Debug.valid'. data IntMap_ t a = NonEmpty {-# UNPACK #-} !(Bound t) a !(Node t a) | Empty deriving (Eq) -- | A node within a tree mapping integers to value @a@. Unlike an 'IntMap_', a 'Node' cannot @@ -2583,15 +2583,18 @@ maxViewWithKey (IntMap Empty) = Nothing maxViewWithKey (IntMap (NonEmpty min minV Tip)) = Just ((boundKey min, minV), IntMap Empty) maxViewWithKey (IntMap (NonEmpty min minV (Bin max maxV l r))) = Just ((boundKey max, maxV), IntMap (NonEmpty min minV (extractBinL l r))) --- | /O(1)/. Returns whether the most significant bit of its first --- argument is less significant than the most significant bit of its --- second argument. +-- | /O(1)/. Returns whether the most significant bit (MSB) of its first +-- argument is less significant than the most significant bit of its second +-- argument. -- This works by measuring whether x is in between 0 and y but closer to 0 (in the xor metric). {-# INLINE ltMSB #-} ltMSB :: Word -> Word -> Bool ltMSB x y = x < y && x < Data.Bits.xor x y +-- | /O(1)/. Compares the significance of the most significan set bits (MSBs) +-- of two words. Commonly used with `xorBounds` to tell which of two nodes +-- spans a larger space of keys in merge operations. -- See 'ltMSB' for why this works {-# INLINE compareMSB #-} compareMSB :: Word -> Word -> Ordering From 9c2ac0235d35b12718421fc5c10b5f02c209126d Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 14 Jan 2020 11:55:35 -0600 Subject: [PATCH 110/147] Reference fromDistinctAscList in Data.IntMap.BuildStack's documentation (a fuller explanation is still to come) --- containers/src/Data/IntMap/Internal.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 3cfc2d0f6..1858ae6c3 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -2024,7 +2024,10 @@ foldlFB = foldlWithKey #-} #endif --- | A stack used in the in-order building of IntMaps. +-- | A stack used in the in-order building of IntMaps. The utilities here don't +-- force any of the values that are passed, and so require both lazy and strict +-- wrappers. See 'Data.IntMap.Lazy.fromDistinctAscList' and its strict +-- counterpart for examples of how to use these functions. data BuildStack a = Push {-# UNPACK #-} !(Bound L) a !(Node L a) !(BuildStack a) | StackBase pushBuildStack :: Word -> Key -> a -> Node R a -> BuildStack a -> BuildStack a From 6568108605236925bac6f5b271e13a177f638415 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 14 Jan 2020 14:29:08 -0600 Subject: [PATCH 111/147] INLINE IntMap fold and traverse variants --- containers/src/Data/IntMap/Internal.hs | 6 ++++++ containers/src/Data/IntMap/Lazy.hs | 1 + containers/src/Data/IntMap/Strict.hs | 1 + 3 files changed, 8 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 1858ae6c3..8bab2cf68 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -858,6 +858,7 @@ instance Data.Foldable.Foldable IntMap where #endif instance Traversable IntMap where + {-# INLINE traverse #-} traverse f = start where start (IntMap Empty) = pure (IntMap Empty) @@ -1793,6 +1794,7 @@ disjoint = start -- -- > let f a len = len + (length a) -- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 +{-# INLINE foldr #-} foldr :: (a -> b -> b) -> b -> IntMap a -> b foldr f z = start where @@ -1814,6 +1816,7 @@ foldr f z = start -- -- > let f len a = len + (length a) -- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 +{-# INLINE foldl #-} foldl :: (a -> b -> a) -> a -> IntMap b -> a foldl f z = start where @@ -1836,6 +1839,7 @@ foldl f z = start -- -- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" -- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" +{-# INLINE foldrWithKey #-} foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b foldrWithKey f z = start where @@ -1858,6 +1862,7 @@ foldrWithKey f z = start -- -- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" -- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)" +{-# INLINE foldlWithKey #-} foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a foldlWithKey f z = start where @@ -1875,6 +1880,7 @@ foldlWithKey f z = start -- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@ -- -- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids. +{-# INLINE foldMapWithKey #-} foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m foldMapWithKey f = start where diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index cba4d82cc..37c12ab5a 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1094,6 +1094,7 @@ mapWithKey f = start -- -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +{-# INLINE traverseWithKey #-} traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) traverseWithKey f = start where diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 908739898..f437c429e 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1149,6 +1149,7 @@ mapWithKey f = start -- -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing +{-# INLINE traverseWithKey #-} traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) traverseWithKey f = start where From 4ebf97206d81299003bee73ecbb36da51a0d9620 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 14 Jan 2020 16:27:28 -0600 Subject: [PATCH 112/147] Worker/wrapper transform filter-style functions in IntMap --- containers/src/Data/IntMap/Internal.hs | 80 +++++++++++++---------- containers/src/Data/IntMap/Lazy.hs | 90 +++++++++++++++----------- containers/src/Data/IntMap/Strict.hs | 38 +++++++---- 3 files changed, 125 insertions(+), 83 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 8bab2cf68..7a12a6ec5 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -2057,31 +2057,37 @@ filter p = filterWithKey (const p) -- | /O(n)/. Filter all keys\/values that satisfy some predicate. -- -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" +{-# INLINE filterWithKey #-} filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a -filterWithKey p = start +filterWithKey p = filterWithUKey (\k a -> p (box k) a) + +-- | /O(n)/. Filter all keys\/values that satisfy some predicate taking unboxed +-- keys. Identical in functionality to 'filterWithKeys'. +filterWithUKey :: (UKey -> a -> Bool) -> IntMap a -> IntMap a +filterWithUKey p = start where start (IntMap Empty) = IntMap Empty start (IntMap (NonEmpty min minV root)) - | p (boundKey min) minV = IntMap (NonEmpty min minV (goL root)) + | p (unbox (boundKey min)) minV = IntMap (NonEmpty min minV (goL root)) | otherwise = IntMap (goDeleteL root) goL Tip = Tip goL (Bin max maxV l r) - | p (boundKey max) maxV = Bin max maxV (goL l) (goR r) + | p (unbox (boundKey max)) maxV = Bin max maxV (goL l) (goR r) | otherwise = case goDeleteR r of Empty -> goL l NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' goR Tip = Tip goR (Bin min minV l r) - | p (boundKey min) minV = Bin min minV (goL l) (goR r) + | p (unbox (boundKey min)) minV = Bin min minV (goL l) (goR r) | otherwise = case goDeleteL l of Empty -> goR r NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) goDeleteL Tip = Empty goDeleteL (Bin max maxV l r) - | p (boundKey max) maxV = case goDeleteL l of + | p (unbox (boundKey max)) maxV = case goDeleteL l of Empty -> case goR r of Tip -> NonEmpty (maxToMin max) maxV Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) @@ -2090,7 +2096,7 @@ filterWithKey p = start goDeleteR Tip = Empty goDeleteR (Bin min minV l r) - | p (boundKey min) minV = case goDeleteR r of + | p (unbox (boundKey min)) minV = case goDeleteR r of Empty -> case goL l of Tip -> NonEmpty (minToMax min) minV Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) @@ -2134,21 +2140,27 @@ partition p = partitionWithKey (const p) -- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b") -- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty) -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")]) +{-# INLINE partitionWithKey #-} partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a, IntMap a) -partitionWithKey p = start +partitionWithKey p = partitionWithUKey (\k a -> p (box k) a) + +-- | /O(n)/. Partition the map according to some predicate taking an unboxed +-- key. Identical in functionality to 'partitionWithKey'. +partitionWithUKey :: (UKey -> a -> Bool) -> IntMap a -> (IntMap a, IntMap a) +partitionWithUKey p = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) start (IntMap (NonEmpty min minV root)) - | p (boundKey min) minV = let t :*: f = goTrueL root - in (IntMap (NonEmpty min minV t), IntMap f) + | p (unbox (boundKey min)) minV = let t :*: f = goTrueL root + in (IntMap (NonEmpty min minV t), IntMap f) | otherwise = let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min minV f)) goTrueL Tip = Tip :*: Empty goTrueL (Bin max maxV l r) - | p (boundKey max) maxV = let tl :*: fl = goTrueL l - tr :*: fr = goTrueR r - in Bin max maxV tl tr :*: binL fl fr + | p (unbox (boundKey max)) maxV = let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin max maxV tl tr :*: binL fl fr | otherwise = let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of @@ -2161,9 +2173,9 @@ partitionWithKey p = start goTrueR Tip = Tip :*: Empty goTrueR (Bin min minV l r) - | p (boundKey min) minV = let tl :*: fl = goTrueL l - tr :*: fr = goTrueR r - in Bin min minV tl tr :*: binR fl fr + | p (unbox (boundKey min)) minV = let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin min minV tl tr :*: binR fl fr | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -2176,30 +2188,32 @@ partitionWithKey p = start goFalseL Tip = Empty :*: Tip goFalseL (Bin max maxV l r) - | p (boundKey max) maxV = let tl :*: fl = goFalseL l - tr :*: fr = goTrueR r - t = case tl of - Empty -> r2lMap $ NonEmpty max maxV tr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' tr) - f = case fr of - Empty -> fl - NonEmpty max' maxV' r' -> Bin max' maxV' fl r' - in t :*: f + | p (unbox (boundKey max)) maxV = + let tl :*: fl = goFalseL l + tr :*: fr = goTrueR r + t = case tl of + Empty -> r2lMap $ NonEmpty max maxV tr + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' tr) + f = case fr of + Empty -> fl + NonEmpty max' maxV' r' -> Bin max' maxV' fl r' + in t :*: f | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binL tl tr :*: Bin max maxV fl fr goFalseR Tip = Empty :*: Tip goFalseR (Bin min minV l r) - | p (boundKey min) minV = let tl :*: fl = goTrueL l - tr :*: fr = goFalseR r - t = case tr of - Empty -> l2rMap $ NonEmpty min minV tl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV tl r') - f = case fl of - Empty -> fr - NonEmpty min' minV' l' -> Bin min' minV' l' fr - in t :*: f + | p (unbox (boundKey min)) minV = + let tl :*: fl = goTrueL l + tr :*: fr = goFalseR r + t = case tr of + Empty -> l2rMap $ NonEmpty min minV tl + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV tl r') + f = case fl of + Empty -> fr + NonEmpty min' minV' l' -> Bin min' minV' l' fr + in t :*: f | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binR tl tr :*: Bin min minV fl fr diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 37c12ab5a..288539401 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1301,45 +1301,52 @@ mapMaybe f = mapMaybeWithKey (const f) -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" +{-# INLINE mapMaybeWithKey #-} mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b -mapMaybeWithKey f = start - where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = case f (boundKey min) minV of - Just minV' -> IntMap (NonEmpty min minV' (goL root)) - Nothing -> IntMap (goDeleteL root) - - goL Tip = Tip - goL (Bin max maxV l r) = case f (boundKey max) maxV of - Just maxV' -> Bin max maxV' (goL l) (goR r) - Nothing -> case goDeleteR r of - Empty -> goL l - NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' +mapMaybeWithKey f = mapMaybeWithUKey (\k a -> f (box k) a) - goR Tip = Tip - goR (Bin min minV l r) = case f (boundKey min) minV of - Just minV' -> Bin min minV' (goL l) (goR r) - Nothing -> case goDeleteL l of - Empty -> goR r - NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) - - goDeleteL Tip = Empty - goDeleteL (Bin max maxV l r) = case f (boundKey max) maxV of - Just maxV' -> case goDeleteL l of - Empty -> case goR r of +-- | /O(n)/. Map keys\/values and collect the 'Just' results with a mapping +-- function that takes unboxed keys. Identical in functionality to +-- 'mapMaybeWithKey'. +mapMaybeWithUKey :: (UKey -> a -> Maybe b) -> IntMap a -> IntMap b +mapMaybeWithUKey = start + where + start _ (IntMap Empty) = IntMap Empty + start f (IntMap (NonEmpty min minV root)) = case f (unbox (boundKey min)) minV of + Just minV' -> IntMap (NonEmpty min minV' (goL f root)) + Nothing -> IntMap (goDeleteL f root) + + goL _ Tip = Tip + goL f (Bin max maxV l r) = case f (unbox (boundKey max)) maxV of + Just maxV' -> Bin max maxV' (goL f l) (goR f r) + Nothing -> case goDeleteR f r of + Empty -> goL f l + NonEmpty max' maxV' r' -> Bin max' maxV' (goL f l) r' + + goR _ Tip = Tip + goR f (Bin min minV l r) = case f (unbox (boundKey min)) minV of + Just minV' -> Bin min minV' (goL f l) (goR f r) + Nothing -> case goDeleteL f l of + Empty -> goR f r + NonEmpty min' minV' l' -> Bin min' minV' l' (goR f r) + + goDeleteL _ Tip = Empty + goDeleteL f (Bin max maxV l r) = case f (unbox (boundKey max)) maxV of + Just maxV' -> case goDeleteL f l of + Empty -> case goR f r of Tip -> NonEmpty (maxToMin max) maxV' Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) - NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR r)) - Nothing -> binL (goDeleteL l) (goDeleteR r) + NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR f r)) + Nothing -> binL (goDeleteL f l) (goDeleteR f r) - goDeleteR Tip = Empty - goDeleteR (Bin min minV l r) = case f (boundKey min) minV of - Just minV' -> case goDeleteR r of - Empty -> case goL l of + goDeleteR _ Tip = Empty + goDeleteR f (Bin min minV l r) = case f (unbox (boundKey min)) minV of + Just minV' -> case goDeleteR f r of + Empty -> case goL f l of Tip -> NonEmpty (minToMax min) minV' Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) - NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL l) r') - Nothing -> binR (goDeleteL l) (goDeleteR r) + NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL f l) r') + Nothing -> binR (goDeleteL f l) (goDeleteR f r) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -- @@ -1360,18 +1367,25 @@ mapEither f = mapEitherWithKey (const f) -- > -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) +{-# INLINE mapEitherWithKey #-} mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) -mapEitherWithKey func = start +mapEitherWithKey f = mapEitherWithUKey (\k a -> f (box k) a) + +-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results with +-- a mapping function taking unboxed keys. Identical in functionality to +-- 'mapEitherWithKey'. +mapEitherWithUKey :: (UKey -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) +mapEitherWithUKey func = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) - start (IntMap (NonEmpty min minV root)) = case func (boundKey min) minV of + start (IntMap (NonEmpty min minV root)) = case func (unbox (boundKey min)) minV of Left v -> let t :*: f = goTrueL root in (IntMap (NonEmpty min v t), IntMap f) Right v -> let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min v f)) goTrueL Tip = Tip :*: Empty - goTrueL (Bin max maxV l r) = case func (boundKey max) maxV of + goTrueL (Bin max maxV l r) = case func (unbox (boundKey max)) maxV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin max v tl tr :*: binL fl fr @@ -1386,7 +1400,7 @@ mapEitherWithKey func = start in t :*: f goTrueR Tip = Tip :*: Empty - goTrueR (Bin min minV l r) = case func (boundKey min) minV of + goTrueR (Bin min minV l r) = case func (unbox (boundKey min)) minV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin min v tl tr :*: binR fl fr @@ -1401,7 +1415,7 @@ mapEitherWithKey func = start in t :*: f goFalseL Tip = Empty :*: Tip - goFalseL (Bin max maxV l r) = case func (boundKey max) maxV of + goFalseL (Bin max maxV l r) = case func (unbox (boundKey max)) maxV of Left v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -1416,7 +1430,7 @@ mapEitherWithKey func = start in binL tl tr :*: Bin max v fl fr goFalseR Tip = Empty :*: Tip - goFalseR (Bin min minV l r) = case func (boundKey min) minV of + goFalseR (Bin min minV l r) = case func (unbox (boundKey min)) minV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index f437c429e..e5751d894 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1358,30 +1358,37 @@ mapMaybe f = mapMaybeWithKey (const f) -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" +{-# INLINE mapMaybeWithKey #-} mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b -mapMaybeWithKey f = start +mapMaybeWithKey f = mapMaybeWithUKey (\k a -> f (box k) a) + +-- | /O(n)/. Map keys\/values and collect the 'Just' results with a mapping +-- function that takes unboxed keys. Identical in functionality to +-- 'mapMaybeWithKey'. +mapMaybeWithUKey :: (UKey -> a -> Maybe b) -> IntMap a -> IntMap b +mapMaybeWithUKey f = start where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = case f (boundKey min) minV of + start (IntMap (NonEmpty min minV root)) = case f (unbox (boundKey min)) minV of Just !minV' -> IntMap (NonEmpty min minV' (goL root)) Nothing -> IntMap (goDeleteL root) goL Tip = Tip - goL (Bin max maxV l r) = case f (boundKey max) maxV of + goL (Bin max maxV l r) = case f (unbox (boundKey max)) maxV of Just !maxV' -> Bin max maxV' (goL l) (goR r) Nothing -> case goDeleteR r of Empty -> goL l NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' goR Tip = Tip - goR (Bin min minV l r) = case f (boundKey min) minV of + goR (Bin min minV l r) = case f (unbox (boundKey min)) minV of Just !minV' -> Bin min minV' (goL l) (goR r) Nothing -> case goDeleteL l of Empty -> goR r NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) goDeleteL Tip = Empty - goDeleteL (Bin max maxV l r) = case f (boundKey max) maxV of + goDeleteL (Bin max maxV l r) = case f (unbox (boundKey max)) maxV of Just !maxV' -> case goDeleteL l of Empty -> case goR r of Tip -> NonEmpty (maxToMin max) maxV' Tip @@ -1390,7 +1397,7 @@ mapMaybeWithKey f = start Nothing -> binL (goDeleteL l) (goDeleteR r) goDeleteR Tip = Empty - goDeleteR (Bin min minV l r) = case f (boundKey min) minV of + goDeleteR (Bin min minV l r) = case f (unbox (boundKey min)) minV of Just !minV' -> case goDeleteR r of Empty -> case goL l of Tip -> NonEmpty (minToMax min) minV' Tip @@ -1417,18 +1424,25 @@ mapEither f = mapEitherWithKey (const f) -- > -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) +{-# INLINE mapEitherWithKey #-} mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) -mapEitherWithKey func = start +mapEitherWithKey f = mapEitherWithUKey (\k a -> f (box k) a) + +-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results with +-- a mapping function taking unboxed keys. Identical in functionality to +-- 'mapEitherWithKey'. +mapEitherWithUKey :: (UKey -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) +mapEitherWithUKey func = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) - start (IntMap (NonEmpty min minV root)) = case func (boundKey min) minV of + start (IntMap (NonEmpty min minV root)) = case func (unbox (boundKey min)) minV of Left !v -> let t :*: f = goTrueL root in (IntMap (NonEmpty min v t), IntMap f) Right !v -> let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min v f)) goTrueL Tip = Tip :*: Empty - goTrueL (Bin max maxV l r) = case func (boundKey max) maxV of + goTrueL (Bin max maxV l r) = case func (unbox (boundKey max)) maxV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin max v tl tr :*: binL fl fr @@ -1443,7 +1457,7 @@ mapEitherWithKey func = start in t :*: f goTrueR Tip = Tip :*: Empty - goTrueR (Bin min minV l r) = case func (boundKey min) minV of + goTrueR (Bin min minV l r) = case func (unbox (boundKey min)) minV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin min v tl tr :*: binR fl fr @@ -1458,7 +1472,7 @@ mapEitherWithKey func = start in t :*: f goFalseL Tip = Empty :*: Tip - goFalseL (Bin max maxV l r) = case func (boundKey max) maxV of + goFalseL (Bin max maxV l r) = case func (unbox (boundKey max)) maxV of Left !v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -1473,7 +1487,7 @@ mapEitherWithKey func = start in binL tl tr :*: Bin max v fl fr goFalseR Tip = Empty :*: Tip - goFalseR (Bin min minV l r) = case func (boundKey min) minV of + goFalseR (Bin min minV l r) = case func (unbox (boundKey min)) minV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of From 996b0ec6616deac3e65071db8476063ef3f88124 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 16 Jan 2020 01:57:36 -0600 Subject: [PATCH 113/147] Remove the broken implementation of IntMap.merge and replace it with a TODO describing why merge could be better --- containers/src/Data/IntMap/Merge/Internal.hs | 409 +------------------ 1 file changed, 9 insertions(+), 400 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index b7bf06f0d..e5934a46e 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -325,408 +325,17 @@ runWhenMatched = matchedSingle -- prop> symmetricDifference = merge preserveMissing preserveMissing (zipWithMaybeMatched (\_ _ _ -> Nothing)) -- prop> mapEachPiece f g h = merge (mapMissing f) (mapMissing g) (zipWithMatched h) {-# INLINE merge #-} +-- TODO: Implementing 'merge' in terms of 'mergeA' leaves a lot to be desired +-- on the performance front. Because the choice of whether to delete a key is +-- hidden behind Applicative effects, 'mergeA' must conservatively return +-- 'IntMap_'s from every intermediate function, even when a 'Node' would be +-- more efficient and appropriate. (It could return 'Node's everywhere instead, +-- but that would have the same problem in the opposite direction.) 'merge' +-- has no such limitation, since recursion schemes and decisions about what +-- types of structures to return can be made based on the results of pure +-- tactics. merge :: SimpleWhenMissing a c -> SimpleWhenMissing b c -> SimpleWhenMatched a b c -> IntMap a -> IntMap b -> IntMap c merge miss1 miss2 match = \m1 m2 -> runIdentity (mergeA miss1 miss2 match m1 m2) -{- FIXME: The following is significantly faster, but incorrect. -merge miss1 miss2 match = start where - start (IntMap Empty) (IntMap Empty) = IntMap Empty - start (IntMap Empty) (IntMap !m2) = IntMap (missAllL miss2 m2) - start (IntMap !m1) (IntMap Empty) = IntMap (missAllL miss1 m1) - start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = case missSingle miss1 (boundKey min1) minV1 of - Nothing -> IntMap (goL2 minV2 min1 root1 min2 root2) - Just minV' -> IntMap (NonEmpty min1 minV' (goL2Keep minV2 min1 root1 min2 root2)) - | min1 > min2 = case missSingle miss2 (boundKey min2) minV2 of - Nothing -> IntMap (goL1 minV1 min1 root1 min2 root2) - Just minV' -> IntMap (NonEmpty min2 minV' (goL1Keep minV1 min1 root1 min2 root2)) - | otherwise = case matchSingle match (boundKey min1) minV1 minV2 of - Nothing -> IntMap (goLFused min1 root1 root2) - Just minV' -> IntMap (NonEmpty min1 minV' (goLFusedKeep min1 root1 root2)) - - -- The merge code is structured as 12 very repetitive methods that merge nodes and a value associated with - -- the bound of one of those nodes. These vary on 3 axes: - -- - -- * The functions ending in L take and produce left nodes/maps, while those ending in R take and produce right nodes/maps - -- * The functions ending with a 1 have the first argument "inside" the second, i.e., the L1 functions assume that min1 > min2 - -- and take minV1 and the R1 functions assume that max1 < max2 and take maxV1. The functions ending with a 2 are symmetrical, - -- and the functions ending with Fused assume that the two maps are aligned: LFused assumes that min1 = min2 and RFused assumes that max1 = max2. - -- * The functions ending in Keep produce a Node, while the functions without Keep produce an IntMap_ - -- - -- See goL1Keep and goLFusedKeep for detailed description of the merging process. - - - -- | Merge two left nodes and a minimum value for the first node into a new left node - -- Precondition: min1 > min2 - -- goL1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c - - -- We special case merging two empty nodes because the last time I checked it was faster than falling through to the next case - goL1Keep minV1 !min1 Tip !_ Tip = case missSingle miss1 (boundKey min1) minV1 of - Nothing -> Tip - Just minV' -> Bin (minToMax min1) minV' Tip Tip - - -- If the second node is empty, then we basically need a copy of the first node. However, the presence of minV1 complicates things, - -- so we need to insert it - goL1Keep minV1 !min1 n1 !min2 Tip = case missSingle miss1 (boundKey min1) minV1 of - Nothing -> missLeft miss1 n1 - Just minV' -> insertMinL (xor (boundKey min1) min2) min1 minV' (missLeft miss1 n1) - - -- We handle the case of nodes that cover disjoint ranges separately. The property of being disjoint, unlike a lot of things, remains - -- constant as we recurse into subnodes, and this representation is particularly good at efficiently detecting it. By assumption, - -- min1 > min2, so we don't need to handle the case of min2 > max1. - goL1Keep minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = case missAllL miss1 (NonEmpty min1 minV1 n1) of - Empty -> missLeft miss2 n2 - NonEmpty min1' minV1' n1' -> case missLeft miss2 n2 of - Tip -> insertMinL (xor (boundKey min1') min2) min1' minV1' n1' - n2'@(Bin _ _ _ _) -> unionDisjointL minV1' min2 n2' min1' n1' - - -- If the first node is empty, we still need to insert minV1 - goL1Keep minV1 !min1 Tip !min2 n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 - - -- This is the meat of the method. Since we already know that the two nodes cover overlapping ranges, there are three possibilities: - -- * Node 2 splits first, so we need to merge n1 with either l2 or r2 - -- * Both nodes split at the same time, so we need to merge l1 with l2 and r1 with r2 - -- * Node 1 splits first, so we need to merge n2 with either l1 or r1 - goL1Keep minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - -- Node 2 splits first. Knowing that min1 < min2 doesn't really help here, so our first job is to determine if we need - -- to merge n1 with l2 or with r2. We do this with the same navigational test used in, e.g., lookup, using an arbirary key - -- from node 1 (in this case we chose min1). If that key would be on the left side of node 2, then (since node 1 covers a smaller - -- binary range) the whole node 1 must fit in on the left side of node 2. - -- - -- In the specific case of merging n1 with l2, we don't have to do any more comparisons: we already know that min1 > min2, - -- so we should be calling an L1 function - LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missRight miss2 r2) - -- At this point, we know that we need to merge n1 with r2. There are two things needed to do this: - -- * n1 needs to be converted to a right node to match r2. - -- * We need to compare max1 and max2 to figure out which will be the maximum of the combined node and to - -- decide which (R1, R2, or RFused) function to recurse to. - | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of - -- If we had an optimized goR2 (no keep), then calling using it is more efficient than - -- calling goR2Keep and having to extract a new maximum from the result. Therefore, we - -- first check if we can keep our existing maximum, and if not, call goR2. - Nothing -> maybeBinL l' (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of - Nothing -> maybeBinL l' (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of - Nothing -> maybeBinL l' (goRFused max1 (Bin min1 minV1 l1 r1) r2) - Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) - where - {-# INLINE l' #-} - l' = missLeft miss2 l2 - - -- The two nodes split at the same time. In this case we need to merge l1 and l2 and r1 and r2. We already know that - -- min1 > min2, so merging the left nodes is easy, but we need to branch to figure out which right merging function to call - -- and which maximum to keep. - EQ | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of - Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 r2) - Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) - | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of - Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 r2) - Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) - | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of - Nothing -> maybeBinL l' (goRFused max1 r1 r2) - Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) - where - {-# INLINE l' #-} - l' = goL1Keep minV1 min1 l1 min2 l2 - - -- The simplest case is when node 1 splits first, meaning that we need to merge n2 and l1 or r1. However, since we already know - -- that min1 > min2, n2 must be merged with l1 instead of r1, and we already know the correct method to call. - GT -> binL1 max1 maxV1 (goL1Keep minV1 min1 l1 min2 n2) (missRight miss1 r1) - - - -- Merge two left nodes and a minimum value for the second node into a new left node - -- Precondition: min2 > min1 - -- goL2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c - goL2Keep minV2 !_ Tip !min2 Tip = case missSingle miss2 (boundKey min2) minV2 of - Nothing -> Tip - Just minV' -> Bin (minToMax min2) minV' Tip Tip - goL2Keep minV2 !min1 Tip !min2 n2 = case missSingle miss2 (boundKey min2) minV2 of - Nothing -> missLeft miss2 n2 - Just minV' -> insertMinL (xor (boundKey min2) min1) min2 minV' (missLeft miss2 n2) - goL2Keep minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = case missAllL miss2 (NonEmpty min2 minV2 n2) of - Empty -> missLeft miss1 n1 - NonEmpty min2' minV2' n2' -> case missLeft miss1 n1 of - Tip -> insertMinL (xor (boundKey min2') min1) min2' minV2' n2' - n1'@(Bin _ _ _ _) -> unionDisjointL minV2' min1 n1' min2' n2' - goL2Keep minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 - goL2Keep minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missRight miss1 r1) - | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of - Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) - Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of - Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of - Nothing -> maybeBinL l' (goRFused max1 r1 (Bin min2 minV2 l2 r2)) - Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 (Bin min2 minV2 l2 r2)) - where - {-# INLINE l' #-} - l' = missLeft miss1 l1 - EQ | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of - Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 r2) - Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) - | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of - Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 r2) - Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) - | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of - Nothing -> maybeBinL l' (goRFused max1 r1 r2) - Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) - where - {-# INLINE l' #-} - l' = goL2Keep minV2 min1 l1 min2 l2 - LT -> binL2 max2 maxV2 (goL2Keep minV2 min1 n1 min2 l2) (missRight miss2 r2) - - - -- | Merge two left nodes that share a minimum bound. - - -- We can special case the merging of two empty nodes. This is currently commented out in an attempt to - -- match union as closely as possible --- goLFusedKeep !_ Tip Tip = Tip - - -- If one of the nodes is empty, we can just use the other one. Unlike the case of misaligned nodes, we don't have an - -- extra value to insert - goLFusedKeep !_ Tip n2 = missLeft miss2 n2 - goLFusedKeep !_ n1 Tip = missLeft miss1 n1 - - -- Since the two nodes are joined at the left, the choices are considerable limited in comparison to the misaligned case. - -- If node 1 splits first, n2 must be merged with l1 and if node 2 splits first, n1 must be merged with l2. The equal case - -- is still the same as in the misaligned case, since we need to determine which maximum to use and which goR to call. - goLFusedKeep !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> binL2 max2 maxV2 (goLFusedKeep min n1 l2) (missRight miss2 r2) - EQ | max1 > max2 -> case missSingle miss1 (boundKey max1) maxV1 of - Nothing -> maybeBinL l' (goR2 maxV2 max1 r1 max2 r2) - Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) - | max1 < max2 -> case missSingle miss2 (boundKey max2) maxV2 of - Nothing -> maybeBinL l' (goR1 maxV1 max1 r1 max2 r2) - Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) - | otherwise -> case matchSingle match (boundKey max1) maxV1 maxV2 of - Nothing -> maybeBinL l' (goRFused max1 r1 r2) - Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) - where - {-# INLINE l' #-} - l' = goLFusedKeep min l1 l2 - GT -> binL1 max1 maxV1 (goLFusedKeep min l1 n2) (missRight miss1 r1) - - -- Merge two right nodes and a maximum value for the first node into a new right node - -- Precondition: max1 < max2 - -- goR1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c - goR1Keep maxV1 !max1 Tip !_ Tip = case missSingle miss1 (boundKey max1) maxV1 of - Nothing -> Tip - Just maxV' -> Bin (maxToMin max1) maxV' Tip Tip - goR1Keep maxV1 !max1 !n1 !max2 Tip = case missSingle miss1 (boundKey max1) maxV1 of - Nothing -> missRight miss1 n1 - Just maxV' -> insertMaxR (xor (boundKey max1) max2) max1 maxV' (missRight miss1 n1) - goR1Keep maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = case missAllR miss1 (NonEmpty max1 maxV1 n1) of - Empty -> missRight miss2 n2 - NonEmpty max1' maxV1' n1' -> case missRight miss2 n2 of - Tip -> insertMaxR (xor (boundKey max1') max2) max1' maxV1' n1' - n2'@(Bin _ _ _ _) -> unionDisjointR maxV1' max1' n1' max2 n2' - goR1Keep maxV1 !max1 Tip !max2 n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 - goR1Keep maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> binR2 min2 minV2 (missLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) - | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of - Nothing -> maybeBinR (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' - Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' - | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of - Nothing -> maybeBinR (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' - Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' - | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of - Nothing -> maybeBinR (goLFused min1 (Bin max1 maxV1 l1 r1) l2) r' - Just minV' -> Bin min1 minV' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) r' - where - {-# INLINE r' #-} - r' = missRight miss2 r2 - EQ | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of - Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 l2) r' - Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' - | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of - Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 l2) r' - Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' - | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of - Nothing -> maybeBinR (goLFused min1 l1 l2) r' - Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' - where - {-# INLINE r' #-} - r' = goR1Keep maxV1 max1 r1 max2 r2 - GT -> binR1 min1 minV1 (missLeft miss1 l1) (goR1Keep maxV1 max1 r1 max2 n2) - - -- Merge two left nodes and a minimum value for the second node into a new left node - -- Precondition: max2 < max1 - -- goR2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c - goR2Keep maxV2 !_ Tip !max2 Tip = case missSingle miss2 (boundKey max2) maxV2 of - Nothing -> Tip - Just maxV' -> Bin (maxToMin max2) maxV' Tip Tip - goR2Keep maxV2 !max1 Tip !max2 n2 = case missSingle miss2 (boundKey max2) maxV2 of - Nothing -> missRight miss2 n2 - Just maxV' -> insertMaxR (xor (boundKey max2) max1) max2 maxV' (missRight miss2 n2) - goR2Keep maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = case missAllR miss2 (NonEmpty max2 maxV2 n2) of - Empty -> missRight miss1 n1 - NonEmpty max2' maxV2' n2' -> case missRight miss1 n1 of - Tip -> insertMaxR (xor (boundKey max2') max1) max2' maxV2' n2' - n1'@(Bin _ _ _ _) -> unionDisjointR maxV2' max2' n2' max1 n1' - goR2Keep maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 - goR2Keep maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> binR1 min1 minV1 (missLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) - | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of - Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' - Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' - | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of - Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' - Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' - | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of - Nothing -> maybeBinR (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) r' - Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 (Bin max2 maxV2 l2 r2)) r' - where - {-# INLINE r' #-} - r' = missRight miss1 r1 - EQ | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of - Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 l2) r' - Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' - | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of - Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 l2) r' - Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' - | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of - Nothing -> maybeBinR (goLFused min1 l1 l2) r' - Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' - where - {-# INLINE r' #-} - r' = goR2Keep maxV2 max1 r1 max2 r2 - LT -> binR2 min2 minV2 (missLeft miss2 l2) (goR2Keep maxV2 max1 n1 max2 r2) - --- goRFusedKeep !_ Tip Tip = Tip - goRFusedKeep !_ Tip n2 = missRight miss2 n2 - goRFusedKeep !_ n1 Tip = missRight miss1 n1 - goRFusedKeep !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> binR2 min2 minV2 (missLeft miss2 l2) (goRFusedKeep max n1 r2) - EQ | min1 < min2 -> case missSingle miss1 (boundKey min1) minV1 of - Nothing -> maybeBinR (goL2 minV2 min1 l1 min2 l2) r' - Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' - | min1 > min2 -> case missSingle miss2 (boundKey min2) minV2 of - Nothing -> maybeBinR (goL1 minV1 min1 l1 min2 l2) r' - Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' - | otherwise -> case matchSingle match (boundKey min1) minV1 minV2 of - Nothing -> maybeBinR (goLFused min1 l1 l2) r' - Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' - where - {-# INLINE r' #-} - r' = goRFusedKeep max r1 r2 - GT -> binR1 min1 minV1 (missLeft miss1 l1) (goRFusedKeep max r1 n2) - - -- TODO: These are inefficient, obviously correct implementations. See intersection - -- and difference for examples of specialized implementations - goL1 minV1 !min1 !n1 !min2 !n2 = nodeToMapL (goL1Keep minV1 min1 n1 min2 n2) - goL2 minV2 !min1 !n1 !min2 !n2 = nodeToMapL (goL2Keep minV2 min1 n1 min2 n2) - goLFused !min !n1 !n2 = nodeToMapL (goLFusedKeep min n1 n2) - goR1 maxV1 !max1 !n1 !max2 !n2 = nodeToMapR (goR1Keep maxV1 max1 n1 max2 n2) - goR2 maxV2 !max1 !n1 !max2 !n2 = nodeToMapR (goR2Keep maxV2 max1 n1 max2 n2) - goRFused !max !n1 !n2 = nodeToMapR (goRFusedKeep max n1 n2) - - goInsertL1 !k v !_ _ Tip = case missSingle miss1 k v of - Nothing -> Tip - Just v' -> Bin (Bound k) v' Tip Tip - goInsertL1 !k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> binL2 max maxV (goInsertL1 k v xorCache min l) (missRight miss2 r) - | otherwise -> binL2 max maxV (missLeft miss2 l) (goInsertR1 k v xorCacheMax max r) - OutOfBound -> case missSingle miss1 k v of - Nothing -> missLeft miss2 (Bin max maxV l r) - Just v' -> if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v' (missLeft miss2 (Bin max maxV l r)) Tip - else Bin (Bound k) v' (missLeft miss2 l) (missRight miss2 (insertMaxR xorCacheMax max maxV r)) - Matched -> case matchSingle match k v maxV of - Nothing -> extractBinL (missLeft miss2 l) (missRight miss2 r) -- TODO: do extractBin first? - Just maxV' -> Bin max maxV' (missLeft miss2 l) (missRight miss2 r) - where xorCacheMax = xor k max - - goInsertL2 !k v !_ _ Tip = case missSingle miss2 k v of - Nothing -> Tip - Just v' -> Bin (Bound k) v' Tip Tip - goInsertL2 !k v !xorCache min (Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> binL1 max maxV (goInsertL2 k v xorCache min l) (missRight miss1 r) - | otherwise -> binL1 max maxV (missLeft miss1 l) (goInsertR2 k v xorCacheMax max r) - OutOfBound -> case missSingle miss2 k v of - Nothing -> missLeft miss1 (Bin max maxV l r) - Just v' -> if xor (boundKey max) min < xorCacheMax - then Bin (Bound k) v' (missLeft miss1 (Bin max maxV l r)) Tip - else Bin (Bound k) v' (missLeft miss1 l) (missRight miss1 (insertMaxR xorCacheMax max maxV r)) - Matched -> case matchSingle match k maxV v of - Nothing -> extractBinL (missLeft miss1 l) (missRight miss1 r) -- TODO: do extractBin first? - Just maxV' -> Bin max maxV' (missLeft miss1 l) (missRight miss1 r) - where xorCacheMax = xor k max - - goInsertR1 k v !_ _ Tip = case missSingle miss1 k v of - Nothing -> Tip - Just v' -> Bin (Bound k) v' Tip Tip - goInsertR1 k v !xorCache max (Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> binR2 min minV (missLeft miss2 l) (goInsertR1 k v xorCache max r) - | otherwise -> binR2 min minV (goInsertL1 k v xorCacheMin min l) (missRight miss2 r) - OutOfBound -> case missSingle miss1 k v of - Nothing -> missRight miss2 (Bin min minV l r) - Just v' -> if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v' Tip (missRight miss2 (Bin min minV l r)) - else Bin (Bound k) v' (missLeft miss2 (insertMinL xorCacheMin min minV l)) (missRight miss2 r) - Matched -> case matchSingle match k v minV of - Nothing -> extractBinR (missLeft miss2 l) (missRight miss2 r) -- TODO: do extractBin first? - Just minV' -> Bin min minV' (missLeft miss2 l) (missRight miss2 r) - where xorCacheMin = xor k min - - goInsertR2 !k v !_ _ Tip = case missSingle miss2 k v of - Nothing -> Tip - Just v' -> Bin (Bound k) v' Tip Tip - goInsertR2 !k v !xorCache max (Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> binR1 min minV (missLeft miss1 l) (goInsertR2 k v xorCache max r) - | otherwise -> binR1 min minV (goInsertL2 k v xorCacheMin min l) (missRight miss1 r) - OutOfBound -> case missSingle miss2 k v of - Nothing -> missRight miss1 (Bin min minV l r) - Just v' -> if xor (boundKey min) max < xorCacheMin - then Bin (Bound k) v' Tip (missRight miss1 (Bin min minV l r)) - else Bin (Bound k) v' (missLeft miss1 (insertMinL xorCacheMin min minV l)) (missRight miss1 r) - Matched -> case matchSingle match k minV v of - Nothing -> extractBinR (missLeft miss1 l) (missRight miss1 r) -- TODO: do extractBin first? - Just minV' -> Bin min minV' (missLeft miss1 l) (missRight miss1 r) - where xorCacheMin = xor k min - - {-# INLINE binL1 #-} - binL1 k1 v1 l r = case missSingle miss1 (boundKey k1) v1 of - Nothing -> extractBinL l r - Just v' -> Bin k1 v' l r - - {-# INLINE binL2 #-} - binL2 k2 v2 l r = case missSingle miss2 (boundKey k2) v2 of - Nothing -> extractBinL l r - Just v' -> Bin k2 v' l r - - {-# INLINE binR1 #-} - binR1 k1 v1 l r = case missSingle miss1 (boundKey k1) v1 of - Nothing -> extractBinR l r - Just v' -> Bin k1 v' l r - - {-# INLINE binR2 #-} - binR2 k2 v2 l r = case missSingle miss2 (boundKey k2) v2 of - Nothing -> extractBinR l r - Just v' -> Bin k2 v' l r - - -- To avoid the messy pain of putting runIdentity everywhere, we use pure versions of the input functions. - {-# INLINE missSingle #-} - missSingle whenMiss k v = runIdentity (missingSingle whenMiss k v) - - {-# INLINE missLeft #-} - missLeft whenMiss l = runIdentity (missingLeft whenMiss l) - - {-# INLINE missRight #-} - missRight whenMiss r = runIdentity (missingRight whenMiss r) - - {-# INLINE missAllL #-} - missAllL whenMiss m = runIdentity (missingAllL whenMiss m) - - {-# INLINE missAllR #-} - missAllR whenMiss m = l2rMap (missAllL whenMiss (r2lMap m)) - - {-# INLINE matchSingle #-} - matchSingle whenMatch k v1 v2 = runIdentity (matchedSingle whenMatch k v1 v2) --} -- | An applicative version of 'merge'. Due to the necessity of performing actions -- in order, this can be significantly slower than 'merge'. From 3c30fcdfe4eb5bebbc832140986ba4f13ddaa0a4 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 16 Jan 2020 01:58:59 -0600 Subject: [PATCH 114/147] Pull more helper functions out of IntMap.mergeA to make it more regular and easier to follow --- containers/src/Data/IntMap/Merge/Internal.hs | 208 +++++++++++-------- 1 file changed, 117 insertions(+), 91 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index e5934a46e..16085e498 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -407,135 +407,161 @@ mergeA miss1 miss2 match = start where start (IntMap Empty) (IntMap !m2) = IntMap <$> missingAllL miss2 m2 start (IntMap !m1) (IntMap Empty) = IntMap <$> missingAllL miss1 m1 start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = (\v m -> IntMap (maybeInsertMin min1 v m)) <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 root1 min2 root2 - | min2 < min1 = (\v m -> IntMap (maybeInsertMin min2 v m)) <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 root1 min2 root2 - | otherwise = (\v m -> IntMap (maybeInsertMin min1 v m)) <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 root1 root2 - + | min1 < min2 = liftA2 (\v m -> IntMap (maybeNonEmptyL min1 v m)) (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 root1 min2 root2) + | min2 < min1 = liftA2 (\v m -> IntMap (maybeNonEmptyL min2 v m)) (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 root1 min2 root2) + | otherwise = liftA2 (\v m -> IntMap (maybeNonEmptyL min1 v m)) (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 root1 root2) + + -- TODO: These functions choose to return 'IntMap_'s instead of 'Node's, + -- even when 'Node's are more appropriate and efficient. This decision is + -- a necessary one, since the choice of whether to keep a key is hidden + -- behind the Applicative effects, but it isn't clear whether 'IntMap_' is + -- the right choice. In particular, keeping values around or deleting whole + -- subtrees seem to be the common cases, and the former prefers 'Nodes' and + -- the latter doesn't care much since there isn't any tall tree to push new + -- bounds into. goL1 minV1 !min1 !n1 !_ Tip = missingAllL miss1 (NonEmpty min1 minV1 n1) - goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = maybeUnionDisjointL min2 <$> missingLeft miss2 n2 <*> missingAllL miss1 (NonEmpty min1 minV1 n1) + goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = liftA2 (maybeUnionDisjointL min2) (missingLeft miss2 n2) (missingAllL miss1 (NonEmpty min1 minV1 n1)) goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> binL <$> goL1 minV1 min1 n1 min2 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) - | max1 > max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss2 l2 <*> goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 <*> missingSingle miss1 (boundKey max1) maxV1 - | max1 < max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max2 v rm))) <$> missingLeft miss2 l2 <*> goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 <*> missingSingle miss2 (boundKey max2) maxV2 - | otherwise -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss2 l2 <*> goRFused max1 (Bin min1 minV1 l1 r1) r2 <*> matchedSingle match (boundKey max1) maxV1 maxV2 - EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 (boundKey max1) maxV1 - | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 (boundKey max2) maxV2 - | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL1 minV1 min1 l1 min2 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match (boundKey max1) maxV1 maxV2 - GT -> binL <$> goL1 minV1 min1 l1 min2 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> liftA2 binL (goL1 minV1 min1 n1 min2 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) + | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (N (missingLeft miss2 l2)) (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (N (missingLeft miss2 l2)) (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (N (missingLeft miss2 l2)) (goRFused max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (I (goL1 minV1 min1 l1 min2 l2)) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (I (goL1 minV1 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (I (goL1 minV1 min1 l1 min2 l2)) (goRFused max1 r1 r2) + GT -> liftA2 binL (goL1 minV1 min1 l1 min2 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) goL2 minV2 !_ Tip !min2 !n2 = missingAllL miss2 (NonEmpty min2 minV2 n2) - goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = maybeUnionDisjointL min1 <$> missingLeft miss1 n1 <*> missingAllL miss2 (NonEmpty min2 minV2 n2) + goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = liftA2 (maybeUnionDisjointL min1) (missingLeft miss1 n1) (missingAllL miss2 (NonEmpty min2 minV2 n2)) goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> binL <$> goL2 minV2 min1 l1 min2 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) - | max1 > max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss1 l1 <*> goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) <*> missingSingle miss1 (boundKey max1) maxV1 - | max1 < max2 -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max2 v rm))) <$> missingLeft miss1 l1 <*> goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) <*> missingSingle miss2 (boundKey max2) maxV2 - | otherwise -> (\l' rm v -> nodeToMapL (maybeBinL l' (maybeInsertMax max1 v rm))) <$> missingLeft miss1 l1 <*> goRFused max1 r1 (Bin min2 minV2 l2 r2) <*> matchedSingle match (boundKey max1) maxV1 maxV2 - EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 (boundKey max1) maxV1 - | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 (boundKey max2) maxV2 - | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goL2 minV2 min1 l1 min2 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match (boundKey max1) maxV1 maxV2 - LT -> binL <$> goL2 minV2 min1 n1 min2 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> liftA2 binL (goL2 minV2 min1 l1 min2 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) + | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (N (missingLeft miss1 l1)) (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (N (missingLeft miss1 l1)) (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (N (missingLeft miss1 l1)) (goRFused max1 r1 (Bin min2 minV2 l2 r2)) + EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (I (goL2 minV2 min1 l1 min2 l2)) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (I (goL2 minV2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (I (goL2 minV2 min1 l1 min2 l2)) (goRFused max1 r1 r2) + LT -> liftA2 binL (goL2 minV2 min1 n1 min2 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) goLFused !_ Tip !n2 = nodeToMapL <$> missingLeft miss2 n2 goLFused !_ !n1 Tip = nodeToMapL <$> missingLeft miss1 n1 goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> binL <$> goLFused min n1 l2 <*> missingAllR miss2 (NonEmpty max2 maxV2 r2) - EQ | max1 > max2 -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goLFused min l1 l2 <*> goR2 maxV2 max1 r1 max2 r2 <*> missingSingle miss1 (boundKey max1) maxV1 - | max1 < max2 -> (\l' rm v -> binL l' (maybeInsertMax max2 v rm)) <$> goLFused min l1 l2 <*> goR1 maxV1 max1 r1 max2 r2 <*> missingSingle miss2 (boundKey max2) maxV2 - | otherwise -> (\l' rm v -> binL l' (maybeInsertMax max1 v rm)) <$> goLFused min l1 l2 <*> goRFused max1 r1 r2 <*> matchedSingle match (boundKey max1) maxV1 maxV2 - GT -> binL <$> goLFused min l1 n2 <*> missingAllR miss1 (NonEmpty max1 maxV1 r1) + LT -> liftA2 binL (goLFused min n1 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) + EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (I (goLFused min l1 l2)) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (I (goLFused min l1 l2)) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (I (goLFused min l1 l2)) (goRFused max1 r1 r2) + GT -> liftA2 binL (goLFused min l1 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) goR1 maxV1 !max1 !n1 !_ Tip = missingAllR miss1 (NonEmpty max1 maxV1 n1) - goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = maybeUnionDisjointR max2 <$> missingAllR miss1 (NonEmpty max1 maxV1 n1) <*> missingRight miss2 n2 + goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = liftA2 (maybeUnionDisjointR max2) (missingAllR miss1 (NonEmpty max1 maxV1 n1)) (missingRight miss2 n2) goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goR1 maxV1 max1 n1 max2 r2 - | min1 < min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 <*> missingRight miss2 r2 - | min1 > min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min2 v lm) r')) <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 <*> missingRight miss2 r2 - | otherwise -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 (Bin max1 maxV1 l1 r1) l2 <*> missingRight miss2 r2 - EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 - | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goR1 maxV1 max1 r1 max2 r2 - | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 l1 l2 <*> goR1 maxV1 max1 r1 max2 r2 - GT -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goR1 maxV1 max1 r1 max2 n2 + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> liftA2 binR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goR1 maxV1 max1 n1 max2 r2) + | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) (N (missingRight miss2 r2)) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) (N (missingRight miss2 r2)) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) (N (missingRight miss2 r2)) + EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (I (goR1 maxV1 max1 r1 max2 r2)) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (I (goR1 maxV1 max1 r1 max2 r2)) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (I (goR1 maxV1 max1 r1 max2 r2)) + GT -> liftA2 binR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goR1 maxV1 max1 r1 max2 n2) goR2 maxV2 !_ Tip !max2 !n2 = missingAllR miss2 (NonEmpty max2 maxV2 n2) - goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = maybeUnionDisjointR max1 <$> missingAllR miss2 (NonEmpty max2 maxV2 n2) <*> missingRight miss1 n1 + goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = liftA2 (maybeUnionDisjointR max1) (missingAllR miss2 (NonEmpty max2 maxV2 n2)) (missingRight miss1 n1) goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max1) max2) max1 n1 goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goR2 maxV2 max1 r1 max2 n2 - | min1 < min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 - | min1 > min2 -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min2 v lm) r')) <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 - | otherwise -> (\v lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min1 v lm) r')) <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 l1 (Bin max2 maxV2 l2 r2) <*> missingRight miss1 r1 - EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 - | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goR2 maxV2 max1 r1 max2 r2 - | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 l1 l2 <*> goR2 maxV2 max1 r1 max2 r2 - LT -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goR2 maxV2 max1 n1 max2 r2 + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> liftA2 binR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goR2 maxV2 max1 r1 max2 n2) + | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (N (missingRight miss1 r1)) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (N (missingRight miss1 r1)) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) (N (missingRight miss1 r1)) + EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (I (goR2 maxV2 max1 r1 max2 r2)) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (I (goR2 maxV2 max1 r1 max2 r2)) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (I (goR2 maxV2 max1 r1 max2 r2)) + LT -> liftA2 binR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goR2 maxV2 max1 n1 max2 r2) goRFused !_ Tip !n2 = nodeToMapR <$> missingRight miss2 n2 goRFused !_ !n1 Tip = nodeToMapR <$> missingRight miss1 n1 goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> binR <$> missingAllL miss2 (NonEmpty min2 minV2 l2) <*> goRFused max n1 r2 - EQ | min1 < min2 -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> missingSingle miss1 (boundKey min1) minV1 <*> goL2 minV2 min1 l1 min2 l2 <*> goRFused max r1 r2 - | min1 > min2 -> (\v lm r' -> binR (maybeInsertMin min2 v lm) r') <$> missingSingle miss2 (boundKey min2) minV2 <*> goL1 minV1 min1 l1 min2 l2 <*> goRFused max r1 r2 - | otherwise -> (\v lm r' -> binR (maybeInsertMin min1 v lm) r') <$> matchedSingle match (boundKey min1) minV1 minV2 <*> goLFused min1 l1 l2 <*> goRFused max r1 r2 - GT -> binR <$> missingAllL miss1 (NonEmpty min1 minV1 l1) <*> goRFused max r1 n2 + LT -> liftA2 binR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goRFused max n1 r2) + EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (I (goRFused max r1 r2)) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (I (goRFused max r1 r2)) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (I (goRFused max r1 r2)) + GT -> liftA2 binR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goRFused max r1 n2) - goInsertL1 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss1 k v + goInsertL1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 k v) goInsertL1 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> binL <$> goInsertL1 k v xorCache min l <*> missingAllR miss2 (NonEmpty max maxV r) - | otherwise -> (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss2 l <*> goInsertR1 k v xorCacheMax max r <*> missingSingle miss2 (boundKey max) maxV - OutOfBound -> (\n' v' -> r2lMap (maybeInsertMax (Bound k) v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss2 n <*> missingSingle miss1 k v - Matched -> (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss2 l <*> missingRight miss2 r <*> matchedSingle match k v maxV + InBound | xorCache < xorCacheMax -> liftA2 binL (goInsertL1 k v xorCache min l) (missingAllR miss2 (NonEmpty max maxV r)) + | otherwise -> makeBinL max (missingSingle miss2 (boundKey max) maxV) (N (missingLeft miss2 l)) (goInsertR1 k v xorCacheMax max r) + OutOfBound -> liftA2 (\n' v' -> r2lMap (maybeNonEmptyR (Bound k) v' (l2rMap (nodeToMapL n')))) (missingLeft miss2 n) (missingSingle miss1 k v) + Matched -> liftA3 (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) (missingLeft miss2 l) (missingRight miss2 r) (matchedSingle match k v maxV) where xorCacheMax = xor k max - goInsertL2 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss2 k v + goInsertL2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 k v) goInsertL2 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> binL <$> goInsertL2 k v xorCache min l <*> missingAllR miss1 (NonEmpty max maxV r) - | otherwise -> (\l' rm maxV' -> nodeToMapL (maybeBinL l' (maybeInsertMax max maxV' rm))) <$> missingLeft miss1 l <*> goInsertR2 k v xorCacheMax max r <*> missingSingle miss1 (boundKey max) maxV - OutOfBound -> (\n' v' -> r2lMap (maybeInsertMax (Bound k) v' (l2rMap (nodeToMapL n')))) <$> missingLeft miss1 n <*> missingSingle miss2 k v - Matched -> (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) <$> missingLeft miss1 l <*> missingRight miss1 r <*> matchedSingle match k maxV v + InBound | xorCache < xorCacheMax -> liftA2 binL (goInsertL2 k v xorCache min l) (missingAllR miss1 (NonEmpty max maxV r)) + | otherwise -> makeBinL max (missingSingle miss1 (boundKey max) maxV) (N (missingLeft miss1 l)) (goInsertR2 k v xorCacheMax max r) + OutOfBound -> liftA2 (\n' v' -> r2lMap (maybeNonEmptyR (Bound k) v' (l2rMap (nodeToMapL n')))) (missingLeft miss1 n) (missingSingle miss2 k v) + Matched -> liftA3 (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) (missingLeft miss1 l) (missingRight miss1 r) (matchedSingle match k maxV v) where xorCacheMax = xor k max - goInsertR1 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss1 k v + goInsertR1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 k v) goInsertR1 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> binR <$> missingAllL miss2 (NonEmpty min minV l) <*> goInsertR1 k v xorCache max r - | otherwise -> (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss2 (boundKey min) minV <*> goInsertL1 k v xorCacheMin min l <*> missingRight miss2 r - OutOfBound -> (\v' n' -> l2rMap (maybeInsertMin (Bound k) v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss1 k v <*> missingRight miss2 n - Matched -> (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match k v minV <*> missingLeft miss2 l <*> missingRight miss2 r + InBound | xorCache < xorCacheMin -> liftA2 binR (missingAllL miss2 (NonEmpty min minV l)) (goInsertR1 k v xorCache max r) + | otherwise -> makeBinR min (missingSingle miss2 (boundKey min) minV) (goInsertL1 k v xorCacheMin min l) (N (missingRight miss2 r)) + OutOfBound -> liftA2 (\v' n' -> l2rMap (maybeNonEmptyL (Bound k) v' (r2lMap (nodeToMapR n')))) (missingSingle miss1 k v) (missingRight miss2 n) + Matched -> liftA3 (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) (matchedSingle match k v minV) (missingLeft miss2 l) (missingRight miss2 r) where xorCacheMin = xor k min - goInsertR2 !k v !_ _ Tip = maybeSingleton k <$> missingSingle miss2 k v + goInsertR2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 k v) goInsertR2 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> binR <$> missingAllL miss1 (NonEmpty min minV l) <*> goInsertR2 k v xorCache max r - | otherwise -> (\minV' lm r' -> nodeToMapR (maybeBinR (maybeInsertMin min minV' lm) r')) <$> missingSingle miss1 (boundKey min) minV <*> goInsertL2 k v xorCacheMin min l <*> missingRight miss1 r - OutOfBound -> (\v' n' -> l2rMap (maybeInsertMin (Bound k) v' (r2lMap (nodeToMapR n')))) <$> missingSingle miss2 k v <*> missingRight miss1 n - Matched -> (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) <$> matchedSingle match k minV v <*> missingLeft miss1 l <*> missingRight miss1 r + InBound | xorCache < xorCacheMin -> liftA2 binR (missingAllL miss1 (NonEmpty min minV l)) (goInsertR2 k v xorCache max r) + | otherwise -> makeBinR min (missingSingle miss1 (boundKey min) minV) (goInsertL2 k v xorCacheMin min l) (N (missingRight miss1 r)) + OutOfBound -> liftA2 (\v' n' -> l2rMap (maybeNonEmptyL (Bound k) v' (r2lMap (nodeToMapR n')))) (missingSingle miss2 k v) (missingRight miss1 n) + Matched -> liftA3 (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) (matchedSingle match k minV v) (missingLeft miss1 l) (missingRight miss1 r) where xorCacheMin = xor k min missingAllR whenMiss = fmap l2rMap . missingAllL whenMiss . r2lMap -maybeSingleton :: Key -> Maybe v -> IntMap_ d v -maybeSingleton !_ Nothing = Empty -maybeSingleton !k (Just v) = NonEmpty (Bound k) v Tip - -maybeBinL :: Node L v -> IntMap_ R v -> Node L v -maybeBinL l Empty = l -maybeBinL l (NonEmpty max maxV r) = Bin max maxV l r - -maybeBinR :: IntMap_ L v -> Node R v -> Node R v -maybeBinR Empty r = r -maybeBinR (NonEmpty min minV l) r = Bin min minV l r - -maybeInsertMin :: Bound L -> Maybe v -> IntMap_ L v -> IntMap_ L v -maybeInsertMin !_ Nothing !m = m -maybeInsertMin !k (Just v) Empty = NonEmpty k v Tip -maybeInsertMin !k (Just v) (NonEmpty min minV root) = NonEmpty k v (insertMinL (xor (boundKey min) k) min minV root) - -maybeInsertMax :: Bound R -> Maybe v -> IntMap_ R v -> IntMap_ R v -maybeInsertMax !_ Nothing !m = m -maybeInsertMax !k (Just v) Empty = NonEmpty k v Tip -maybeInsertMax !k (Just v) (NonEmpty max maxV root) = NonEmpty k v (insertMaxR (xor (boundKey max) k) max maxV root) +data NodeOrIntMap_ f t a = N (f (Node t a)) | I (f (IntMap_ t a)) + +{-# INLINE makeSingleton #-} +makeSingleton :: Functor f => Key -> f (Maybe v) -> f (IntMap_ d v) +makeSingleton !k v = make <$> v where + make Nothing = Empty + make (Just v') = NonEmpty (Bound k) v' Tip + +{-# INLINE makeBinL #-} +makeBinL :: Applicative f => Bound R -> f (Maybe v) -> NodeOrIntMap_ f L v -> f (IntMap_ R v) -> f (IntMap_ L v) +makeBinL !max maxV (N l) r = liftA3 make l r maxV where + make l' r' maxV' = nodeToMapL (binNodeMapL l' (maybeNonEmptyR max maxV' r')) +makeBinL !max maxV (I l) r = liftA3 make l r maxV where + make l' r' maxV' = binL l' (maybeNonEmptyR max maxV' r') + +{-# INLINE makeBinR #-} +makeBinR :: Applicative f => Bound L -> f (Maybe v) -> f (IntMap_ L v) -> NodeOrIntMap_ f R v -> f (IntMap_ R v) +makeBinR !min minV l (N r) = liftA3 make minV l r where + make minV' l' r' = nodeToMapR (binMapNodeR (maybeNonEmptyL min minV' l') r') +makeBinR !min minV l (I r) = liftA3 make minV l r where + make minV' l' r' = binR (maybeNonEmptyL min minV' l') r' + +binNodeMapL :: Node L v -> IntMap_ R v -> Node L v +binNodeMapL l Empty = l +binNodeMapL l (NonEmpty max maxV r) = Bin max maxV l r + +binMapNodeR :: IntMap_ L v -> Node R v -> Node R v +binMapNodeR Empty r = r +binMapNodeR (NonEmpty min minV l) r = Bin min minV l r + +maybeNonEmptyL :: Bound L -> Maybe v -> IntMap_ L v -> IntMap_ L v +maybeNonEmptyL !_ Nothing !m = m +maybeNonEmptyL !k (Just v) Empty = NonEmpty k v Tip +maybeNonEmptyL !k (Just v) (NonEmpty min minV root) = NonEmpty k v (insertMinL (xor (boundKey min) k) min minV root) + +maybeNonEmptyR :: Bound R -> Maybe v -> IntMap_ R v -> IntMap_ R v +maybeNonEmptyR !_ Nothing !m = m +maybeNonEmptyR !k (Just v) Empty = NonEmpty k v Tip +maybeNonEmptyR !k (Just v) (NonEmpty max maxV root) = NonEmpty k v (insertMaxR (xor (boundKey max) k) max maxV root) maybeUnionDisjointL :: Bound L -> Node L v -> IntMap_ L v -> IntMap_ L v maybeUnionDisjointL !_ Tip !m2 = m2 From 754bace5afa7574c6e579535c348b5dfdd33a428 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 16 Jan 2020 02:11:02 -0600 Subject: [PATCH 115/147] Add a TODO for further optimization of IntMap.mergeA --- containers/src/Data/IntMap/Merge/Internal.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 16085e498..7f61ec317 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -102,6 +102,14 @@ instance Applicative Identity where -- A tactic of type @ WhenMissing f a c @ is an abstract representation -- of a function of type @ Key -> a -> f (Maybe c) @. data WhenMissing f a b = WhenMissing { + -- TODO: Instead of unconditionally putting the 'Maybe' inside the @f@, + -- provide options for the deletion vs. not choice to be decided purely, + -- before Applicative effects. Most merge tactics (all but 'filterAMissing' + -- and 'Data.IntMap.Merge.Lazy.traverseMaybeMissing', it seems) can support + -- this more precise representation, and it would allow 'mergeA' to make an + -- optimized choice between 'Node' and 'IntMap_' intermediates. By changing + -- its arguments into that form, 'merge' might even be implementable as + -- efficiently as possible in terms of 'mergeA'. missingSingle :: Key -> a -> f (Maybe b), missingLeft :: Node L a -> f (Node L b), missingRight :: Node R a -> f (Node R b), From 95346c4edaddd585a73627861b0963ac34d64d94 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 16 Jan 2020 12:21:01 -0600 Subject: [PATCH 116/147] Make IntMap.mergeA intermediates be 'Node's instead of 'IntMap_'s. This is a better default. Performance of emulated set operations: ``` Benchmark Runtime change Original runtime union-block_nn -68.54% 3.22e-04 union-block_nn_swap -68.48% 3.25e-04 union-block_ns -72.29% 3.07e-05 union-block_sn_swap -71.45% 2.96e-05 union-common_nn -30.16% 8.77e-03 union-common_nn_swap -29.29% 8.79e-03 union-common_ns -41.95% 5.25e-03 union-common_nt -71.12% 3.07e-04 union-common_sn_swap -41.13% 5.28e-03 union-common_tn_swap -70.80% 3.05e-04 union-disj_nn -41.68% 5.31e-07 union-disj_nn_swap -41.60% 5.29e-07 union-disj_ns -39.85% 4.85e-07 union-disj_nt -40.96% 4.60e-07 union-disj_sn_swap -39.23% 4.83e-07 union-disj_tn_swap -40.14% 4.58e-07 union-mix_nn -12.99% 1.84e-02 union-mix_nn_swap -12.13% 1.84e-02 union-mix_ns -38.42% 6.15e-03 union-mix_nt -70.42% 3.15e-04 union-mix_sn_swap -37.90% 6.16e-03 union-mix_tn_swap -69.66% 3.13e-04 difference-block_nn -50.46% 9.41e-05 difference-block_nn_swap -51.39% 9.60e-05 difference-block_ns -77.93% 2.04e-05 difference-block_sn_swap +17.45% 5.10e-06 difference-common_nn -6.65% 4.97e-03 difference-common_nn_swap +15.19% 1.78e-03 difference-common_ns -38.85% 4.83e-03 difference-common_nt -68.30% 3.06e-04 difference-common_sn_swap +4.23% 6.76e-04 difference-common_tn_swap -8.55% 5.55e-05 difference-disj_nn -49.66% 3.82e-07 difference-disj_nn_swap +18.57% 1.81e-07 difference-disj_ns -49.68% 3.83e-07 difference-disj_nt -49.66% 3.83e-07 difference-disj_sn_swap +12.56% 1.81e-07 difference-disj_tn_swap +12.49% 1.81e-07 difference-mix_nn -1.75% 1.02e-02 difference-mix_nn_swap +5.63% 1.07e-02 difference-mix_ns -44.41% 5.12e-03 difference-mix_nt -71.67% 2.96e-04 difference-mix_sn_swap +16.03% 1.36e-03 difference-mix_tn_swap +8.87% 5.93e-05 intersection-block_nn -8.29% 2.47e-05 intersection-block_nn_swap -7.81% 2.46e-05 intersection-block_ns -7.87% 3.62e-06 intersection-block_sn_swap -9.48% 3.61e-06 intersection-common_nn +6.61% 5.07e-03 intersection-common_nn_swap +8.06% 5.02e-03 intersection-common_ns +16.16% 1.43e-03 intersection-common_nt +6.47% 6.21e-05 intersection-common_sn_swap +14.00% 1.44e-03 intersection-common_tn_swap +6.42% 6.28e-05 intersection-disj_nn -0.04% 1.83e-07 intersection-disj_nn_swap +1.29% 1.82e-07 intersection-disj_ns -0.35% 1.83e-07 intersection-disj_nt -1.47% 1.84e-07 intersection-disj_sn_swap -0.02% 1.82e-07 intersection-disj_tn_swap +0.72% 1.81e-07 intersection-mix_nn +11.37% 3.75e-03 intersection-mix_nn_swap +12.63% 3.73e-03 intersection-mix_ns -3.15% 6.37e-04 intersection-mix_nt -1.57% 4.90e-05 intersection-mix_sn_swap -4.83% 6.56e-04 intersection-mix_tn_swap -3.23% 5.00e-05 Minimum -77.93% Average -29.63% Maximum +18.57% ``` --- containers/src/Data/IntMap/Merge/Internal.hs | 254 ++++++++++--------- 1 file changed, 133 insertions(+), 121 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 7f61ec317..938ef2463 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -336,11 +336,11 @@ runWhenMatched = matchedSingle -- TODO: Implementing 'merge' in terms of 'mergeA' leaves a lot to be desired -- on the performance front. Because the choice of whether to delete a key is -- hidden behind Applicative effects, 'mergeA' must conservatively return --- 'IntMap_'s from every intermediate function, even when a 'Node' would be --- more efficient and appropriate. (It could return 'Node's everywhere instead, --- but that would have the same problem in the opposite direction.) 'merge' --- has no such limitation, since recursion schemes and decisions about what --- types of structures to return can be made based on the results of pure +-- 'Node's from every intermediate function, even when an 'IntMap_' would be +-- more efficient and appropriate. (It could return 'IntMap_'s everywhere +-- instead, but that would have the same problem in the opposite direction.) +-- 'merge' has no such limitation, since recursion schemes and decisions about +-- what types of structures to return can be made based on the results of pure -- tactics. merge :: SimpleWhenMissing a c -> SimpleWhenMissing b c -> SimpleWhenMatched a b c -> IntMap a -> IntMap b -> IntMap c merge miss1 miss2 match = \m1 m2 -> runIdentity (mergeA miss1 miss2 match m1 m2) @@ -415,143 +415,143 @@ mergeA miss1 miss2 match = start where start (IntMap Empty) (IntMap !m2) = IntMap <$> missingAllL miss2 m2 start (IntMap !m1) (IntMap Empty) = IntMap <$> missingAllL miss1 m1 start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = liftA2 (\v m -> IntMap (maybeNonEmptyL min1 v m)) (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 root1 min2 root2) - | min2 < min1 = liftA2 (\v m -> IntMap (maybeNonEmptyL min2 v m)) (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 root1 min2 root2) - | otherwise = liftA2 (\v m -> IntMap (maybeNonEmptyL min1 v m)) (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 root1 root2) - - -- TODO: These functions choose to return 'IntMap_'s instead of 'Node's, - -- even when 'Node's are more appropriate and efficient. This decision is - -- a necessary one, since the choice of whether to keep a key is hidden - -- behind the Applicative effects, but it isn't clear whether 'IntMap_' is - -- the right choice. In particular, keeping values around or deleting whole - -- subtrees seem to be the common cases, and the former prefers 'Nodes' and - -- the latter doesn't care much since there isn't any tall tree to push new - -- bounds into. - goL1 minV1 !min1 !n1 !_ Tip = missingAllL miss1 (NonEmpty min1 minV1 n1) + | min1 < min2 = makeIntMapNE min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 root1 min2 root2) + | min2 < min1 = makeIntMapNE min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 root1 min2 root2) + | otherwise = makeIntMapNE min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 root1 root2) + + goL1 minV1 !min1 !n1 !min2 Tip = mapToNodeL min2 <$> missingAllL miss1 (NonEmpty min1 minV1 n1) goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = liftA2 (maybeUnionDisjointL min2) (missingLeft miss2 n2) (missingAllL miss1 (NonEmpty min1 minV1 n1)) goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> liftA2 binL (goL1 minV1 min1 n1 min2 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) - | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (N (missingLeft miss2 l2)) (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (N (missingLeft miss2 l2)) (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (N (missingLeft miss2 l2)) (goRFused max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (I (goL1 minV1 min1 l1 min2 l2)) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (I (goL1 minV1 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (I (goL1 minV1 min1 l1 min2 l2)) (goRFused max1 r1 r2) - GT -> liftA2 binL (goL1 minV1 min1 l1 min2 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) - - goL2 minV2 !_ Tip !min2 !n2 = missingAllL miss2 (NonEmpty min2 minV2 n2) + LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> liftA2 binNodeMapL (goL1 minV1 min1 n1 min2 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) + | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (missingLeft miss2 l2) (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (missingLeft miss2 l2) (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (missingLeft miss2 l2) (goRFused max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) + GT -> liftA2 binNodeMapL (goL1 minV1 min1 l1 min2 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) + + goL2 minV2 !min1 Tip !min2 !n2 = mapToNodeL min1 <$> missingAllL miss2 (NonEmpty min2 minV2 n2) goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = liftA2 (maybeUnionDisjointL min1) (missingLeft miss1 n1) (missingAllL miss2 (NonEmpty min2 minV2 n2)) goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> liftA2 binL (goL2 minV2 min1 l1 min2 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) - | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (N (missingLeft miss1 l1)) (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (N (missingLeft miss1 l1)) (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (N (missingLeft miss1 l1)) (goRFused max1 r1 (Bin min2 minV2 l2 r2)) - EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (I (goL2 minV2 min1 l1 min2 l2)) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (I (goL2 minV2 min1 l1 min2 l2)) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (I (goL2 minV2 min1 l1 min2 l2)) (goRFused max1 r1 r2) - LT -> liftA2 binL (goL2 minV2 min1 n1 min2 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) - - goLFused !_ Tip !n2 = nodeToMapL <$> missingLeft miss2 n2 - goLFused !_ !n1 Tip = nodeToMapL <$> missingLeft miss1 n1 + GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> liftA2 binNodeMapL (goL2 minV2 min1 l1 min2 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) + | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (missingLeft miss1 l1) (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (missingLeft miss1 l1) (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (missingLeft miss1 l1) (goRFused max1 r1 (Bin min2 minV2 l2 r2)) + EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) + LT -> liftA2 binNodeMapL (goL2 minV2 min1 n1 min2 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) + + goLFused !_ Tip !n2 = missingLeft miss2 n2 + goLFused !_ !n1 Tip = missingLeft miss1 n1 goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of - LT -> liftA2 binL (goLFused min n1 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) - EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (I (goLFused min l1 l2)) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (I (goLFused min l1 l2)) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (I (goLFused min l1 l2)) (goRFused max1 r1 r2) - GT -> liftA2 binL (goLFused min l1 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) + LT -> liftA2 binNodeMapL (goLFused min n1 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) + EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (goLFused min l1 l2) (goRFused max1 r1 r2) + GT -> liftA2 binNodeMapL (goLFused min l1 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) - goR1 maxV1 !max1 !n1 !_ Tip = missingAllR miss1 (NonEmpty max1 maxV1 n1) + goR1 maxV1 !max1 !n1 !max2 Tip = mapToNodeR max2 <$> missingAllR miss1 (NonEmpty max1 maxV1 n1) goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = liftA2 (maybeUnionDisjointR max2) (missingAllR miss1 (NonEmpty max1 maxV1 n1)) (missingRight miss2 n2) goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> liftA2 binR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goR1 maxV1 max1 n1 max2 r2) - | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) (N (missingRight miss2 r2)) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) (N (missingRight miss2 r2)) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) (N (missingRight miss2 r2)) - EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (I (goR1 maxV1 max1 r1 max2 r2)) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (I (goR1 maxV1 max1 r1 max2 r2)) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (I (goR1 maxV1 max1 r1 max2 r2)) - GT -> liftA2 binR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goR1 maxV1 max1 r1 max2 n2) - - goR2 maxV2 !_ Tip !max2 !n2 = missingAllR miss2 (NonEmpty max2 maxV2 n2) + LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> liftA2 binMapNodeR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goR1 maxV1 max1 n1 max2 r2) + | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) (missingRight miss2 r2) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) (missingRight miss2 r2) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) (missingRight miss2 r2) + EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) + GT -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goR1 maxV1 max1 r1 max2 n2) + + goR2 maxV2 !max1 Tip !max2 !n2 = mapToNodeR max1 <$> missingAllR miss2 (NonEmpty max2 maxV2 n2) goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = liftA2 (maybeUnionDisjointR max1) (missingAllR miss2 (NonEmpty max2 maxV2 n2)) (missingRight miss1 n1) goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max1) max2) max1 n1 goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of - GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> liftA2 binR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goR2 maxV2 max1 r1 max2 n2) - | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (N (missingRight miss1 r1)) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (N (missingRight miss1 r1)) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) (N (missingRight miss1 r1)) - EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (I (goR2 maxV2 max1 r1 max2 r2)) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (I (goR2 maxV2 max1 r1 max2 r2)) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (I (goR2 maxV2 max1 r1 max2 r2)) - LT -> liftA2 binR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goR2 maxV2 max1 n1 max2 r2) - - goRFused !_ Tip !n2 = nodeToMapR <$> missingRight miss2 n2 - goRFused !_ !n1 Tip = nodeToMapR <$> missingRight miss1 n1 + GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goR2 maxV2 max1 r1 max2 n2) + | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (missingRight miss1 r1) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (missingRight miss1 r1) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) (missingRight miss1 r1) + EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) + LT -> liftA2 binMapNodeR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goR2 maxV2 max1 n1 max2 r2) + + goRFused !_ Tip !n2 = missingRight miss2 n2 + goRFused !_ !n1 Tip = missingRight miss1 n1 goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of - LT -> liftA2 binR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goRFused max n1 r2) - EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (I (goRFused max r1 r2)) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (I (goRFused max r1 r2)) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (I (goRFused max r1 r2)) - GT -> liftA2 binR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goRFused max r1 n2) + LT -> liftA2 binMapNodeR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goRFused max n1 r2) + EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) + | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goRFused max r1 r2) + GT -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goRFused max r1 n2) goInsertL1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 k v) goInsertL1 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> liftA2 binL (goInsertL1 k v xorCache min l) (missingAllR miss2 (NonEmpty max maxV r)) - | otherwise -> makeBinL max (missingSingle miss2 (boundKey max) maxV) (N (missingLeft miss2 l)) (goInsertR1 k v xorCacheMax max r) - OutOfBound -> liftA2 (\n' v' -> r2lMap (maybeNonEmptyR (Bound k) v' (l2rMap (nodeToMapL n')))) (missingLeft miss2 n) (missingSingle miss1 k v) - Matched -> liftA3 (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) (missingLeft miss2 l) (missingRight miss2 r) (matchedSingle match k v maxV) + InBound | xorCache < xorCacheMax -> liftA2 binNodeMapL (goInsertL1 k v xorCache min l) (missingAllR miss2 (NonEmpty max maxV r)) + | otherwise -> makeBinL max (missingSingle miss2 (boundKey max) maxV) (missingLeft miss2 l) (goInsertR1 k v xorCacheMax max r) + OutOfBound -> addMaxL min (Bound k) (missingSingle miss1 k v) (missingLeft miss2 n) + Matched -> makeBinL max (matchedSingle match k v maxV) (missingLeft miss2 l) (missingRight miss2 r) where xorCacheMax = xor k max goInsertL2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 k v) goInsertL2 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> liftA2 binL (goInsertL2 k v xorCache min l) (missingAllR miss1 (NonEmpty max maxV r)) - | otherwise -> makeBinL max (missingSingle miss1 (boundKey max) maxV) (N (missingLeft miss1 l)) (goInsertR2 k v xorCacheMax max r) - OutOfBound -> liftA2 (\n' v' -> r2lMap (maybeNonEmptyR (Bound k) v' (l2rMap (nodeToMapL n')))) (missingLeft miss1 n) (missingSingle miss2 k v) - Matched -> liftA3 (\l' r' v' -> nodeToMapL (maybe extractBinL (Bin max) v' l' r')) (missingLeft miss1 l) (missingRight miss1 r) (matchedSingle match k maxV v) + InBound | xorCache < xorCacheMax -> liftA2 binNodeMapL (goInsertL2 k v xorCache min l) (missingAllR miss1 (NonEmpty max maxV r)) + | otherwise -> makeBinL max (missingSingle miss1 (boundKey max) maxV) (missingLeft miss1 l) (goInsertR2 k v xorCacheMax max r) + OutOfBound -> addMaxL min (Bound k) (missingSingle miss2 k v) (missingLeft miss1 n) + Matched -> makeBinL max (matchedSingle match k maxV v) (missingLeft miss1 l) (missingRight miss1 r) where xorCacheMax = xor k max goInsertR1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 k v) goInsertR1 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> liftA2 binR (missingAllL miss2 (NonEmpty min minV l)) (goInsertR1 k v xorCache max r) - | otherwise -> makeBinR min (missingSingle miss2 (boundKey min) minV) (goInsertL1 k v xorCacheMin min l) (N (missingRight miss2 r)) - OutOfBound -> liftA2 (\v' n' -> l2rMap (maybeNonEmptyL (Bound k) v' (r2lMap (nodeToMapR n')))) (missingSingle miss1 k v) (missingRight miss2 n) - Matched -> liftA3 (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) (matchedSingle match k v minV) (missingLeft miss2 l) (missingRight miss2 r) + InBound | xorCache < xorCacheMin -> liftA2 binMapNodeR (missingAllL miss2 (NonEmpty min minV l)) (goInsertR1 k v xorCache max r) + | otherwise -> makeBinR min (missingSingle miss2 (boundKey min) minV) (goInsertL1 k v xorCacheMin min l) (missingRight miss2 r) + OutOfBound -> addMinR max (Bound k) (missingSingle miss1 k v) (missingRight miss2 n) + Matched -> makeBinR min (matchedSingle match k v minV) (missingLeft miss2 l) (missingRight miss2 r) where xorCacheMin = xor k min goInsertR2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 k v) goInsertR2 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> liftA2 binR (missingAllL miss1 (NonEmpty min minV l)) (goInsertR2 k v xorCache max r) - | otherwise -> makeBinR min (missingSingle miss1 (boundKey min) minV) (goInsertL2 k v xorCacheMin min l) (N (missingRight miss1 r)) - OutOfBound -> liftA2 (\v' n' -> l2rMap (maybeNonEmptyL (Bound k) v' (r2lMap (nodeToMapR n')))) (missingSingle miss2 k v) (missingRight miss1 n) - Matched -> liftA3 (\v' l' r' -> nodeToMapR (maybe extractBinR (Bin min) v' l' r')) (matchedSingle match k minV v) (missingLeft miss1 l) (missingRight miss1 r) + InBound | xorCache < xorCacheMin -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min minV l)) (goInsertR2 k v xorCache max r) + | otherwise -> makeBinR min (missingSingle miss1 (boundKey min) minV) (goInsertL2 k v xorCacheMin min l) (missingRight miss1 r) + OutOfBound -> addMinR max (Bound k) (missingSingle miss2 k v) (missingRight miss1 n) + Matched -> makeBinR min (matchedSingle match k minV v) (missingLeft miss1 l) (missingRight miss1 r) where xorCacheMin = xor k min missingAllR whenMiss = fmap l2rMap . missingAllL whenMiss . r2lMap -data NodeOrIntMap_ f t a = N (f (Node t a)) | I (f (IntMap_ t a)) - {-# INLINE makeSingleton #-} -makeSingleton :: Functor f => Key -> f (Maybe v) -> f (IntMap_ d v) +makeSingleton :: Functor f => Key -> f (Maybe v) -> f (Node d v) makeSingleton !k v = make <$> v where - make Nothing = Empty - make (Just v') = NonEmpty (Bound k) v' Tip + make Nothing = Tip + make (Just v') = Bin (Bound k) v' Tip Tip {-# INLINE makeBinL #-} -makeBinL :: Applicative f => Bound R -> f (Maybe v) -> NodeOrIntMap_ f L v -> f (IntMap_ R v) -> f (IntMap_ L v) -makeBinL !max maxV (N l) r = liftA3 make l r maxV where - make l' r' maxV' = nodeToMapL (binNodeMapL l' (maybeNonEmptyR max maxV' r')) -makeBinL !max maxV (I l) r = liftA3 make l r maxV where - make l' r' maxV' = binL l' (maybeNonEmptyR max maxV' r') +makeBinL :: Applicative f => Bound R -> f (Maybe v) -> f (Node L v) -> f (Node R v) -> f (Node L v) +makeBinL !max maxV l r = liftA3 make l r maxV where + make l' r' maxV' = maybe extractBinL (Bin max) maxV' l' r' {-# INLINE makeBinR #-} -makeBinR :: Applicative f => Bound L -> f (Maybe v) -> f (IntMap_ L v) -> NodeOrIntMap_ f R v -> f (IntMap_ R v) -makeBinR !min minV l (N r) = liftA3 make minV l r where - make minV' l' r' = nodeToMapR (binMapNodeR (maybeNonEmptyL min minV' l') r') -makeBinR !min minV l (I r) = liftA3 make minV l r where - make minV' l' r' = binR (maybeNonEmptyL min minV' l') r' +makeBinR :: Applicative f => Bound L -> f (Maybe v) -> f (Node L v) -> f (Node R v) -> f (Node R v) +makeBinR !min minV l r = liftA3 make minV l r where + make minV' l' r' = maybe extractBinR (Bin min) minV' l' r' + +{-# INLINE makeIntMapNE #-} +makeIntMapNE :: Applicative f => Bound L -> f (Maybe v) -> f (Node L v) -> f (IntMap v) +makeIntMapNE !min minV root = liftA2 make minV root where + make Nothing root' = IntMap (nodeToMapL root') + make (Just minV') root' = IntMap (NonEmpty min minV' root') + +mapToNodeL :: Bound L -> IntMap_ L v -> Node L v +mapToNodeL !_ Empty = Tip +mapToNodeL !externalMin (NonEmpty min minV root) = insertMinL (xor (boundKey min) externalMin) min minV root + +mapToNodeR :: Bound R -> IntMap_ R v -> Node R v +mapToNodeR !_ Empty = Tip +mapToNodeR !externalMax (NonEmpty max maxV root) = insertMaxR (xor (boundKey max) externalMax) max maxV root binNodeMapL :: Node L v -> IntMap_ R v -> Node L v binNodeMapL l Empty = l @@ -561,22 +561,34 @@ binMapNodeR :: IntMap_ L v -> Node R v -> Node R v binMapNodeR Empty r = r binMapNodeR (NonEmpty min minV l) r = Bin min minV l r -maybeNonEmptyL :: Bound L -> Maybe v -> IntMap_ L v -> IntMap_ L v -maybeNonEmptyL !_ Nothing !m = m -maybeNonEmptyL !k (Just v) Empty = NonEmpty k v Tip -maybeNonEmptyL !k (Just v) (NonEmpty min minV root) = NonEmpty k v (insertMinL (xor (boundKey min) k) min minV root) - -maybeNonEmptyR :: Bound R -> Maybe v -> IntMap_ R v -> IntMap_ R v -maybeNonEmptyR !_ Nothing !m = m -maybeNonEmptyR !k (Just v) Empty = NonEmpty k v Tip -maybeNonEmptyR !k (Just v) (NonEmpty max maxV root) = NonEmpty k v (insertMaxR (xor (boundKey max) k) max maxV root) - -maybeUnionDisjointL :: Bound L -> Node L v -> IntMap_ L v -> IntMap_ L v -maybeUnionDisjointL !_ Tip !m2 = m2 -maybeUnionDisjointL !_ !n1 Empty = nodeToMapL n1 -maybeUnionDisjointL !min1 !n1 (NonEmpty min2 minV2 root2) = nodeToMapL (unionDisjointL minV2 min1 n1 min2 root2) - -maybeUnionDisjointR :: Bound R -> IntMap_ R v -> Node R v -> IntMap_ R v -maybeUnionDisjointR !_ !m1 Tip = m1 -maybeUnionDisjointR !_ Empty !n2 = nodeToMapR n2 -maybeUnionDisjointR !max2 (NonEmpty max1 maxV1 root1) !n2 = nodeToMapR (unionDisjointR maxV1 max1 root1 max2 n2) +{-# INLINE addMaxL #-} +addMaxL :: Applicative f => Bound L -> Bound R -> f (Maybe v) -> f (Node L v) -> f (Node L v) +addMaxL !min !k v n = liftA2 add n v where + add n' Nothing = n' + add Tip (Just v') = Bin k v' Tip Tip + add n'@(Bin max maxV l r) (Just v') + | xor (boundKey max) min < xorCacheMax = Bin k v' n' Tip + | otherwise = Bin k v' l (insertMaxR xorCacheMax max maxV r) + where + xorCacheMax = xor (boundKey max) k + +{-# INLINE addMinR #-} +addMinR :: Applicative f => Bound R -> Bound L -> f (Maybe v) -> f (Node R v) -> f (Node R v) +addMinR !max !k v n = liftA2 add v n where + add Nothing n' = n' + add (Just v') Tip = Bin k v' Tip Tip + add (Just v') n'@(Bin min minV l r) + | xor (boundKey min) max < xorCacheMin = Bin k v' Tip n' + | otherwise = Bin k v' (insertMinL xorCacheMin min minV l) r + where + xorCacheMin = xor (boundKey min) k + +maybeUnionDisjointL :: Bound L -> Node L v -> IntMap_ L v -> Node L v +maybeUnionDisjointL !min1 Tip !m2 = mapToNodeL min1 m2 +maybeUnionDisjointL !_ !n1 Empty = n1 +maybeUnionDisjointL !min1 !n1 (NonEmpty min2 minV2 root2) = unionDisjointL minV2 min1 n1 min2 root2 + +maybeUnionDisjointR :: Bound R -> IntMap_ R v -> Node R v -> Node R v +maybeUnionDisjointR !max2 !m1 Tip = mapToNodeR max2 m1 +maybeUnionDisjointR !_ Empty !n2 = n2 +maybeUnionDisjointR !max2 (NonEmpty max1 maxV1 root1) !n2 = unionDisjointR maxV1 max1 root1 max2 n2 From 49bebc695f0f3becd3c0a584788fcac35f1a506c Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 16 Jan 2020 13:31:38 -0600 Subject: [PATCH 117/147] Add a unboxed wrapper around boundKey to ease manual worker-wrapper transforms --- containers/src/Data/IntMap/Internal.hs | 35 +++++---- containers/src/Data/IntMap/Lazy.hs | 98 +++++++++++++------------- containers/src/Data/IntMap/Strict.hs | 98 +++++++++++++------------- 3 files changed, 119 insertions(+), 112 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 7a12a6ec5..649e94679 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -309,6 +309,7 @@ module Data.IntMap.Internal ( , box , unbox , Bound(..) + , boundUKey , BoundOrdering(..) , xor , xorBounds @@ -612,6 +613,12 @@ newtype Bound_ = Bound { boundKey :: Key } deriving (Eq, Ord, Show) data Flipped t #endif +-- | Extract the key from a 'Bound' and unbox it. Identical in functionality to +-- 'boundKey'. +{-# INLINE boundUKey #-} +boundUKey :: Bound t -> UKey +boundUKey b = unbox (boundKey b) + data BoundOrdering = InBound | OutOfBound | Matched deriving (Eq) {-# INLINE compareMinBound #-} @@ -2068,26 +2075,26 @@ filterWithUKey p = start where start (IntMap Empty) = IntMap Empty start (IntMap (NonEmpty min minV root)) - | p (unbox (boundKey min)) minV = IntMap (NonEmpty min minV (goL root)) + | p (boundUKey min) minV = IntMap (NonEmpty min minV (goL root)) | otherwise = IntMap (goDeleteL root) goL Tip = Tip goL (Bin max maxV l r) - | p (unbox (boundKey max)) maxV = Bin max maxV (goL l) (goR r) + | p (boundUKey max) maxV = Bin max maxV (goL l) (goR r) | otherwise = case goDeleteR r of Empty -> goL l NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' goR Tip = Tip goR (Bin min minV l r) - | p (unbox (boundKey min)) minV = Bin min minV (goL l) (goR r) + | p (boundUKey min) minV = Bin min minV (goL l) (goR r) | otherwise = case goDeleteL l of Empty -> goR r NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) goDeleteL Tip = Empty goDeleteL (Bin max maxV l r) - | p (unbox (boundKey max)) maxV = case goDeleteL l of + | p (boundUKey max) maxV = case goDeleteL l of Empty -> case goR r of Tip -> NonEmpty (maxToMin max) maxV Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) @@ -2096,7 +2103,7 @@ filterWithUKey p = start goDeleteR Tip = Empty goDeleteR (Bin min minV l r) - | p (unbox (boundKey min)) minV = case goDeleteR r of + | p (boundUKey min) minV = case goDeleteR r of Empty -> case goL l of Tip -> NonEmpty (minToMax min) minV Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) @@ -2151,16 +2158,16 @@ partitionWithUKey p = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) start (IntMap (NonEmpty min minV root)) - | p (unbox (boundKey min)) minV = let t :*: f = goTrueL root + | p (boundUKey min) minV = let t :*: f = goTrueL root in (IntMap (NonEmpty min minV t), IntMap f) | otherwise = let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min minV f)) goTrueL Tip = Tip :*: Empty goTrueL (Bin max maxV l r) - | p (unbox (boundKey max)) maxV = let tl :*: fl = goTrueL l - tr :*: fr = goTrueR r - in Bin max maxV tl tr :*: binL fl fr + | p (boundUKey max) maxV = let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin max maxV tl tr :*: binL fl fr | otherwise = let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of @@ -2173,9 +2180,9 @@ partitionWithUKey p = start goTrueR Tip = Tip :*: Empty goTrueR (Bin min minV l r) - | p (unbox (boundKey min)) minV = let tl :*: fl = goTrueL l - tr :*: fr = goTrueR r - in Bin min minV tl tr :*: binR fl fr + | p (boundUKey min) minV = let tl :*: fl = goTrueL l + tr :*: fr = goTrueR r + in Bin min minV tl tr :*: binR fl fr | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -2188,7 +2195,7 @@ partitionWithUKey p = start goFalseL Tip = Empty :*: Tip goFalseL (Bin max maxV l r) - | p (unbox (boundKey max)) maxV = + | p (boundUKey max) maxV = let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -2204,7 +2211,7 @@ partitionWithUKey p = start goFalseR Tip = Empty :*: Tip goFalseR (Bin min minV l r) - | p (unbox (boundKey min)) minV = + | p (boundUKey min) minV = let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 288539401..98bc8995c 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -536,7 +536,7 @@ unionWithUKey = start start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 combine minV1 min1 root1 min2 root2)) - | otherwise = IntMap (NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 goL1 _ minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip goL1 _ minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 @@ -546,10 +546,10 @@ unionWithUKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) l2 (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundUKey max1) maxV1 maxV2) l2 (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundUKey max1) maxV1 maxV2) (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 n2) r1 goL2 _ minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip @@ -560,10 +560,10 @@ unionWithUKey = start GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) l1 (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundUKey max1) maxV1 maxV2) l1 (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundUKey max1) maxV1 maxV2) (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 LT -> Bin max2 maxV2 (goL2 combine minV2 min1 n1 min2 l2) r2 -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same @@ -574,7 +574,7 @@ unionWithUKey = start LT -> Bin max2 maxV2 (goLFused combine min n1 l2) r2 EQ | max1 > max2 -> Bin max1 maxV1 (goLFused combine min l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundUKey max1) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused combine min l1 n2) r1 goR1 _ maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip @@ -585,10 +585,10 @@ unionWithUKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 combine maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) r2 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 combine maxV1 max1 r1 max2 n2) goR2 _ maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip @@ -599,10 +599,10 @@ unionWithUKey = start GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) r1 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 LT -> Bin min2 minV2 l2 (goR2 combine maxV2 max1 n1 max2 r2) -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same @@ -613,7 +613,7 @@ unionWithUKey = start LT -> Bin min2 minV2 l2 (goRFused combine max n1 r2) EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max r1 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) - | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goRFused combine max r1 n2) goInsertL1 _ k v !_ _ Tip = Bin (Bound k) v Tip Tip @@ -689,7 +689,7 @@ differenceWithUKey = start start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) - | otherwise = case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise = case combine (boundUKey min1) minV1 minV2 of Nothing -> IntMap (goLFused combine min1 root1 root2) Just minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep combine min1 root1 root2)) @@ -700,12 +700,12 @@ differenceWithUKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> r2lMap $ goRFused combine max1 (Bin min1 minV1 l1 r1) r2 Just maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep combine max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> binL (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) Just maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) @@ -719,7 +719,7 @@ differenceWithUKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goL2 combine minV2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of Empty -> goL2 combine minV2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' @@ -729,7 +729,7 @@ differenceWithUKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' @@ -742,7 +742,7 @@ differenceWithUKey = start LT -> goLFused combine min n1 l2 EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> binL (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 Just maxV1' -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goLFused combine min l1 n2) (NonEmpty max1 maxV1 r1) @@ -755,7 +755,7 @@ differenceWithUKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' @@ -769,12 +769,12 @@ differenceWithUKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> l2rMap $ goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 Just minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep combine min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) @@ -788,7 +788,7 @@ differenceWithUKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goR2 combine maxV2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> case goLFused combine min1 l1 l2 of Empty -> goR2 combine maxV2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) @@ -798,7 +798,7 @@ differenceWithUKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> case goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 @@ -811,7 +811,7 @@ differenceWithUKey = start LT -> goRFused combine max n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goRFused combine max r1 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 Just minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goRFused combine max r1 r2) GT -> binR (NonEmpty min1 minV1 l1) (goRFused combine max r1 n2) @@ -824,7 +824,7 @@ differenceWithUKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> case combine (boundUKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 Nothing -> case goLFused combine min1 l1 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) @@ -895,7 +895,7 @@ intersectionWithUKey = start start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (goL2 combine minV2 min1 root1 min2 root2) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) - | otherwise = IntMap (NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. @@ -906,12 +906,12 @@ intersectionWithUKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) + | otherwise -> r2lMap $ NonEmpty max1 (combine (boundUKey max1) maxV1 maxV2) (goRFused combine max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goL1 combine minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goRFused combine max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) + Empty -> r2lMap (NonEmpty max1 (combine (boundUKey max1) maxV1 maxV2) (goRFused combine max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundUKey max1) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) GT -> goL1 combine minV1 min1 l1 min2 n2 goL2 _ _ !_ Tip !_ !_ = Empty @@ -922,12 +922,12 @@ intersectionWithUKey = start EQ | max1 > max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goL2 combine minV2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goRFused combine max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) + Empty -> r2lMap (NonEmpty max1 (combine (boundUKey max1) maxV1 maxV2) (goRFused combine max1 r1 r2)) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 (combine (boundUKey max1) maxV1 maxV2) l' (goRFused combine max1 r1 r2)) GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 combine minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) + | otherwise -> r2lMap $ NonEmpty max1 (combine (boundUKey max1) maxV1 maxV2) (goRFused combine max1 r1 (Bin min2 minV2 l2 r2)) goLFused _ !_ Tip !_ = Tip goLFused _ !_ !_ Tip = Tip @@ -939,7 +939,7 @@ intersectionWithUKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFused combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' - | otherwise -> Bin max1 (combine (unbox (boundKey max1)) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 (combine (boundUKey max1) maxV1 maxV2) (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> goLFused combine min l1 n2 goR1 _ _ !_ !_ !_ Tip = Empty @@ -949,12 +949,12 @@ intersectionWithUKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) + | otherwise -> l2rMap $ NonEmpty min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goR1 combine maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) r') + Empty -> l2rMap (NonEmpty min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 l2) r') GT -> goR1 combine maxV1 max1 r1 max2 n2 goR2 _ _ !_ Tip !_ !_ = Empty @@ -965,12 +965,12 @@ intersectionWithUKey = start EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | otherwise -> case goR2 combine maxV2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) r') + Empty -> l2rMap (NonEmpty min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 l2)) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 l2) r') GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 combine maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) + | otherwise -> l2rMap $ NonEmpty min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 (Bin max2 maxV2 l2 r2)) goRFused _ !_ Tip !_ = Tip goRFused _ !_ !_ Tip = Tip @@ -982,7 +982,7 @@ intersectionWithUKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFused combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) - | otherwise -> Bin min1 (combine (unbox (boundKey min1)) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin min1 (combine (boundUKey min1) minV1 minV2) (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> goRFused combine max r1 n2 goLookupL1 _ !_ _ !_ Tip = Empty @@ -1312,26 +1312,26 @@ mapMaybeWithUKey :: (UKey -> a -> Maybe b) -> IntMap a -> IntMap b mapMaybeWithUKey = start where start _ (IntMap Empty) = IntMap Empty - start f (IntMap (NonEmpty min minV root)) = case f (unbox (boundKey min)) minV of + start f (IntMap (NonEmpty min minV root)) = case f (boundUKey min) minV of Just minV' -> IntMap (NonEmpty min minV' (goL f root)) Nothing -> IntMap (goDeleteL f root) goL _ Tip = Tip - goL f (Bin max maxV l r) = case f (unbox (boundKey max)) maxV of + goL f (Bin max maxV l r) = case f (boundUKey max) maxV of Just maxV' -> Bin max maxV' (goL f l) (goR f r) Nothing -> case goDeleteR f r of Empty -> goL f l NonEmpty max' maxV' r' -> Bin max' maxV' (goL f l) r' goR _ Tip = Tip - goR f (Bin min minV l r) = case f (unbox (boundKey min)) minV of + goR f (Bin min minV l r) = case f (boundUKey min) minV of Just minV' -> Bin min minV' (goL f l) (goR f r) Nothing -> case goDeleteL f l of Empty -> goR f r NonEmpty min' minV' l' -> Bin min' minV' l' (goR f r) goDeleteL _ Tip = Empty - goDeleteL f (Bin max maxV l r) = case f (unbox (boundKey max)) maxV of + goDeleteL f (Bin max maxV l r) = case f (boundUKey max) maxV of Just maxV' -> case goDeleteL f l of Empty -> case goR f r of Tip -> NonEmpty (maxToMin max) maxV' Tip @@ -1340,7 +1340,7 @@ mapMaybeWithUKey = start Nothing -> binL (goDeleteL f l) (goDeleteR f r) goDeleteR _ Tip = Empty - goDeleteR f (Bin min minV l r) = case f (unbox (boundKey min)) minV of + goDeleteR f (Bin min minV l r) = case f (boundUKey min) minV of Just minV' -> case goDeleteR f r of Empty -> case goL f l of Tip -> NonEmpty (minToMax min) minV' Tip @@ -1378,14 +1378,14 @@ mapEitherWithUKey :: (UKey -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap mapEitherWithUKey func = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) - start (IntMap (NonEmpty min minV root)) = case func (unbox (boundKey min)) minV of + start (IntMap (NonEmpty min minV root)) = case func (boundUKey min) minV of Left v -> let t :*: f = goTrueL root in (IntMap (NonEmpty min v t), IntMap f) Right v -> let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min v f)) goTrueL Tip = Tip :*: Empty - goTrueL (Bin max maxV l r) = case func (unbox (boundKey max)) maxV of + goTrueL (Bin max maxV l r) = case func (boundUKey max) maxV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin max v tl tr :*: binL fl fr @@ -1400,7 +1400,7 @@ mapEitherWithUKey func = start in t :*: f goTrueR Tip = Tip :*: Empty - goTrueR (Bin min minV l r) = case func (unbox (boundKey min)) minV of + goTrueR (Bin min minV l r) = case func (boundUKey min) minV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin min v tl tr :*: binR fl fr @@ -1415,7 +1415,7 @@ mapEitherWithUKey func = start in t :*: f goFalseL Tip = Empty :*: Tip - goFalseL (Bin max maxV l r) = case func (unbox (boundKey max)) maxV of + goFalseL (Bin max maxV l r) = case func (boundUKey max) maxV of Left v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -1430,7 +1430,7 @@ mapEitherWithUKey func = start in binL tl tr :*: Bin max v fl fr goFalseR Tip = Empty :*: Tip - goFalseR (Bin min minV l r) = case func (unbox (boundKey min)) minV of + goFalseR (Bin min minV l r) = case func (boundUKey min) minV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index e5751d894..19fc30a76 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -564,7 +564,7 @@ unionWithUKey = start start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 combine minV1 min1 root1 min2 root2)) - | otherwise = IntMap (NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 goL1 _ minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip goL1 _ minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 @@ -574,10 +574,10 @@ unionWithUKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 n1 min2 l2) r2 -- we choose min1 arbitrarily - we just need something from tree 1 | max1 > max2 -> Bin max1 maxV1 l2 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> Bin max2 maxV2 l2 (goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # l2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundUKey max1) maxV1 maxV2 # l2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goL1 combine minV1 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundUKey max1) maxV1 maxV2 # goL1 combine minV1 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 combine minV1 min1 l1 min2 n2) r1 goL2 _ minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip @@ -588,10 +588,10 @@ unionWithUKey = start GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 n2) r1 -- we choose min2 arbitrarily - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) | max1 < max2 -> Bin max2 maxV2 l1 (goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # l1 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundUKey max1) maxV1 maxV2 # l1 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) -- we choose max1 arbitrarily, as max1 == max2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goL2 combine minV2 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundUKey max1) maxV1 maxV2 # goL2 combine minV2 min1 l1 min2 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 LT -> Bin max2 maxV2 (goL2 combine minV2 min1 n1 min2 l2) r2 -- 'goLFused' is called instead of 'goL' if the minimums of the two trees are the same @@ -602,7 +602,7 @@ unionWithUKey = start LT -> Bin max2 maxV2 (goLFused combine min n1 l2) r2 EQ | max1 > max2 -> Bin max1 maxV1 (goLFused combine min l1 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> Bin max2 maxV2 (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundUKey max1) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused combine min l1 n2) r1 goR1 _ maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip @@ -613,10 +613,10 @@ unionWithUKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> Bin min2 minV2 l2 (goR1 combine maxV1 max1 n1 max2 r2) -- we choose max1 arbitrarily - we just need something from tree 1 | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r2 - | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 # r2 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # goR1 combine maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goR1 combine maxV1 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 combine maxV1 max1 r1 max2 n2) goR2 _ maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip @@ -627,10 +627,10 @@ unionWithUKey = start GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 combine maxV2 max1 r1 max2 n2) -- we choose max2 arbitrarily - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r1 - | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) # r1 -- we choose min1 arbitrarily, as min1 == min2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) - | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # goR2 combine maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goR2 combine maxV2 max1 r1 max2 r2 -- we choose min1 arbitrarily, as min1 == min2 LT -> Bin min2 minV2 l2 (goR2 combine maxV2 max1 n1 max2 r2) -- 'goRFused' is called instead of 'goR' if the minimums of the two trees are the same @@ -641,7 +641,7 @@ unionWithUKey = start LT -> Bin min2 minV2 l2 (goRFused combine max n1 r2) EQ | min1 < min2 -> Bin min1 minV1 (goL2 combine minV2 min1 l1 min2 l2) (goRFused combine max r1 r2) | min1 > min2 -> Bin min2 minV2 (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) - | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> Bin min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goRFused combine max r1 n2) goInsertL1 _ k v !_ _ Tip = Bin (Bound k) #! v # Tip # Tip @@ -717,7 +717,7 @@ differenceWithUKey = start start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (NonEmpty min1 minV1 (goL2 combine minV2 min1 root1 min2 root2)) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) - | otherwise = case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise = case combine (boundUKey min1) minV1 minV2 of Nothing -> IntMap (goLFused combine min1 root1 root2) Just !minV1' -> IntMap (NonEmpty min1 minV1' (goLFusedKeep combine min1 root1 root2)) @@ -728,12 +728,12 @@ differenceWithUKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ NonEmpty max1 maxV1 (goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> r2lMap $ goRFused combine max1 (Bin min1 minV1 l1 r1) r2 Just !maxV1' -> r2lMap $ NonEmpty max1 maxV1' (goRFusedKeep combine max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> binL (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max1 r1 r2) Just !maxV1' -> binL (goL1 combine minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goL1 combine minV1 min1 l1 min2 n2) (NonEmpty max1 maxV1 r1) @@ -747,7 +747,7 @@ differenceWithUKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goL2 combine minV2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of Empty -> goL2 combine minV2 min1 l1 min2 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 combine minV2 min1 l1 min2 l2) r' @@ -757,7 +757,7 @@ differenceWithUKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 (Bin min2 minV2 l2 r2) of Empty -> l1 NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' @@ -770,7 +770,7 @@ differenceWithUKey = start LT -> goLFused combine min n1 l2 EQ | max1 > max2 -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1 (goR2 combine maxV2 max1 r1 max2 r2)) | max1 < max2 -> binL (goLFused combine min l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> binL (goLFused combine min l1 l2) (goRFused combine max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 Just !maxV1' -> binL (goLFused combine min l1 l2) (NonEmpty max1 maxV1' (goRFusedKeep combine max1 r1 r2)) GT -> binL (goLFused combine min l1 n2) (NonEmpty max1 maxV1 r1) @@ -783,7 +783,7 @@ differenceWithUKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' - | otherwise -> case combine (unbox (boundKey max1)) maxV1 maxV2 of + | otherwise -> case combine (boundUKey max1) maxV1 maxV2 of Nothing -> case goRFused combine max1 r1 r2 of -- we choose max1 arbitrarily, as max1 == max2 Empty -> goLFusedKeep combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFusedKeep combine min l1 l2) r' @@ -797,12 +797,12 @@ differenceWithUKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ NonEmpty min1 minV1 (goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> l2rMap $ goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 Just !minV1' -> l2rMap $ NonEmpty min1 minV1' (goLFusedKeep combine min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goR1 combine maxV1 max1 r1 max2 r2) Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goR1 combine maxV1 max1 r1 max2 r2) GT -> binR (NonEmpty min1 minV1 l1) (goR1 combine maxV1 max1 r1 max2 n2) @@ -816,7 +816,7 @@ differenceWithUKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goR2 combine maxV2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> case goLFused combine min1 l1 l2 of Empty -> goR2 combine maxV2 max1 r1 max2 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 combine maxV2 max1 r1 max2 r2) @@ -826,7 +826,7 @@ differenceWithUKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> case goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) of Empty -> r1 NonEmpty min' minV' l' -> Bin min' minV' l' r1 @@ -839,7 +839,7 @@ differenceWithUKey = start LT -> goRFused combine max n1 r2 EQ | min1 < min2 -> binR (NonEmpty min1 minV1 (goL2 combine minV2 min1 l1 min2 l2)) (goRFused combine max r1 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goRFused combine max r1 r2) - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of + | otherwise -> case combine (boundUKey min1) minV1 minV2 of Nothing -> binR (goLFused combine min1 l1 l2) (goRFused combine max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 Just !minV1' -> binR (NonEmpty min1 minV1' (goLFusedKeep combine min1 l1 l2)) (goRFused combine max r1 r2) GT -> binR (NonEmpty min1 minV1 l1) (goRFused combine max r1 n2) @@ -852,7 +852,7 @@ differenceWithUKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) - | otherwise -> case combine (unbox (boundKey min1)) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 + | otherwise -> case combine (boundUKey min1) minV1 minV2 of -- we choose min1 arbitrarily, as min1 == min2 Nothing -> case goLFused combine min1 l1 l2 of Empty -> goRFusedKeep combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFusedKeep combine max r1 r2) @@ -923,7 +923,7 @@ intersectionWithUKey = start start combine (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) | min1 < min2 = IntMap (goL2 combine minV2 min1 root1 min2 root2) | min1 > min2 = IntMap (goL1 combine minV1 min1 root1 min2 root2) - | otherwise = IntMap (NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 + | otherwise = IntMap (NonEmpty min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 root1 root2) -- we choose min1 arbitrarily, as min1 == min2 -- TODO: This scheme might produce lots of unnecessary l2r and r2l calls. This should be rectified. @@ -934,12 +934,12 @@ intersectionWithUKey = start LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> goL1 combine minV1 min1 n1 min2 l2 -- min1 is arbitrary here - we just need something from tree 1 | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 - | otherwise -> r2lMap $ NonEmpty max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 + | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundUKey max1) maxV1 maxV2 # goRFused combine max1 (Bin min1 minV1 l1 r1) r2 EQ | max1 > max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goL1 combine minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goRFused combine max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) + Empty -> r2lMap (NonEmpty max1 #! combine (boundUKey max1) maxV1 maxV2 # goRFused combine max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundUKey max1) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) GT -> goL1 combine minV1 min1 l1 min2 n2 goL2 _ _ !_ Tip !_ !_ = Empty @@ -950,12 +950,12 @@ intersectionWithUKey = start EQ | max1 > max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | max1 < max2 -> binL (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goL2 combine minV2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goRFused combine max1 r1 r2) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) + Empty -> r2lMap (NonEmpty max1 #! combine (boundUKey max1) maxV1 maxV2 # goRFused combine max1 r1 r2) + NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 #! combine (boundUKey max1) maxV1 maxV2 # l' # goRFused combine max1 r1 r2) GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 combine minV2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> r2lMap $ goR2 combine maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) | max1 < max2 -> r2lMap $ goR1 combine maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) - | otherwise -> r2lMap $ NonEmpty max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) + | otherwise -> r2lMap $ NonEmpty max1 #! combine (boundUKey max1) maxV1 maxV2 # goRFused combine max1 r1 (Bin min2 minV2 l2 r2) goLFused _ !_ Tip !_ = Tip goLFused _ !_ !_ Tip = Tip @@ -967,7 +967,7 @@ intersectionWithUKey = start | max1 < max2 -> case goR1 combine maxV1 max1 r1 max2 r2 of Empty -> goLFused combine min l1 l2 NonEmpty max' maxV' r' -> Bin max' maxV' (goLFused combine min l1 l2) r' - | otherwise -> Bin max1 #! combine (unbox (boundKey max1)) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin max1 #! combine (boundUKey max1) maxV1 maxV2 # goLFused combine min l1 l2 # goRFused combine max1 r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> goLFused combine min l1 n2 goR1 _ _ !_ !_ !_ Tip = Empty @@ -977,12 +977,12 @@ intersectionWithUKey = start LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> goR1 combine maxV1 max1 n1 max2 r2 -- max1 is arbitrary here - we just need something from tree 1 | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 - | otherwise -> l2rMap $ NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 + | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 (Bin max1 maxV1 l1 r1) l2 EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR1 combine maxV1 max1 r1 max2 r2) | otherwise -> case goR1 combine maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # r') + Empty -> l2rMap (NonEmpty min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # r') GT -> goR1 combine maxV1 max1 r1 max2 n2 goR2 _ _ !_ Tip !_ !_ = Empty @@ -993,12 +993,12 @@ intersectionWithUKey = start EQ | min1 < min2 -> binR (goL2 combine minV2 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 combine minV1 min1 l1 min2 l2) (goR2 combine maxV2 max1 r1 max2 r2) | otherwise -> case goR2 combine maxV2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # r') + Empty -> l2rMap (NonEmpty min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 l2) + NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # r') GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 combine maxV2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> l2rMap $ goL2 combine minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) | min1 > min2 -> l2rMap $ goL1 combine minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) - | otherwise -> l2rMap $ NonEmpty min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) + | otherwise -> l2rMap $ NonEmpty min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 (Bin max2 maxV2 l2 r2) goRFused _ !_ Tip !_ = Tip goRFused _ !_ !_ Tip = Tip @@ -1010,7 +1010,7 @@ intersectionWithUKey = start | min1 > min2 -> case goL1 combine minV1 min1 l1 min2 l2 of Empty -> goRFused combine max r1 r2 NonEmpty min' minV' l' -> Bin min' minV' l' (goRFused combine max r1 r2) - | otherwise -> Bin min1 #! combine (unbox (boundKey min1)) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose max1 arbitrarily, as max1 == max2 + | otherwise -> Bin min1 #! combine (boundUKey min1) minV1 minV2 # goLFused combine min1 l1 l2 # goRFused combine max r1 r2 -- we choose max1 arbitrarily, as max1 == max2 GT -> goRFused combine max r1 n2 goLookupL1 _ !_ _ !_ Tip = Empty @@ -1369,26 +1369,26 @@ mapMaybeWithUKey :: (UKey -> a -> Maybe b) -> IntMap a -> IntMap b mapMaybeWithUKey f = start where start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = case f (unbox (boundKey min)) minV of + start (IntMap (NonEmpty min minV root)) = case f (boundUKey min) minV of Just !minV' -> IntMap (NonEmpty min minV' (goL root)) Nothing -> IntMap (goDeleteL root) goL Tip = Tip - goL (Bin max maxV l r) = case f (unbox (boundKey max)) maxV of + goL (Bin max maxV l r) = case f (boundUKey max) maxV of Just !maxV' -> Bin max maxV' (goL l) (goR r) Nothing -> case goDeleteR r of Empty -> goL l NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' goR Tip = Tip - goR (Bin min minV l r) = case f (unbox (boundKey min)) minV of + goR (Bin min minV l r) = case f (boundUKey min) minV of Just !minV' -> Bin min minV' (goL l) (goR r) Nothing -> case goDeleteL l of Empty -> goR r NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) goDeleteL Tip = Empty - goDeleteL (Bin max maxV l r) = case f (unbox (boundKey max)) maxV of + goDeleteL (Bin max maxV l r) = case f (boundUKey max) maxV of Just !maxV' -> case goDeleteL l of Empty -> case goR r of Tip -> NonEmpty (maxToMin max) maxV' Tip @@ -1397,7 +1397,7 @@ mapMaybeWithUKey f = start Nothing -> binL (goDeleteL l) (goDeleteR r) goDeleteR Tip = Empty - goDeleteR (Bin min minV l r) = case f (unbox (boundKey min)) minV of + goDeleteR (Bin min minV l r) = case f (boundUKey min) minV of Just !minV' -> case goDeleteR r of Empty -> case goL l of Tip -> NonEmpty (minToMax min) minV' Tip @@ -1435,14 +1435,14 @@ mapEitherWithUKey :: (UKey -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap mapEitherWithUKey func = start where start (IntMap Empty) = (IntMap Empty, IntMap Empty) - start (IntMap (NonEmpty min minV root)) = case func (unbox (boundKey min)) minV of + start (IntMap (NonEmpty min minV root)) = case func (boundUKey min) minV of Left !v -> let t :*: f = goTrueL root in (IntMap (NonEmpty min v t), IntMap f) Right !v -> let t :*: f = goFalseL root in (IntMap t, IntMap (NonEmpty min v f)) goTrueL Tip = Tip :*: Empty - goTrueL (Bin max maxV l r) = case func (unbox (boundKey max)) maxV of + goTrueL (Bin max maxV l r) = case func (boundUKey max) maxV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin max v tl tr :*: binL fl fr @@ -1457,7 +1457,7 @@ mapEitherWithUKey func = start in t :*: f goTrueR Tip = Tip :*: Empty - goTrueR (Bin min minV l r) = case func (unbox (boundKey min)) minV of + goTrueR (Bin min minV l r) = case func (boundUKey min) minV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goTrueR r in Bin min v tl tr :*: binR fl fr @@ -1472,7 +1472,7 @@ mapEitherWithUKey func = start in t :*: f goFalseL Tip = Empty :*: Tip - goFalseL (Bin max maxV l r) = case func (unbox (boundKey max)) maxV of + goFalseL (Bin max maxV l r) = case func (boundUKey max) maxV of Left !v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r t = case tl of @@ -1487,7 +1487,7 @@ mapEitherWithUKey func = start in binL tl tr :*: Bin max v fl fr goFalseR Tip = Empty :*: Tip - goFalseR (Bin min minV l r) = case func (unbox (boundKey min)) minV of + goFalseR (Bin min minV l r) = case func (boundUKey min) minV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r t = case tr of From a7ca8628a20aec14705e2e4e96e6b657497296d8 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 16 Jan 2020 13:58:31 -0600 Subject: [PATCH 118/147] Manually worker-wrapper transform IntMap merge tactics Performance of emulated set operations: ``` Benchmark Runtime change Original runtime union-block_nn -1.57% 1.01e-04 union-block_nn_swap -2.05% 1.02e-04 union-block_ns -4.93% 8.50e-06 union-block_sn_swap -4.68% 8.45e-06 union-common_nn -1.35% 6.12e-03 union-common_nn_swap -1.56% 6.22e-03 union-common_ns -4.69% 3.05e-03 union-common_nt -5.95% 8.86e-05 union-common_sn_swap -5.63% 3.11e-03 union-common_tn_swap -5.34% 8.90e-05 union-disj_nn -1.30% 3.09e-07 union-disj_nn_swap -1.86% 3.09e-07 union-disj_ns -0.87% 2.92e-07 union-disj_nt -0.22% 2.72e-07 union-disj_sn_swap -1.98% 2.93e-07 union-disj_tn_swap -1.45% 2.74e-07 union-mix_nn -1.08% 1.61e-02 union-mix_nn_swap -2.21% 1.61e-02 union-mix_ns -3.00% 3.79e-03 union-mix_nt -6.89% 9.31e-05 union-mix_sn_swap -2.98% 3.83e-03 union-mix_tn_swap -7.54% 9.50e-05 difference-block_nn -3.91% 4.66e-05 difference-block_nn_swap -4.43% 4.67e-05 difference-block_ns -8.56% 4.50e-06 difference-block_sn_swap -6.59% 6.00e-06 difference-common_nn -1.70% 4.64e-03 difference-common_nn_swap -11.72% 2.05e-03 difference-common_ns -2.44% 2.96e-03 difference-common_nt -4.50% 9.70e-05 difference-common_sn_swap -9.97% 7.04e-04 difference-common_tn_swap -2.82% 5.08e-05 difference-disj_nn -1.19% 1.93e-07 difference-disj_nn_swap -2.84% 2.14e-07 difference-disj_ns -1.70% 1.93e-07 difference-disj_nt -1.77% 1.93e-07 difference-disj_sn_swap -2.48% 2.04e-07 difference-disj_tn_swap -2.74% 2.04e-07 difference-mix_nn -2.87% 1.00e-02 difference-mix_nn_swap -2.33% 1.13e-02 difference-mix_ns -1.87% 2.85e-03 difference-mix_nt -5.50% 8.39e-05 difference-mix_sn_swap -8.03% 1.58e-03 difference-mix_tn_swap -2.18% 6.46e-05 intersection-block_nn -8.58% 2.27e-05 intersection-block_nn_swap -8.41% 2.27e-05 intersection-block_ns -11.85% 3.33e-06 intersection-block_sn_swap -8.55% 3.27e-06 intersection-common_nn -3.27% 5.40e-03 intersection-common_nn_swap -3.49% 5.42e-03 intersection-common_ns -10.83% 1.67e-03 intersection-common_nt -4.34% 6.61e-05 intersection-common_sn_swap -10.17% 1.64e-03 intersection-common_tn_swap -1.43% 6.68e-05 intersection-disj_nn -2.71% 1.83e-07 intersection-disj_nn_swap -4.62% 1.84e-07 intersection-disj_ns -2.91% 1.83e-07 intersection-disj_nt -2.71% 1.81e-07 intersection-disj_sn_swap -4.43% 1.82e-07 intersection-disj_tn_swap -3.33% 1.82e-07 intersection-mix_nn -7.75% 4.17e-03 intersection-mix_nn_swap -9.19% 4.20e-03 intersection-mix_ns -12.61% 6.17e-04 intersection-mix_nt -1.71% 4.82e-05 intersection-mix_sn_swap -10.81% 6.25e-04 intersection-mix_tn_swap -2.01% 4.84e-05 Minimum -12.61% Average -4.55% Maximum -0.22% ``` --- containers/src/Data/IntMap/Merge/Internal.hs | 143 ++++++++++--------- containers/src/Data/IntMap/Merge/Lazy.hs | 58 +++++--- containers/src/Data/IntMap/Merge/Strict.hs | 58 +++++--- 3 files changed, 154 insertions(+), 105 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 938ef2463..52c66efd3 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -110,7 +110,7 @@ data WhenMissing f a b = WhenMissing { -- optimized choice between 'Node' and 'IntMap_' intermediates. By changing -- its arguments into that form, 'merge' might even be implementable as -- efficiently as possible in terms of 'mergeA'. - missingSingle :: Key -> a -> f (Maybe b), + missingSingle :: UKey -> a -> f (Maybe b), missingLeft :: Node L a -> f (Node L b), missingRight :: Node R a -> f (Node R b), missingAllL :: IntMap_ L a -> f (IntMap_ L b) @@ -129,7 +129,7 @@ type SimpleWhenMissing = WhenMissing Identity -- @since 0.5.9 {-# INLINE runWhenMissing #-} runWhenMissing :: WhenMissing f a b -> Key -> a -> f (Maybe b) -runWhenMissing = missingSingle +runWhenMissing miss k = missingSingle miss (unbox k) -- | Apply a missing tactic to an entire map. -- @@ -150,7 +150,7 @@ runWhenMissingAll miss (IntMap m) = IntMap <$> missingAllL miss m -- but @dropMissing@ is much faster. {-# INLINE dropMissing #-} dropMissing :: Applicative f => WhenMissing f a b -dropMissing = WhenMissing (const (const (pure Nothing))) (const (pure Tip)) (const (pure Tip)) (const (pure Empty)) +dropMissing = WhenMissing (\_ _ -> pure Nothing) (const (pure Tip)) (const (pure Tip)) (const (pure Empty)) -- | Preserve, unchanged, the entries whose keys are missing from -- the other map. @@ -175,30 +175,37 @@ preserveMissing = WhenMissing (\_ v -> pure (Just v)) pure pure pure -- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x -- -- but this should be a little faster. +{-# INLINE filterMissing #-} filterMissing :: Applicative f => (Key -> a -> Bool) -> WhenMissing f a a -filterMissing p = WhenMissing (\k v -> pure (if p k v then Just v else Nothing)) (pure . goLKeep) (pure . goRKeep) (pure . start) where +filterMissing p = filterMissingUKey (\k a -> p (box k) a) + +-- | Filter the entries whose keys are missing from the other map with a +-- predicate taking unboxed keys. Identical in functionality to +-- 'filterMissing'. +filterMissingUKey :: Applicative f => (UKey -> a -> Bool) -> WhenMissing f a a +filterMissingUKey p = WhenMissing (\k v -> pure (if p k v then Just v else Nothing)) (pure . goLKeep) (pure . goRKeep) (pure . start) where start Empty = Empty start (NonEmpty min minV root) - | p (boundKey min) minV = NonEmpty min minV (goLKeep root) + | p (boundUKey min) minV = NonEmpty min minV (goLKeep root) | otherwise = goL root goLKeep Tip = Tip goLKeep (Bin max maxV l r) - | p (boundKey max) maxV = Bin max maxV (goLKeep l) (goRKeep r) + | p (boundUKey max) maxV = Bin max maxV (goLKeep l) (goRKeep r) | otherwise = case goR r of Empty -> goLKeep l NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' goRKeep Tip = Tip goRKeep (Bin min minV l r) - | p (boundKey min) minV = Bin min minV (goLKeep l) (goRKeep r) + | p (boundUKey min) minV = Bin min minV (goLKeep l) (goRKeep r) | otherwise = case goL l of Empty -> goRKeep r NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) goL Tip = Empty goL (Bin max maxV l r) - | p (boundKey max) maxV = case goL l of + | p (boundUKey max) maxV = case goL l of Empty -> case goRKeep r of Tip -> NonEmpty (maxToMin max) maxV Tip Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) @@ -207,7 +214,7 @@ filterMissing p = WhenMissing (\k v -> pure (if p k v then Just v else Nothing)) goR Tip = Empty goR (Bin min minV l r) - | p (boundKey min) minV = case goR r of + | p (boundUKey min) minV = case goR r of Empty -> case goLKeep l of Tip -> NonEmpty (minToMax min) minV Tip Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) @@ -225,21 +232,27 @@ filterMissing p = WhenMissing (\k v -> pure (if p k v then Just v else Nothing)) -- @since 0.5.9 {-# INLINE filterAMissing #-} -- TODO: Use pointer equality to speed this up? -filterAMissing :: Applicative f => (Key -> a -> f Bool) -> WhenMissing f a a -filterAMissing f = WhenMissing +filterAMissing :: Applicative f => (Key -> a -> f Bool) -> WhenMissing f a a +filterAMissing p = filterAMissingUKey (\k a -> p (box k) a) + +-- | Filter the entries whose keys are missing from the other map using some +-- 'Applicative' action that takes an unboxed key. Identical in functionality +-- to 'filterAMissing'. +filterAMissingUKey :: Applicative f => (UKey -> a -> f Bool) -> WhenMissing f a a +filterAMissingUKey f = WhenMissing { missingAllL = start , missingLeft = goL , missingRight = goR , missingSingle = \k v -> fmap (\keep -> if keep then Just v else Nothing) (f k v) } where start Empty = pure Empty - start (NonEmpty min minV root) = liftA2 (\keepV root' -> if keepV then NonEmpty min minV root' else nodeToMapL root') (f (boundKey min) minV) (goL root) + start (NonEmpty min minV root) = liftA2 (\keepV root' -> if keepV then NonEmpty min minV root' else nodeToMapL root') (f (boundUKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = liftA3 (\l' r' keepMax -> if keepMax then Bin max maxV l' r' else extractBinL l' r') (goL l) (goR r) (f (boundKey max) maxV) + goL (Bin max maxV l r) = liftA3 (\l' r' keepMax -> if keepMax then Bin max maxV l' r' else extractBinL l' r') (goL l) (goR r) (f (boundUKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = liftA3 (\keepMin l' r' -> if keepMin then Bin min minV l' r' else extractBinR l' r') (f (boundKey min) minV) (goL l) (goR r) + goR (Bin min minV l r) = liftA3 (\keepMin l' r' -> if keepMin then Bin min minV l' r' else extractBinR l' r') (f (boundUKey min) minV) (goL l) (goR r) -- | A tactic for dealing with keys present in both -- maps in 'merge' or 'mergeA'. @@ -247,7 +260,7 @@ filterAMissing f = WhenMissing -- A tactic of type @ WhenMatched f a b c @ is an abstract representation -- of a function of type @ Key -> a -> b -> f (Maybe c) @. newtype WhenMatched f a b c = WhenMatched { - matchedSingle :: Key -> a -> b -> f (Maybe c) + matchedSingle :: UKey -> a -> b -> f (Maybe c) } -- | A tactic for dealing with keys present in both maps in 'merge'. @@ -262,7 +275,7 @@ type SimpleWhenMatched = WhenMatched Identity -- @since 0.5.9 {-# INLINE runWhenMatched #-} runWhenMatched :: WhenMatched f a b c -> Key -> a -> b -> f (Maybe c) -runWhenMatched = matchedSingle +runWhenMatched match k = matchedSingle match (unbox k) -- | Merge two maps. -- @@ -415,21 +428,21 @@ mergeA miss1 miss2 match = start where start (IntMap Empty) (IntMap !m2) = IntMap <$> missingAllL miss2 m2 start (IntMap !m1) (IntMap Empty) = IntMap <$> missingAllL miss1 m1 start (IntMap (NonEmpty min1 minV1 root1)) (IntMap (NonEmpty min2 minV2 root2)) - | min1 < min2 = makeIntMapNE min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 root1 min2 root2) - | min2 < min1 = makeIntMapNE min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 root1 min2 root2) - | otherwise = makeIntMapNE min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 root1 root2) + | min1 < min2 = makeIntMapNE min1 (missingSingle miss1 (boundUKey min1) minV1) (goL2 minV2 min1 root1 min2 root2) + | min2 < min1 = makeIntMapNE min2 (missingSingle miss2 (boundUKey min2) minV2) (goL1 minV1 min1 root1 min2 root2) + | otherwise = makeIntMapNE min1 (matchedSingle match (boundUKey min1) minV1 minV2) (goLFused min1 root1 root2) goL1 minV1 !min1 !n1 !min2 Tip = mapToNodeL min2 <$> missingAllL miss1 (NonEmpty min1 minV1 n1) goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = liftA2 (maybeUnionDisjointL min2) (missingLeft miss2 n2) (missingAllL miss1 (NonEmpty min1 minV1 n1)) goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 goL1 minV1 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey min1) min2 < xor (boundKey min1) max2 -> liftA2 binNodeMapL (goL1 minV1 min1 n1 min2 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) - | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (missingLeft miss2 l2) (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (missingLeft miss2 l2) (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (missingLeft miss2 l2) (goRFused max1 (Bin min1 minV1 l1 r1) r2) - EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) + | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundUKey max1) maxV1) (missingLeft miss2 l2) (goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundUKey max2) maxV2) (missingLeft miss2 l2) (goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundUKey max1) maxV1 maxV2) (missingLeft miss2 l2) (goRFused max1 (Bin min1 minV1 l1 r1) r2) + EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundUKey max1) maxV1) (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundUKey max2) maxV2) (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundUKey max1) maxV1 maxV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) GT -> liftA2 binNodeMapL (goL1 minV1 min1 l1 min2 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) goL2 minV2 !min1 Tip !min2 !n2 = mapToNodeL min1 <$> missingAllL miss2 (NonEmpty min2 minV2 n2) @@ -437,21 +450,21 @@ mergeA miss1 miss2 match = start where goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 goL2 minV2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> liftA2 binNodeMapL (goL2 minV2 min1 l1 min2 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) - | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (missingLeft miss1 l1) (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (missingLeft miss1 l1) (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (missingLeft miss1 l1) (goRFused max1 r1 (Bin min2 minV2 l2 r2)) - EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) + | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundUKey max1) maxV1) (missingLeft miss1 l1) (goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundUKey max2) maxV2) (missingLeft miss1 l1) (goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) + | otherwise -> makeBinL max1 (matchedSingle match (boundUKey max1) maxV1 maxV2) (missingLeft miss1 l1) (goRFused max1 r1 (Bin min2 minV2 l2 r2)) + EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundUKey max1) maxV1) (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundUKey max2) maxV2) (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundUKey max1) maxV1 maxV2) (goL2 minV2 min1 l1 min2 l2) (goRFused max1 r1 r2) LT -> liftA2 binNodeMapL (goL2 minV2 min1 n1 min2 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) goLFused !_ Tip !n2 = missingLeft miss2 n2 goLFused !_ !n1 Tip = missingLeft miss1 n1 goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> liftA2 binNodeMapL (goLFused min n1 l2) (missingAllR miss2 (NonEmpty max2 maxV2 r2)) - EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundKey max1) maxV1) (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) - | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundKey max2) maxV2) (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> makeBinL max1 (matchedSingle match (boundKey max1) maxV1 maxV2) (goLFused min l1 l2) (goRFused max1 r1 r2) + EQ | max1 > max2 -> makeBinL max1 (missingSingle miss1 (boundUKey max1) maxV1) (goLFused min l1 l2) (goR2 maxV2 max1 r1 max2 r2) + | max1 < max2 -> makeBinL max2 (missingSingle miss2 (boundUKey max2) maxV2) (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinL max1 (matchedSingle match (boundUKey max1) maxV1 maxV2) (goLFused min l1 l2) (goRFused max1 r1 r2) GT -> liftA2 binNodeMapL (goLFused min l1 n2) (missingAllR miss1 (NonEmpty max1 maxV1 r1)) goR1 maxV1 !max1 !n1 !max2 Tip = mapToNodeR max2 <$> missingAllR miss1 (NonEmpty max1 maxV1 n1) @@ -459,12 +472,12 @@ mergeA miss1 miss2 match = start where goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 goR1 maxV1 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT | xor (boundKey max1) min2 > xor (boundKey max1) max2 -> liftA2 binMapNodeR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goR1 maxV1 max1 n1 max2 r2) - | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) (missingRight miss2 r2) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) (missingRight miss2 r2) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) (missingRight miss2 r2) - EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundUKey min1) minV1) (goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) (missingRight miss2 r2) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundUKey min2) minV2) (goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) (missingRight miss2 r2) + | otherwise -> makeBinR min1 (matchedSingle match (boundUKey min1) minV1 minV2) (goLFused min1 (Bin max1 maxV1 l1 r1) l2) (missingRight miss2 r2) + EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundUKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundUKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> makeBinR min1 (matchedSingle match (boundUKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) GT -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goR1 maxV1 max1 r1 max2 n2) goR2 maxV2 !max1 Tip !max2 !n2 = mapToNodeR max1 <$> missingAllR miss2 (NonEmpty max2 maxV2 n2) @@ -472,53 +485,53 @@ mergeA miss1 miss2 match = start where goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max1) max2) max1 n1 goR2 maxV2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goR2 maxV2 max1 r1 max2 n2) - | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (missingRight miss1 r1) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (missingRight miss1 r1) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) (missingRight miss1 r1) - EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundUKey min1) minV1) (goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (missingRight miss1 r1) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundUKey min2) minV2) (goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) (missingRight miss1 r1) + | otherwise -> makeBinR min1 (matchedSingle match (boundUKey min1) minV1 minV2) (goLFused min1 l1 (Bin max2 maxV2 l2 r2)) (missingRight miss1 r1) + EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundUKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundUKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (goR2 maxV2 max1 r1 max2 r2) + | otherwise -> makeBinR min1 (matchedSingle match (boundUKey min1) minV1 minV2) (goLFused min1 l1 l2) (goR2 maxV2 max1 r1 max2 r2) LT -> liftA2 binMapNodeR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goR2 maxV2 max1 n1 max2 r2) goRFused !_ Tip !n2 = missingRight miss2 n2 goRFused !_ !n1 Tip = missingRight miss1 n1 goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> liftA2 binMapNodeR (missingAllL miss2 (NonEmpty min2 minV2 l2)) (goRFused max n1 r2) - EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) - | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) - | otherwise -> makeBinR min1 (matchedSingle match (boundKey min1) minV1 minV2) (goLFused min1 l1 l2) (goRFused max r1 r2) + EQ | min1 < min2 -> makeBinR min1 (missingSingle miss1 (boundUKey min1) minV1) (goL2 minV2 min1 l1 min2 l2) (goRFused max r1 r2) + | min1 > min2 -> makeBinR min2 (missingSingle miss2 (boundUKey min2) minV2) (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) + | otherwise -> makeBinR min1 (matchedSingle match (boundUKey min1) minV1 minV2) (goLFused min1 l1 l2) (goRFused max r1 r2) GT -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goRFused max r1 n2) - goInsertL1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 k v) + goInsertL1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 (unbox k) v) goInsertL1 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of InBound | xorCache < xorCacheMax -> liftA2 binNodeMapL (goInsertL1 k v xorCache min l) (missingAllR miss2 (NonEmpty max maxV r)) - | otherwise -> makeBinL max (missingSingle miss2 (boundKey max) maxV) (missingLeft miss2 l) (goInsertR1 k v xorCacheMax max r) - OutOfBound -> addMaxL min (Bound k) (missingSingle miss1 k v) (missingLeft miss2 n) - Matched -> makeBinL max (matchedSingle match k v maxV) (missingLeft miss2 l) (missingRight miss2 r) + | otherwise -> makeBinL max (missingSingle miss2 (boundUKey max) maxV) (missingLeft miss2 l) (goInsertR1 k v xorCacheMax max r) + OutOfBound -> addMaxL min (Bound k) (missingSingle miss1 (unbox k) v) (missingLeft miss2 n) + Matched -> makeBinL max (matchedSingle match (unbox k) v maxV) (missingLeft miss2 l) (missingRight miss2 r) where xorCacheMax = xor k max - goInsertL2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 k v) + goInsertL2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 (unbox k) v) goInsertL2 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of InBound | xorCache < xorCacheMax -> liftA2 binNodeMapL (goInsertL2 k v xorCache min l) (missingAllR miss1 (NonEmpty max maxV r)) - | otherwise -> makeBinL max (missingSingle miss1 (boundKey max) maxV) (missingLeft miss1 l) (goInsertR2 k v xorCacheMax max r) - OutOfBound -> addMaxL min (Bound k) (missingSingle miss2 k v) (missingLeft miss1 n) - Matched -> makeBinL max (matchedSingle match k maxV v) (missingLeft miss1 l) (missingRight miss1 r) + | otherwise -> makeBinL max (missingSingle miss1 (boundUKey max) maxV) (missingLeft miss1 l) (goInsertR2 k v xorCacheMax max r) + OutOfBound -> addMaxL min (Bound k) (missingSingle miss2 (unbox k) v) (missingLeft miss1 n) + Matched -> makeBinL max (matchedSingle match (unbox k) maxV v) (missingLeft miss1 l) (missingRight miss1 r) where xorCacheMax = xor k max - goInsertR1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 k v) + goInsertR1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 (unbox k) v) goInsertR1 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of InBound | xorCache < xorCacheMin -> liftA2 binMapNodeR (missingAllL miss2 (NonEmpty min minV l)) (goInsertR1 k v xorCache max r) - | otherwise -> makeBinR min (missingSingle miss2 (boundKey min) minV) (goInsertL1 k v xorCacheMin min l) (missingRight miss2 r) - OutOfBound -> addMinR max (Bound k) (missingSingle miss1 k v) (missingRight miss2 n) - Matched -> makeBinR min (matchedSingle match k v minV) (missingLeft miss2 l) (missingRight miss2 r) + | otherwise -> makeBinR min (missingSingle miss2 (boundUKey min) minV) (goInsertL1 k v xorCacheMin min l) (missingRight miss2 r) + OutOfBound -> addMinR max (Bound k) (missingSingle miss1 (unbox k) v) (missingRight miss2 n) + Matched -> makeBinR min (matchedSingle match (unbox k) v minV) (missingLeft miss2 l) (missingRight miss2 r) where xorCacheMin = xor k min - goInsertR2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 k v) + goInsertR2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 (unbox k) v) goInsertR2 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of InBound | xorCache < xorCacheMin -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min minV l)) (goInsertR2 k v xorCache max r) - | otherwise -> makeBinR min (missingSingle miss1 (boundKey min) minV) (goInsertL2 k v xorCacheMin min l) (missingRight miss1 r) - OutOfBound -> addMinR max (Bound k) (missingSingle miss2 k v) (missingRight miss1 n) - Matched -> makeBinR min (matchedSingle match k minV v) (missingLeft miss1 l) (missingRight miss1 r) + | otherwise -> makeBinR min (missingSingle miss1 (boundUKey min) minV) (goInsertL2 k v xorCacheMin min l) (missingRight miss1 r) + OutOfBound -> addMinR max (Bound k) (missingSingle miss2 (unbox k) v) (missingRight miss1 n) + Matched -> makeBinR min (matchedSingle match (unbox k) minV v) (missingLeft miss1 l) (missingRight miss1 r) where xorCacheMin = xor k min missingAllR whenMiss = fmap l2rMap . missingAllL whenMiss . r2lMap diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index a68325e2e..32fda6925 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -96,16 +96,23 @@ import Data.IntMap.Merge.Internal -- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) -- -- but @mapMissing@ is somewhat faster. +{-# INLINE mapMissing #-} mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b -mapMissing f = WhenMissing (\k v -> pure (Just (f k v))) (pure . goL) (pure . goR) (pure . start) where +mapMissing f = mapMissingUKey (\k v -> f (box k) v) + +-- | Map over the entries whose keys are missing from the other map with a +-- function that takes an unboxed key. Identical in functionality to +-- 'mapMissing'. +mapMissingUKey :: Applicative f => (UKey -> a -> b) -> WhenMissing f a b +mapMissingUKey f = WhenMissing (\k v -> pure (Just (f k v))) (pure . goL) (pure . goR) (pure . start) where start Empty = Empty - start (NonEmpty min minV root) = NonEmpty min (f (boundKey min) minV) (goL root) + start (NonEmpty min minV root) = NonEmpty min (f (boundUKey min) minV) (goL root) goL Tip = Tip - goL (Bin k v l r) = Bin k (f (boundKey k) v) (goL l) (goR r) + goL (Bin k v l r) = Bin k (f (boundUKey k) v) (goL l) (goR r) goR Tip = Tip - goR (Bin k v l r) = Bin k (f (boundKey k) v) (goL l) (goR r) + goR (Bin k v l r) = Bin k (f (boundUKey k) v) (goL l) (goR r) -- | Map over the entries whose keys are missing from the other map, -- optionally removing some. This is the most powerful 'SimpleWhenMissing' @@ -118,29 +125,36 @@ mapMissing f = WhenMissing (\k v -> pure (Just (f k v))) (pure . goL) (pure . go -- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x)) -- -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. +{-# INLINE mapMaybeMissing #-} mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b -mapMaybeMissing f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pure . goRKeep) (pure . start) where +mapMaybeMissing f = mapMaybeMissingUKey (\k a -> f (box k) a) + +-- | Map over the entries whose keys are missing from the other map using a +-- function taking an unboxed key, optionally removing some. Identical in +-- functionality to 'mapMaybeMissing'. +mapMaybeMissingUKey :: Applicative f => (UKey -> a -> Maybe b) -> WhenMissing f a b +mapMaybeMissingUKey f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pure . goRKeep) (pure . start) where start Empty = Empty - start (NonEmpty min minV root) = case f (boundKey min) minV of + start (NonEmpty min minV root) = case f (boundUKey min) minV of Just minV' -> NonEmpty min minV' (goLKeep root) Nothing -> goL root goLKeep Tip = Tip - goLKeep (Bin max maxV l r) = case f (boundKey max) maxV of + goLKeep (Bin max maxV l r) = case f (boundUKey max) maxV of Just maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) Nothing -> case goR r of Empty -> goLKeep l NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' goRKeep Tip = Tip - goRKeep (Bin min minV l r) = case f (boundKey min) minV of + goRKeep (Bin min minV l r) = case f (boundUKey min) minV of Just minV' -> Bin min minV' (goLKeep l) (goRKeep r) Nothing -> case goL l of Empty -> goRKeep r NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) goL Tip = Empty - goL (Bin max maxV l r) = case f (boundKey max) maxV of + goL (Bin max maxV l r) = case f (boundUKey max) maxV of Just maxV' -> case goL l of Empty -> case goRKeep r of Tip -> NonEmpty (maxToMin max) maxV' Tip @@ -149,7 +163,7 @@ mapMaybeMissing f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pure . Nothing -> binL (goL l) (goR r) goR Tip = Empty - goR (Bin min minV l r) = case f (boundKey min) minV of + goR (Bin min minV l r) = case f (boundUKey min) minV of Just minV' -> case goR r of Empty -> case goLKeep l of Tip -> NonEmpty (minToMax min) minV' Tip @@ -166,7 +180,7 @@ mapMaybeMissing f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pure . -- @ {-# INLINE zipWithMaybeMatched #-} zipWithMaybeMatched :: Applicative f => (Key -> a -> b -> Maybe c) -> WhenMatched f a b c -zipWithMaybeMatched f = WhenMatched (\k a b -> pure (f k a b)) +zipWithMaybeMatched f = WhenMatched (\k a b -> pure (f (box k) a b)) -- | When a key is found in both maps, apply a function to the -- key and values and use the result in the merged map. @@ -190,7 +204,7 @@ zipWithMatched f = zipWithMaybeMatched (\k a b -> Just (f k a b)) zipWithMaybeAMatched :: (Key -> a -> b -> f (Maybe c)) -> WhenMatched f a b c -zipWithMaybeAMatched f = WhenMatched (\k a b -> f k a b) +zipWithMaybeAMatched f = WhenMatched (\k a b -> f (box k) a b) -- | When a key is found in both maps, apply a function to the key -- and values to produce an action and use its result in the merged @@ -217,16 +231,18 @@ traverseMaybeMissing f = WhenMissing { missingAllL = start , missingLeft = goL , missingRight = goR - , missingSingle = f } + , missingSingle = f' } where + f' k a = f (box k) a + start Empty = pure Empty - start (NonEmpty min minV root) = liftA2 (maybe nodeToMapL (NonEmpty min)) (f (boundKey min) minV) (goL root) + start (NonEmpty min minV root) = liftA2 (maybe nodeToMapL (NonEmpty min)) (f' (boundUKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> maybe extractBinL (Bin max) maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) + goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> maybe extractBinL (Bin max) maxV' l' r') (goL l) (goR r) (f' (boundUKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = liftA3 (\minV' l' r' -> maybe extractBinR (Bin min) minV' l' r') (f (boundKey min) minV) (goL l) (goR r) + goR (Bin min minV l r) = liftA3 (\minV' l' r' -> maybe extractBinR (Bin min) minV' l' r') (f' (boundUKey min) minV) (goL l) (goR r) -- | Traverse over the entries whose keys are missing from the other -- map. @@ -239,13 +255,15 @@ traverseMissing f = WhenMissing { missingAllL = start , missingLeft = goL , missingRight = goR - , missingSingle = \k v -> Just <$> f k v } + , missingSingle = \k v -> Just <$> f' k v } where + f' k a = f (box k) a + start Empty = pure Empty - start (NonEmpty min minV root) = liftA2 (NonEmpty min) (f (boundKey min) minV) (goL root) + start (NonEmpty min minV root) = liftA2 (NonEmpty min) (f' (boundUKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> Bin max maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) + goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> Bin max maxV' l' r') (goL l) (goR r) (f' (boundUKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = liftA3 (\minV' l' r' -> Bin min minV' l' r') (f (boundKey min) minV) (goL l) (goR r) + goR (Bin min minV l r) = liftA3 (\minV' l' r' -> Bin min minV' l' r') (f' (boundUKey min) minV) (goL l) (goR r) diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index b7c0cb5d9..be7aeee99 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -100,16 +100,23 @@ import Data.IntMap.Merge.Internal -- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) -- -- but @mapMissing@ is somewhat faster. +{-# INLINE mapMissing #-} mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b -mapMissing f = WhenMissing (\k v -> pure (Just $! f k v)) (pure . goL) (pure . goR) (pure . start) where +mapMissing f = mapMissingUKey (\k v -> f (box k) v) + +-- | Map over the entries whose keys are missing from the other map with a +-- function that takes an unboxed key. Identical in functionality to +-- 'mapMissing'. +mapMissingUKey :: Applicative f => (UKey -> a -> b) -> WhenMissing f a b +mapMissingUKey f = WhenMissing (\k v -> pure (Just $! f k v)) (pure . goL) (pure . goR) (pure . start) where start Empty = Empty - start (NonEmpty min minV root) = NonEmpty min #! f (boundKey min) minV # goL root + start (NonEmpty min minV root) = NonEmpty min #! f (boundUKey min) minV # goL root goL Tip = Tip - goL (Bin k v l r) = Bin k #! f (boundKey k) v # goL l # goR r + goL (Bin k v l r) = Bin k #! f (boundUKey k) v # goL l # goR r goR Tip = Tip - goR (Bin k v l r) = Bin k #! f (boundKey k) v # goL l # goR r + goR (Bin k v l r) = Bin k #! f (boundUKey k) v # goL l # goR r -- | Map over the entries whose keys are missing from the other map, -- optionally removing some. This is the most powerful 'SimpleWhenMissing' @@ -122,32 +129,39 @@ mapMissing f = WhenMissing (\k v -> pure (Just $! f k v)) (pure . goL) (pure . g -- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x)) -- -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. +{-# INLINE mapMaybeMissing #-} mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b -mapMaybeMissing f = WhenMissing (\k v -> case f k v of +mapMaybeMissing f = mapMaybeMissingUKey (\k a -> f (box k) a) + +-- | Map over the entries whose keys are missing from the other map using a +-- function taking an unboxed key, optionally removing some. Identical in +-- functionality to 'mapMaybeMissing'. +mapMaybeMissingUKey :: Applicative f => (UKey -> a -> Maybe b) -> WhenMissing f a b +mapMaybeMissingUKey f = WhenMissing (\k v -> case f k v of Nothing -> pure Nothing Just !b -> pure (Just b)) (pure . goLKeep) (pure . goRKeep) (pure . start) where start Empty = Empty - start (NonEmpty min minV root) = case f (boundKey min) minV of + start (NonEmpty min minV root) = case f (boundUKey min) minV of Just !minV' -> NonEmpty min minV' (goLKeep root) Nothing -> goL root goLKeep Tip = Tip - goLKeep (Bin max maxV l r) = case f (boundKey max) maxV of + goLKeep (Bin max maxV l r) = case f (boundUKey max) maxV of Just !maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) Nothing -> case goR r of Empty -> goLKeep l NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' goRKeep Tip = Tip - goRKeep (Bin min minV l r) = case f (boundKey min) minV of + goRKeep (Bin min minV l r) = case f (boundUKey min) minV of Just !minV' -> Bin min minV' (goLKeep l) (goRKeep r) Nothing -> case goL l of Empty -> goRKeep r NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) goL Tip = Empty - goL (Bin max maxV l r) = case f (boundKey max) maxV of + goL (Bin max maxV l r) = case f (boundUKey max) maxV of Just !maxV' -> case goL l of Empty -> case goRKeep r of Tip -> NonEmpty (maxToMin max) maxV' Tip @@ -156,7 +170,7 @@ mapMaybeMissing f = WhenMissing (\k v -> case f k v of Nothing -> binL (goL l) (goR r) goR Tip = Empty - goR (Bin min minV l r) = case f (boundKey min) minV of + goR (Bin min minV l r) = case f (boundUKey min) minV of Just !minV' -> case goR r of Empty -> case goLKeep l of Tip -> NonEmpty (minToMax min) minV' Tip @@ -174,7 +188,7 @@ mapMaybeMissing f = WhenMissing (\k v -> case f k v of -- @ {-# INLINE zipWithMaybeMatched #-} zipWithMaybeMatched :: Applicative f => (Key -> a -> b -> Maybe c) -> WhenMatched f a b c -zipWithMaybeMatched f = WhenMatched (\k a b -> case f k a b of +zipWithMaybeMatched f = WhenMatched (\k a b -> case f (box k) a b of Nothing -> pure Nothing Just !c -> pure (Just c)) @@ -200,7 +214,7 @@ zipWithMatched f = zipWithMaybeMatched (\k a b -> Just $! f k a b) zipWithMaybeAMatched :: (Key -> a -> b -> f (Maybe c)) -> WhenMatched f a b c -zipWithMaybeAMatched f = WhenMatched (\k a b -> f k a b) +zipWithMaybeAMatched f = WhenMatched (\k a b -> f (box k) a b) -- | When a key is found in both maps, apply a function to the key -- and values to produce an action and use its result in the merged @@ -227,16 +241,18 @@ traverseMaybeMissing f = WhenMissing { missingAllL = start , missingLeft = goL , missingRight = goR - , missingSingle = f } + , missingSingle = f' } where + f' k a = f (box k) a + start Empty = pure Empty - start (NonEmpty min minV root) = liftA2 (maybe nodeToMapL (NonEmpty min $!)) (f (boundKey min) minV) (goL root) + start (NonEmpty min minV root) = liftA2 (maybe nodeToMapL (NonEmpty min $!)) (f' (boundUKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> maybe extractBinL (Bin max $!) maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) + goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> maybe extractBinL (Bin max $!) maxV' l' r') (goL l) (goR r) (f' (boundUKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = liftA3 (\minV' l' r' -> maybe extractBinR (Bin min $!) minV' l' r') (f (boundKey min) minV) (goL l) (goR r) + goR (Bin min minV l r) = liftA3 (\minV' l' r' -> maybe extractBinR (Bin min $!) minV' l' r') (f' (boundUKey min) minV) (goL l) (goR r) -- | Traverse over the entries whose keys are missing from the other -- map. @@ -249,13 +265,15 @@ traverseMissing f = WhenMissing { missingAllL = start , missingLeft = goL , missingRight = goR - , missingSingle = \k v -> Just <$> f k v } + , missingSingle = \k v -> Just <$> f' k v } where + f' k a = f (box k) a + start Empty = pure Empty - start (NonEmpty min minV root) = liftA2 (NonEmpty min $!) (f (boundKey min) minV) (goL root) + start (NonEmpty min minV root) = liftA2 (NonEmpty min $!) (f' (boundUKey min) minV) (goL root) goL Tip = pure Tip - goL (Bin max maxV l r) = liftA3 (\l' r' !maxV' -> Bin max maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) + goL (Bin max maxV l r) = liftA3 (\l' r' !maxV' -> Bin max maxV' l' r') (goL l) (goR r) (f' (boundUKey max) maxV) goR Tip = pure Tip - goR (Bin min minV l r) = liftA3 (\ !minV' l' r' -> Bin min minV' l' r') (f (boundKey min) minV) (goL l) (goR r) + goR (Bin min minV l r) = liftA3 (\ !minV' l' r' -> Bin min minV' l' r') (f' (boundUKey min) minV) (goL l) (goR r) From 7d0f635b9143d825540e978c951992ee346a747e Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 16 Jan 2020 14:05:56 -0600 Subject: [PATCH 119/147] Force a good match order in IntMap.delete{MinL,MaxR} --- containers/src/Data/IntMap/Internal.hs | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 649e94679..2098dbd81 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -2703,21 +2703,25 @@ insertMaxR !xorCache !max maxV (Bin min minV l r) -- when the minimum bound of the node has been deleted. See 'NonEmptyIntMap_' -- for the reasoning behind this. deleteMinL :: Bound R -> a -> Node L a -> Node R a -> NonEmptyIntMap_ L a -deleteMinL !max maxV Tip Tip = NE (maxToMin max) maxV Tip -deleteMinL !max maxV Tip (Bin min minV l r) = NE min minV (Bin max maxV l r) -deleteMinL !max maxV (Bin innerMax innerMaxV innerL innerR) r = - let NE min minV inner = deleteMinL innerMax innerMaxV innerL innerR - in NE min minV (Bin max maxV inner r) +deleteMinL !max maxV l r = case l of -- force l-then-r match order + Tip -> case r of + Tip -> NE (maxToMin max) maxV Tip + Bin min minV innerL innerR -> NE min minV (Bin max maxV innerL innerR) + Bin innerMax innerMaxV innerL innerR -> + let NE min minV inner = deleteMinL innerMax innerMaxV innerL innerR + in NE min minV (Bin max maxV inner r) -- | Rearrange an unpacked (non-empty) right node into a non-empty map, for use -- when the maximum bound of the node has been deleted. See 'NonEmptyIntMap_' -- for the reasoning behind this. deleteMaxR :: Bound L -> a -> Node L a -> Node R a -> NonEmptyIntMap_ R a -deleteMaxR !min minV Tip Tip = NE (minToMax min) minV Tip -deleteMaxR !min minV (Bin max maxV l r) Tip = NE max maxV (Bin min minV l r) -deleteMaxR !min minV l (Bin innerMin innerMinV innerL innerR) = - let NE max maxV inner = deleteMaxR innerMin innerMinV innerL innerR - in NE max maxV (Bin min minV l inner) +deleteMaxR !min minV l r = case r of -- force r-then-l match order + Tip -> case l of + Tip -> NE (minToMax min) minV Tip + Bin max maxV innerL innerR -> NE max maxV (Bin min minV innerL innerR) + Bin innerMin innerMinV innerL innerR -> + let NE max maxV inner = deleteMaxR innerMin innerMinV innerL innerR + in NE max maxV (Bin min minV l inner) -- | Combine two nodes that would be on different branches into into a new left -- node. This is not cheap: since the 'Bin' constructor needs an new bound in From 2a62f6f87e702d6c6d1134435be3f1ef05756091 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 18 Jan 2020 12:37:14 -0600 Subject: [PATCH 120/147] INLINE IntMap.mergeA as we promise in the documentation. Also mark the goInsert helpers as a bit more strict. Performance of emulated operations: ``` Benchmark Runtime change Original runtime union-block_nn -19.06% 9.97e-05 union-block_nn_swap -20.55% 1.00e-04 union-block_ns -35.27% 8.08e-06 union-block_sn_swap -35.04% 8.05e-06 union-common_nn -18.06% 6.04e-03 union-common_nn_swap -19.22% 6.12e-03 union-common_ns -56.80% 2.90e-03 union-common_nt -51.60% 8.34e-05 union-common_sn_swap -57.48% 2.93e-03 union-common_tn_swap -53.45% 8.43e-05 union-disj_nn -52.98% 3.05e-07 union-disj_nn_swap -52.49% 3.03e-07 union-disj_ns -55.66% 2.89e-07 union-disj_nt -60.63% 2.71e-07 union-disj_sn_swap -54.66% 2.88e-07 union-disj_tn_swap -60.45% 2.70e-07 union-mix_nn -13.37% 1.59e-02 union-mix_nn_swap -12.37% 1.58e-02 union-mix_ns -39.16% 3.67e-03 union-mix_nt -42.75% 8.66e-05 union-mix_sn_swap -39.95% 3.71e-03 union-mix_tn_swap -44.86% 8.79e-05 difference-block_nn -43.32% 4.48e-05 difference-block_nn_swap -43.06% 4.46e-05 difference-block_ns -59.69% 4.12e-06 difference-block_sn_swap -48.56% 5.60e-06 difference-common_nn -13.30% 4.56e-03 difference-common_nn_swap -33.97% 1.81e-03 difference-common_ns -53.83% 2.88e-03 difference-common_nt -45.61% 9.26e-05 difference-common_sn_swap -54.63% 6.34e-04 difference-common_tn_swap -54.09% 4.93e-05 difference-disj_nn -87.07% 1.90e-07 difference-disj_nn_swap -78.36% 2.08e-07 difference-disj_ns -86.99% 1.89e-07 difference-disj_nt -87.02% 1.89e-07 difference-disj_sn_swap -82.38% 1.99e-07 difference-disj_tn_swap -82.30% 1.98e-07 difference-mix_nn -16.38% 9.76e-03 difference-mix_nn_swap -20.18% 1.11e-02 difference-mix_ns -56.80% 2.79e-03 difference-mix_nt -52.36% 7.93e-05 difference-mix_sn_swap -34.83% 1.45e-03 difference-mix_tn_swap -38.31% 6.32e-05 intersection-block_nn -59.85% 2.07e-05 intersection-block_nn_swap -59.70% 2.08e-05 intersection-block_ns -59.83% 2.94e-06 intersection-block_sn_swap -62.91% 2.99e-06 intersection-common_nn -14.70% 5.23e-03 intersection-common_nn_swap -14.93% 5.23e-03 intersection-common_ns -33.43% 1.49e-03 intersection-common_nt -34.72% 6.33e-05 intersection-common_sn_swap -35.36% 1.48e-03 intersection-common_tn_swap -36.83% 6.59e-05 intersection-disj_nn -86.13% 1.78e-07 intersection-disj_nn_swap -86.34% 1.76e-07 intersection-disj_ns -86.07% 1.77e-07 intersection-disj_nt -86.01% 1.76e-07 intersection-disj_sn_swap -86.24% 1.74e-07 intersection-disj_tn_swap -86.39% 1.76e-07 intersection-mix_nn -44.58% 3.85e-03 intersection-mix_nn_swap -44.90% 3.82e-03 intersection-mix_ns -48.98% 5.39e-04 intersection-mix_nt -54.94% 4.74e-05 intersection-mix_sn_swap -50.07% 5.57e-04 intersection-mix_tn_swap -50.48% 4.74e-05 Minimum -87.07% Average -56.04% Maximum -12.37% ``` Performance of emulation compared to specialized operations: ``` Benchmark Runtime change Original runtime union-block_nn -1.20% 8.17e-05 union-block_nn_swap -4.25% 8.32e-05 union-block_ns +0.53% 5.21e-06 union-block_sn_swap -1.45% 5.31e-06 union-common_nn +49.57% 3.31e-03 union-common_nn_swap -0.64% 4.98e-03 union-common_ns +2.89% 1.22e-03 union-common_nt +0.47% 4.02e-05 union-common_sn_swap +0.92% 1.24e-03 union-common_tn_swap -8.81% 4.30e-05 union-disj_nn +1.07% 1.42e-07 union-disj_nn_swap -0.22% 1.44e-07 union-disj_ns +1.49% 1.26e-07 union-disj_nt +1.53% 1.05e-07 union-disj_sn_swap +1.94% 1.28e-07 union-disj_tn_swap -0.03% 1.07e-07 union-mix_nn +1.09% 1.36e-02 union-mix_nn_swap +2.04% 1.35e-02 union-mix_ns +2.51% 2.18e-03 union-mix_nt +12.23% 4.42e-05 union-mix_sn_swap +0.85% 2.21e-03 union-mix_tn_swap -0.49% 4.87e-05 difference-block_nn +107.90% 1.22e-05 difference-block_nn_swap +111.94% 1.20e-05 difference-block_ns +34.09% 1.24e-06 difference-block_sn_swap +89.53% 1.52e-06 difference-common_nn -9.15% 4.35e-03 difference-common_nn_swap +37.22% 8.71e-04 difference-common_ns +0.39% 1.33e-03 difference-common_nt +10.63% 4.55e-05 difference-common_sn_swap +11.65% 2.58e-04 difference-common_tn_swap +16.59% 1.94e-05 difference-disj_nn -2.40% 2.52e-08 difference-disj_nn_swap +89.49% 2.38e-08 difference-disj_ns -2.24% 2.52e-08 difference-disj_nt -2.37% 2.52e-08 difference-disj_sn_swap +47.28% 2.38e-08 difference-disj_tn_swap +47.34% 2.38e-08 difference-mix_nn -2.01% 8.33e-03 difference-mix_nn_swap +5.10% 8.41e-03 difference-mix_ns +38.97% 8.68e-04 difference-mix_nt +13.85% 3.32e-05 difference-mix_sn_swap +85.34% 5.10e-04 difference-mix_tn_swap +78.34% 2.19e-05 intersection-block_nn -14.35% 9.71e-06 intersection-block_nn_swap -13.30% 9.66e-06 intersection-block_ns +8.28% 1.09e-06 intersection-block_sn_swap -10.45% 1.24e-06 intersection-common_nn +2.93% 4.33e-03 intersection-common_nn_swap +1.46% 4.39e-03 intersection-common_ns +78.29% 5.55e-04 intersection-common_nt +82.81% 2.26e-05 intersection-common_sn_swap +75.48% 5.44e-04 intersection-common_tn_swap +64.66% 2.53e-05 intersection-disj_nn +9.61% 2.25e-08 intersection-disj_nn_swap +4.33% 2.30e-08 intersection-disj_ns +9.58% 2.25e-08 intersection-disj_nt +9.57% 2.25e-08 intersection-disj_sn_swap +4.25% 2.30e-08 intersection-disj_tn_swap +4.33% 2.30e-08 intersection-mix_nn +34.24% 1.59e-03 intersection-mix_nn_swap +24.34% 1.69e-03 intersection-mix_ns +12.85% 2.44e-04 intersection-mix_nt +26.58% 1.69e-05 intersection-mix_sn_swap +0.79% 2.76e-04 intersection-mix_tn_swap +24.17% 1.89e-05 Minimum -14.35% Average +16.35% Maximum +111.94% ``` --- containers/src/Data/IntMap/Merge/Internal.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 52c66efd3..82279bc64 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -422,6 +422,7 @@ merge miss1 miss2 match = \m1 m2 -> runIdentity (mergeA miss1 miss2 match m1 m2) -- 'mergeA' to define custom combining functions. -- -- @since 0.5.9 +{-# INLINE mergeA #-} mergeA :: Applicative f => WhenMissing f a c -> WhenMissing f b c -> WhenMatched f a b c -> IntMap a -> IntMap b -> f (IntMap c) mergeA miss1 miss2 match = start where start (IntMap Empty) (IntMap Empty) = pure (IntMap Empty) @@ -502,32 +503,32 @@ mergeA miss1 miss2 match = start where | otherwise -> makeBinR min1 (matchedSingle match (boundUKey min1) minV1 minV2) (goLFused min1 l1 l2) (goRFused max r1 r2) GT -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min1 minV1 l1)) (goRFused max r1 n2) - goInsertL1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 (unbox k) v) - goInsertL1 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + goInsertL1 !k v !_ !_ Tip = makeSingleton k (missingSingle miss1 (unbox k) v) + goInsertL1 !k v !xorCache !min n@(Bin max maxV l r) = case compareMaxBound k max of InBound | xorCache < xorCacheMax -> liftA2 binNodeMapL (goInsertL1 k v xorCache min l) (missingAllR miss2 (NonEmpty max maxV r)) | otherwise -> makeBinL max (missingSingle miss2 (boundUKey max) maxV) (missingLeft miss2 l) (goInsertR1 k v xorCacheMax max r) OutOfBound -> addMaxL min (Bound k) (missingSingle miss1 (unbox k) v) (missingLeft miss2 n) Matched -> makeBinL max (matchedSingle match (unbox k) v maxV) (missingLeft miss2 l) (missingRight miss2 r) where xorCacheMax = xor k max - goInsertL2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 (unbox k) v) - goInsertL2 !k v !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of + goInsertL2 !k v !_ !_ Tip = makeSingleton k (missingSingle miss2 (unbox k) v) + goInsertL2 !k v !xorCache !min n@(Bin max maxV l r) = case compareMaxBound k max of InBound | xorCache < xorCacheMax -> liftA2 binNodeMapL (goInsertL2 k v xorCache min l) (missingAllR miss1 (NonEmpty max maxV r)) | otherwise -> makeBinL max (missingSingle miss1 (boundUKey max) maxV) (missingLeft miss1 l) (goInsertR2 k v xorCacheMax max r) OutOfBound -> addMaxL min (Bound k) (missingSingle miss2 (unbox k) v) (missingLeft miss1 n) Matched -> makeBinL max (matchedSingle match (unbox k) maxV v) (missingLeft miss1 l) (missingRight miss1 r) where xorCacheMax = xor k max - goInsertR1 !k v !_ _ Tip = makeSingleton k (missingSingle miss1 (unbox k) v) - goInsertR1 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + goInsertR1 !k v !_ !_ Tip = makeSingleton k (missingSingle miss1 (unbox k) v) + goInsertR1 !k v !xorCache !max n@(Bin min minV l r) = case compareMinBound k min of InBound | xorCache < xorCacheMin -> liftA2 binMapNodeR (missingAllL miss2 (NonEmpty min minV l)) (goInsertR1 k v xorCache max r) | otherwise -> makeBinR min (missingSingle miss2 (boundUKey min) minV) (goInsertL1 k v xorCacheMin min l) (missingRight miss2 r) OutOfBound -> addMinR max (Bound k) (missingSingle miss1 (unbox k) v) (missingRight miss2 n) Matched -> makeBinR min (matchedSingle match (unbox k) v minV) (missingLeft miss2 l) (missingRight miss2 r) where xorCacheMin = xor k min - goInsertR2 !k v !_ _ Tip = makeSingleton k (missingSingle miss2 (unbox k) v) - goInsertR2 !k v !xorCache max n@(Bin min minV l r) = case compareMinBound k min of + goInsertR2 !k v !_ !_ Tip = makeSingleton k (missingSingle miss2 (unbox k) v) + goInsertR2 !k v !xorCache !max n@(Bin min minV l r) = case compareMinBound k min of InBound | xorCache < xorCacheMin -> liftA2 binMapNodeR (missingAllL miss1 (NonEmpty min minV l)) (goInsertR2 k v xorCache max r) | otherwise -> makeBinR min (missingSingle miss1 (boundUKey min) minV) (goInsertL2 k v xorCacheMin min l) (missingRight miss1 r) OutOfBound -> addMinR max (Bound k) (missingSingle miss2 (unbox k) v) (missingRight miss1 n) From 3b6a29ab944f9faff47a977e80affb746dc3fa88 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 18 Jan 2020 14:03:12 -0600 Subject: [PATCH 121/147] Minor nits and fixes: - Revert misguided phased NOINLINE pragmas in wrappers of INLINE functions - Define notMember in terms of member to save compiled code - Add lines between definitions - Fix documentation typo --- containers/src/Data/IntMap/Internal.hs | 13 ++++++------- containers/src/Data/IntMap/Lazy.hs | 1 - containers/src/Data/IntMap/Strict.hs | 2 -- 3 files changed, 6 insertions(+), 10 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 2098dbd81..9b0805e03 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -670,7 +670,7 @@ newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) -- bounds also share. This invariant implies that branches are taken based on the immediately -- following bit. When the minimum and maximum are both of the same sign, the 0 branch is lesser -- and therefore assigned to the left side. For example, when splitting between 4 (@0100@) and --- 7 (@0111@), which disagree in the 2's place, 5 (@0101) would be found on the left side since +-- 7 (@0111@), which disagree in the 2's place, 5 (@0101@) would be found on the left side since -- it has a 0 in the 2's place; similarly, -7 (@1001@) and -4 (@1100@) disagree in the 4's -- place, and -5 (@1011@) would be found on the left side since it has a 0 in the 4's place. -- However, when the minimum and maximum disagree in sign, they differ in the first bit, the @@ -1012,7 +1012,6 @@ lookupChurch nothing just !k = start -- -- > member 5 (fromList [(5,'a'), (3,'b')]) == True -- > member 1 (fromList [(5,'a'), (3,'b')]) == False -{-# NOINLINE[1] member #-} member :: Key -> IntMap a -> Bool member !k = lookupChurch False (const True) k @@ -1020,12 +1019,10 @@ member !k = lookupChurch False (const True) k -- -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True -{-# NOINLINE[1] notMember #-} notMember :: Key -> IntMap a -> Bool -notMember !k = lookupChurch True (const False) k +notMember !k = not . member k -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'. -{-# NOINLINE[1] lookup #-} lookup :: Key -> IntMap a -> Maybe a lookup !k = lookupChurch Nothing Just k @@ -1035,7 +1032,6 @@ lookup !k = lookupChurch Nothing Just k -- -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' -{-# NOINLINE[1] findWithDefault #-} findWithDefault :: a -> Key -> IntMap a -> a findWithDefault def !k = lookupChurch def id k @@ -1240,16 +1236,19 @@ insertWithEval eval = start -- Small functions that really ought to be defined in Data.IntMap.Lazy but have -- to be here for the sake of type class implementations -{-# NOINLINE[1] insertLazy #-} insertLazy :: Key -> a -> IntMap a -> IntMap a insertLazy = insertWithEval (const ()) const + fromListLazy :: [(Key, a)] -> IntMap a fromListLazy = Data.List.foldl' (\t (k, a) -> insertLazy k a t) empty + mapLazy :: (a -> b) -> IntMap a -> IntMap b mapLazy f (IntMap m) = IntMap (mapLazy_ f m) + mapLazy_ :: (a -> b) -> IntMap_ t a -> IntMap_ t b mapLazy_ _ Empty = Empty mapLazy_ f (NonEmpty min minV root) = NonEmpty min (f minV) (mapNodeLazy f root) + mapNodeLazy :: (a -> b) -> Node t a -> Node t b mapNodeLazy _ Tip = Tip mapNodeLazy f (Bin bound value l r) = Bin bound (f value) (mapNodeLazy f l) (mapNodeLazy f r) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 98bc8995c..b4d357f66 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -265,7 +265,6 @@ insert = insertLazy -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" -{-# NOINLINE[1] insertWith #-} insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWith = insertWithEval noeval diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 19fc30a76..38338025c 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -280,7 +280,6 @@ singleton !k !v = IntMap (NonEmpty (Bound k) v Tip) -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')] -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')] -- > insert 5 'x' empty == singleton 5 'x' -{-# NOINLINE[1] insert #-} insert :: Key -> a -> IntMap a -> IntMap a insert = insertWithEval wheval const @@ -293,7 +292,6 @@ insert = insertWithEval wheval const -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" -{-# NOINLINE[1] insertWith #-} insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWith = insertWithEval wheval From 205e2a8591e57ee465bcc170b107a2463740396f Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sat, 18 Jan 2020 15:50:16 -0600 Subject: [PATCH 122/147] Make IntMap.lookupChurch inline after two arguments, not three, making it harder to mess up --- containers/src/Data/IntMap/Internal.hs | 52 +++++++++++++------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 9b0805e03..b55bf5af8 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -979,41 +979,41 @@ size (IntMap (NonEmpty _ _ node)) = sizeNode 0 node -- | /O(min(n,W)/. Lookup the value at a key in the map, returning the result -- to the provided continuations. See also 'lookup'. -- --- When 'lookupChurch' is given three arguments (the continuations and key), it --- is inlined to the call site. You should therefore use 'lookupChurch' only to +-- When 'lookupChurch' is given two arguments (the continuations), it is +-- inlined to the call site. You should therefore use 'lookupChurch' only to -- define custom lookup functions. {-# INLINE lookupChurch #-} lookupChurch :: r -> (a -> r) -> Key -> IntMap a -> r -lookupChurch nothing just !k = start +lookupChurch nothing just = search where - start (IntMap Empty) = nothing - start (IntMap (NonEmpty min minV node)) = case compareMinBound k min of + search !_ (IntMap Empty) = nothing + search !k (IntMap (NonEmpty rootMin rootMinV root)) = case compareMinBound k rootMin of OutOfBound -> nothing - Matched -> just minV - InBound -> goL (xor k min) node - - goL !_ Tip = nothing - goL !xorCache (Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> goL xorCache l - | otherwise -> goR xorCacheMax r - OutOfBound -> nothing - Matched -> just maxV - where xorCacheMax = xor k max - - goR !_ Tip = nothing - goR !xorCache (Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> goR xorCache r - | otherwise -> goL xorCacheMin l - OutOfBound -> nothing - Matched -> just minV - where xorCacheMin = xor k min + Matched -> just rootMinV + InBound -> goL (xor k rootMin) root + where + goL !_ Tip = nothing + goL !xorCache (Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> goL xorCache l + | otherwise -> goR xorCacheMax r + OutOfBound -> nothing + Matched -> just maxV + where xorCacheMax = xor k max + + goR !_ Tip = nothing + goR !xorCache (Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> goR xorCache r + | otherwise -> goL xorCacheMin l + OutOfBound -> nothing + Matched -> just minV + where xorCacheMin = xor k min -- | /O(min(n,W))/. Is the key a member of the map? -- -- > member 5 (fromList [(5,'a'), (3,'b')]) == True -- > member 1 (fromList [(5,'a'), (3,'b')]) == False member :: Key -> IntMap a -> Bool -member !k = lookupChurch False (const True) k +member = lookupChurch False (const True) -- | /O(min(n,W))/. Is the key not a member of the map? -- @@ -1024,7 +1024,7 @@ notMember !k = not . member k -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'. lookup :: Key -> IntMap a -> Maybe a -lookup !k = lookupChurch Nothing Just k +lookup = lookupChurch Nothing Just -- | /O(min(n,W))/. The expression @'findWithDefault' def k map@ -- returns the value at key @k@ or returns @def@ when the key is not an @@ -1033,7 +1033,7 @@ lookup !k = lookupChurch Nothing Just k -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' findWithDefault :: a -> Key -> IntMap a -> a -findWithDefault def !k = lookupChurch def id k +findWithDefault def = lookupChurch def id -- | /O(log n)/. Find largest key smaller than the given one and return the -- corresponding (key, value) pair. From a9655f9eebcc6d042dd950205c71a15e42e82ee2 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Sun, 19 Jan 2020 12:00:47 -0600 Subject: [PATCH 123/147] Remove unnecessary special case in IntMap.union, regularizing which argument gets matched on first --- containers/src/Data/IntMap/Internal.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index b55bf5af8..e07634d6e 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1324,7 +1324,6 @@ union = start | min1 > min2 = IntMap (NonEmpty min2 minV2 (goL1 minV1 min1 root1 min2 root2)) | otherwise = IntMap (NonEmpty min1 minV1 (goLFused min1 root1 root2)) -- we choose min1 arbitrarily, as min1 == min2 - goL1 minV1 !min1 Tip !_ Tip = Bin (minToMax min1) minV1 Tip Tip goL1 minV1 !min1 !n1 !min2 Tip = insertMinL (xor (boundKey min1) min2) min1 minV1 n1 goL1 minV1 !min1 !n1 !min2 n2@(Bin max2 _ _ _) | boundsDisjoint min1 max2 = unionDisjointL minV1 min2 n2 min1 n1 goL1 minV1 !min1 Tip !min2 !n2 = goInsertL1 (boundKey min1) minV1 (xor (boundKey min1) min2) min2 n2 @@ -1338,7 +1337,6 @@ union = start | otherwise -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goL1 minV1 min1 l1 min2 n2) r1 - goL2 minV2 !_ Tip !min2 Tip = Bin (minToMax min2) minV2 Tip Tip goL2 minV2 !min1 Tip !min2 !n2 = insertMinL (xor (boundKey min2) min1) min2 minV2 n2 goL2 minV2 !min1 n1@(Bin max1 _ _ _) !min2 !n2 | boundsDisjoint min2 max1 = unionDisjointL minV2 min1 n1 min2 n2 goL2 minV2 !min1 !n1 !min2 Tip = goInsertL2 (boundKey min2) minV2 (xor (boundKey min2) min1) min1 n1 @@ -1363,7 +1361,6 @@ union = start | otherwise -> Bin max1 maxV1 (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> Bin max1 maxV1 (goLFused min l1 n2) r1 - goR1 maxV1 !max1 Tip !_ Tip = Bin (maxToMin max1) maxV1 Tip Tip goR1 maxV1 !max1 !n1 !max2 Tip = insertMaxR (xor (boundKey max1) max2) max1 maxV1 n1 goR1 maxV1 !max1 !n1 !max2 n2@(Bin min2 _ _ _) | boundsDisjoint min2 max1 = unionDisjointR maxV1 max1 n1 max2 n2 goR1 maxV1 !max1 Tip !max2 !n2 = goInsertR1 (boundKey max1) maxV1 (xor (boundKey max1) max2) max2 n2 @@ -1377,7 +1374,6 @@ union = start | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goR1 maxV1 max1 r1 max2 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> Bin min1 minV1 l1 (goR1 maxV1 max1 r1 max2 n2) - goR2 maxV2 !_ Tip !max2 Tip = Bin (maxToMin max2) maxV2 Tip Tip goR2 maxV2 !max1 Tip !max2 !n2 = insertMaxR (xor (boundKey max2) max1) max2 maxV2 n2 goR2 maxV2 !max1 n1@(Bin min1 _ _ _) !max2 !n2 | boundsDisjoint min1 max2 = unionDisjointR maxV2 max2 n2 max1 n1 goR2 maxV2 !max1 !n1 !max2 Tip = goInsertR2 (boundKey max2) maxV2 (xor (boundKey max2) max1) max1 n1 From 6a81914055a35871ea80fa6affbd3bf10e1275c0 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Tue, 21 Jan 2020 13:22:57 -0600 Subject: [PATCH 124/147] Force inlining of some trivial IntMap functions. This isn't enough for -fprof-auto to reasonably profile IntMap, since the boundKey field accessor can't be marked inline, but it at least increases reliability of inlining --- containers/src/Data/IntMap/Internal.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index e07634d6e..f1f605fed 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -508,10 +508,12 @@ type Key = Int type UKey = Int# -- | Convert a 'UKey' into the equivalent 'Key'. +{-# INLINE box #-} box :: UKey -> Key box = I# -- | Convert a 'Key' into the equivalent 'UKey'. +{-# INLINE unbox #-} unbox :: Key -> UKey unbox (I# x) = x #else @@ -521,14 +523,17 @@ unbox (I# x) = x type UKey = Key -- | Convert a 'UKey' into the equivalent 'Key'. +{-# INLINE box #-} box :: UKey -> Key box = id -- | Convert a 'Key' into the equivalent 'UKey'. +{-# INLINE unbox #-} unbox :: Key -> UKey unbox = id #endif +{-# INLINE i2w #-} i2w :: Key -> Word i2w = fromIntegral From dd904e250c13c0f1e55e0048ac6799d0804ac38e Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 22 Jan 2020 19:09:09 -0600 Subject: [PATCH 125/147] Add long-form merge documentation for IntMap --- containers/src/Data/IntMap/Internal.hs | 4 + containers/src/Data/IntMap/Merge/Internal.hs | 168 +++++++++++++++++++ 2 files changed, 172 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index f1f605fed..c27786e60 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -577,6 +577,10 @@ xor a (Bound b) = Data.Bits.xor (i2w a) (i2w b) xorBounds :: Bound L -> Bound R -> Word xorBounds (Bound min) (Bound max) = Data.Bits.xor (i2w min) (i2w max) +-- | Check if two bounds necessarily bound non-overlapping ranges of keys (i.e. +-- the minimum is greater than the maximum). This is used in merges, indicating +-- when the subtrees from the two maps become unrelated, never sharing another +-- key. See 'Data.IntMap.Merge.Internal' for further details on its use. {-# INLINE boundsDisjoint #-} boundsDisjoint :: Bound L -> Bound R -> Bool boundsDisjoint (Bound min) (Bound max) = min > max diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 82279bc64..c9c13d588 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -37,6 +37,174 @@ -- -- This defines the data structures and core (hidden) manipulations -- on representations. +-- +-- = The Merging Process +-- +-- Since keys have consistent positions in trie-like structures, merging is +-- largely a problem of alignment. Considering the sets of keys matching the +-- bit prefix of a node, we have the following six cases: +-- +-- 1. Disjoint ranges +-- +-- > Node 1: ## +-- > Node 2: #### +-- +-- Depending on the type of merge, we combine the nodes. If +-- 'Data.IntMap.Lazy.union', we create a new 'Bin' combining the nodes. +-- If 'Data.IntMap.Lazy.intersection', we return 'Empty'. In general, both +-- nodes get passed through the 'WhenMissing' tactics then combined. +-- +-- 2. Equal ranges +-- +-- > Node 1: #### +-- > Node 2: #### +-- +-- We recurively merge node 1's left branch with node 2's left branch and +-- node 1's right branch with node 2's right branch. +-- +-- 3. 1-in-2 (left) +-- +-- > Node 1: ## +-- > Node 2: #### +-- +-- We recursively merge node 1 with node 2's left branch. +-- +-- 4. 1-in-2 (right) +-- +-- > Node 1: ## +-- > Node 2: #### +-- +-- We recursively merge node 1 with node 2's right branch. +-- +-- 5. 2-in-1 (left) +-- +-- > Node 1: #### +-- > Node 2: ## +-- +-- We recursively merge node 1's left branch with node 2. +-- +-- 6. 2-in-1 (right) +-- +-- > Node 1: #### +-- > Node 2: ## +-- +-- We recursively merge node 1's right branch with node 2. +-- +-- Distinguishing the latter 5 cases is much harder with the disjoint ranges +-- case in the mix, so eliminating that is the first step. With the min/max +-- implicit representation, we can test for that case by seeing if the minimum +-- of one node is greater than the maximum of the other node 'boundsDisjoint'. +-- Technically, this condition can also trigger in the other cases, since the +-- cases defined above are about shared bits, not being in between the minima +-- and maxima. For example, a minimum of -1 shares no bits with a maximum of 0, +-- so for the purposes of the cases above, a node with those bounds would have +-- a "shared bits range" of all integers. However, determining that two nodes +-- will never overlap is a useful condition in its own right. If taking an +-- intersection, for example, we can immediately return 'Empty', and even the +-- union case can be simplified (see 'unionDisjointL' and 'unionDisjointR') if +-- not to a single 'Bin' node. +-- +-- Once the ranges of the nodes are known to be overlapping, we can compare +-- range sizes to distinguish between the equal, 1-in-2, and 2-in-1 cases. When +-- the minumum and maximum bounds for a node are XORed with each other (using +-- 'xorBounds'), all shared prefix bits will cancel each other out and produce +-- zeros, and the first bit where the bounds disagree will become the result's +-- most significant set bit (MSB). This justifies using 'compareMSB' to compare +-- how many shared prefix bits the two nodes have. The left and right variants +-- of the 1-in-2 and 2-in-1 cases can then be distinguished using the same +-- techniques as in single-key queries, taking a key from the smaller node and +-- determining which branch it belongs in. +-- +-- == Bound Complications +-- +-- Unfortunately, since our tree structure is a bit more complicated than a +-- PATRICIA tree, there is more complexity involved. Instead of just aligning +-- internal nodes and merging values at the keys, we need to interleave the +-- combination of values with the alignment of nodes. At every point in the +-- recursion, whenever we produce a composite node, we need to produce the key +-- and value that go along with that node. +-- +-- Determining which bound to keep and what values to combine is +-- straightforward; the lesser of the two minima is the new minimum, and the +-- greater of the two maxima is new maximum. However, the unused key/value +-- pair (if there is one) needs to be pushed downward in the recursion to be +-- included in the merged map. This necessitates three variants of each helper +-- function, corresponding to the three choices of pushing down the value from +-- node 1, pushing down the value from node 2, and pushing down neither. For +-- example, @goL1@ is called when @min1 > min2@, @goL2@ when @min2 > min1@, and +-- @goLFused@ when @min1 = min2@. +-- +-- As we are forced to do these comparisons anyway, we can use them to reduce +-- the number of cases to consider. When @min1 > min2@, for example, @min2@ +-- cannot be greater than @max1@, so a single comparison suffices to determine +-- whether the ranges are disjoint, and the 2-in-1 (right) case is impossible. +-- +-- == Base Case: Merging leaves into trees +-- +-- In the base case, when the recursion hits the leaves, there are two cases. +-- If the 'Tip' corresponds to the bound that was pushed down from higher up +-- in the tree, then the merge operation begins to look like an insertion (in +-- the case of 'Data.IntMap.Lazy.union'), deletion (in +-- 'Data.IntMap.Lazy.difference' for the second map's leaves), or lookup (in +-- 'Data.IntMap.Lazy.intersection'). These helpers match the general structure +-- of normal single-key operations. However, there still need to be two +-- variants for which map's leaves are being inserted into which other map. +-- +-- If the 'Tip' corresponds to the bound that was already handled earlier in +-- the merge process, however, the recursion can immediately end. +-- +-- == Deletion and Choice of Intermediate +-- +-- Each step in the merge process as described so far processes a single key +-- (the merged bound for the node), recursion on the left branch (or a left +-- branch taken from one map), and recursion on the right brnach (or a right +-- branch taken from one map). This naturally corresponds to the arguments of +-- 'Bin' (a key/value pair and two 'Node's). However, that only matches up +-- when all of the keys are preserved, as in 'Data.IntMap.Lazy.union'. If the +-- merged bound is instead deleted, then it needs to be replaced with a bound +-- pulled from one of the two recursive cases. +-- +-- If the helper functions return 'Node's, extracting bounds from the recursive +-- cases using 'deleteMinL' and 'deleteMaxR' (or a wrapper function like +-- 'extractBinL' or 'extractBinR') is an expensive operation. After traversing +-- and reconstructing the subtrees in the merging provcess, they need to be +-- re-traversed and reconstructed again to pull out one of the entries. A more +-- efficient option would be to fuse the traversals, returning an 'IntMap_' +-- the recursive case. Since an 'IntMap_' already contains its own bound pulled +-- out, we can just put the pieces together in constant time. +-- +-- However, 'IntMap_' isn't a universally better choice for intermediate type. +-- When the outside key is kept, the 'IntMap_' needs to be converted back into +-- a 'Node', causing the same problem, but with insertion instead of deletion. +-- Both intermediate types are appropriate, often in the same merge operation, +-- depending only on whether the external bound has been kept or deleted. +-- 'Data.IntMap.Lazy.union' always keeps its keys so uses 'Node's everywhere. +-- 'Data.IntMap.Lazy.intersection' keeps its keys when they match, so +-- @go{L,R}Fused@ return 'Node's, but mismatched keys are dropped, so +-- @go{L,R}{1,2}@ return 'IntMap_'s. A function like +-- 'Data.IntMap.Lazy.differenceWith' needs two variants of @go{L,R}Fused@ +-- since different matched keys are kept and deleted in the same merge +-- operation. +-- +-- 'mergeA' is a particularly tricky function with regards to this decision. +-- Unlike the specialized merge operations, we don't statically know which keys +-- will be deleted, and unlike 'Data.IntMap.Lazy.differenceWith', we don't even +-- have that information at runtime: merge tactics return @f ('Maybe' a)@ +-- where @f@ is an arbitrary 'Applicative', and we can't choose what actions to +-- combine with that value based on the value itself. (As an aside, a 'Monad' +-- bound would not help either despite providing exactly that kind of choice, +-- as the actions associated with maximum bounds need to be sequenced after the +-- actions of the recursive cases.) Therefore, we need to choose a +-- representation with a good average case. If keys are being deleted, then the +-- maps returned by the recursive cases will be smaller, making the overhead of +-- pulling new bounds out also smaller. Therefore, universally using 'Node's +-- has a smaller overhead than universally using 'IntMap_'s and so is a better +-- choice. +-- +-- TODO: Theoretically, the recursive case could return both a 'Node' and an +-- 'IntMap_', stored in a lazy pair. This would allow selecting which to use +-- and only evaluating the one that is needed. It may also just result in +-- excessive work. ----------------------------------------------------------------------------- module Data.IntMap.Merge.Internal ( From 4fe194f4575eb7ca251a41f69e469254821d1093 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 22 Jan 2020 19:31:43 -0600 Subject: [PATCH 126/147] Consistently use capitalized XOR in IntMap documentation --- containers/src/Data/IntMap/Internal.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index c27786e60..890abc36e 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -44,7 +44,7 @@ -- = Tree Structure -- -- This implementation uses a novel modification of /big-endian patricia trees/, structured --- as a vantage-point tree under the xor metric. +-- as a vantage-point tree under the XOR metric. -- -- = Derivation -- @@ -537,7 +537,7 @@ unbox = id i2w :: Key -> Word i2w = fromIntegral --- | Xor a key with a bound for the purposes of navigation within the tree. +-- | XOR a key with a bound for the purposes of navigation within the tree. -- -- The navigation process is as follows. Suppose we are looking up a key @k@ in a tree. We know -- the minimum key in the tree, @min@, and the maximum key, @max@. Represented in binary: @@ -560,7 +560,7 @@ i2w = fromIntegral -- > xor k max: 000000000000 0 ???????? -- -- Therefore, the splitting bit is set iff @'xor' k min > 'xor' k max@. Put another way, the key --- shares more bits with the bound that it is closer to under the xor metric, since exclusive or +-- shares more bits with the bound that it is closer to under the XOR metric, since exclusive or -- maps shared bits to zero. The metric perspective also makes it clear why this works unmodified -- in the presence of negative numbers, despite storing negative numbers (with a set sign bit) in -- the left branch normally identified with an unset bit. As long as the comparison is done @@ -570,7 +570,7 @@ i2w = fromIntegral xor :: Key -> Bound t -> Word xor a (Bound b) = Data.Bits.xor (i2w a) (i2w b) --- | Xor the minimum and maximum keys of a tree. The most significant bit of the result indicates +-- | XOR the minimum and maximum keys of a tree. The most significant bit of the result indicates -- which bit to split on for navigation and is useful in merging maps to tell whether nodes from -- different maps branch at the same time. {-# INLINE xorBounds #-} @@ -671,7 +671,7 @@ newtype IntMap a = IntMap (IntMap_ L a) deriving (Eq) -- minimum bound for the 'Node' than with the maximum bound for the 'Node', and vice versa for -- the right branch: all keys within the right branch of a 'Bin' 'Node' must share a longer bit -- prefix with the maximum bound for the 'Node' than with the minimum bound for the 'Node'. --- Put another way, under the xor metric, keys in the left branch are closer to the minimum +-- Put another way, under the XOR metric, keys in the left branch are closer to the minimum -- bound than the maximum bound (@'xor' k min < 'xor' k max@), while keys in the right branch -- are closer to the maximum bound than the minimum bound. (@'xor' k min > 'xor' k max@). -- @@ -710,7 +710,7 @@ data IntMap_ t a = NonEmpty {-# UNPACK #-} !(Bound t) a !(Node t a) | Empty deri -- universally true. Some functions, like 'map' or 'filter', preserve the overall branch structure -- and don't need to understand the criteria used to choose between left and right. Others, like -- 'lookup', only need to understand the branching criteria with regards to a single, fixed key, --- and can instead pass the xor-distance between that key and the missing bound. +-- and can instead pass the XOR-distance between that key and the missing bound. data Node t a = Bin {-# UNPACK #-} !(Bound (Flipped t)) a !(Node L a) !(Node R a) | Tip deriving (Eq, Show) -- | The non-empty case of 'IntMap_'. @@ -1290,7 +1290,7 @@ delete !k m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of OutOfBound -> m Matched -> IntMap (nodeToMapL root) --- | Delete a key from a left node. Takes the xor of the deleted key and +-- | Delete a key from a left node. Takes the XOR of the deleted key and -- the minimum bound of that node. -- -- This would normally be a local method of 'delete', but it can be reused in @@ -1304,7 +1304,7 @@ deleteL !k !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of Matched -> extractBinL l r where xorCacheMax = xor k max --- | Delete a key from a right node. Takes the xor of the deleted key and +-- | Delete a key from a right node. Takes the XOR of the deleted key and -- the maximum bound of that node. -- -- This would normally be a local method of 'delete', but it can be reused in @@ -2621,7 +2621,7 @@ maxViewWithKey (IntMap (NonEmpty min minV (Bin max maxV l r))) = Just ((boundKey -- argument is less significant than the most significant bit of its second -- argument. --- This works by measuring whether x is in between 0 and y but closer to 0 (in the xor metric). +-- This works by measuring whether x is in between 0 and y but closer to 0 (in the XOR metric). {-# INLINE ltMSB #-} ltMSB :: Word -> Word -> Bool ltMSB x y = x < y && x < Data.Bits.xor x y @@ -2680,7 +2680,7 @@ r2lNE (NE max maxV Tip) = NE (maxToMin max) maxV Tip r2lNE (NE max maxV (Bin min minV l r)) = NE min minV (Bin max maxV l r) -- | Insert a key/value pair to a left node where the key is smaller than --- any present in that node. Requires the xor of the inserted key and the +-- any present in that node. Requires the XOR of the inserted key and the -- key immediately prior to it (the minimum bound of the node). insertMinL :: Word -> Bound L -> a -> Node L a -> Node L a insertMinL !_ !min minV Tip = Bin (minToMax min) minV Tip Tip @@ -2695,7 +2695,7 @@ insertMinL !xorCache !min minV (Bin max maxV l r) | otherwise = Bin max maxV (insertMinL xorCache min minV l) r -- | Insert a key/value pair to a right node where the key is greater than --- any present in that node. Requires the xor of the inserted key and the +-- any present in that node. Requires the XOR of the inserted key and the -- key immediately following it (the maximum bound of the node). insertMaxR :: Word -> Bound R -> a -> Node R a -> Node R a insertMaxR !_ !max maxV Tip = Bin (maxToMin max) maxV Tip Tip From cf63d2f5bffbff224b6fbc09f41053f2da76c368 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 22 Jan 2020 20:10:42 -0600 Subject: [PATCH 127/147] Move the bin{NodeMapL,MapNodeR} helpers into Data.IntMap.Internal and use them where possible. --- containers/src/Data/IntMap/Internal.hs | 136 ++++++------------- containers/src/Data/IntMap/Lazy.hs | 54 ++------ containers/src/Data/IntMap/Merge/Internal.hs | 28 +--- containers/src/Data/IntMap/Strict.hs | 52 ++----- 4 files changed, 59 insertions(+), 211 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 890abc36e..d6e7338b6 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -410,6 +410,8 @@ module Data.IntMap.Internal ( -- ** Internal Manipulation , binL , binR + , binNodeMapL + , binMapNodeR , extractBinL , extractBinR , l2rMap @@ -1504,20 +1506,12 @@ difference = start goL2 !min1 n1@(Bin max1 maxV1 l1 r1) !min2 n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goL2 min1 n1 min2 l2 EQ | max1 > max2 -> Bin max1 maxV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> goL2 min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' - | otherwise -> case goRFused max1 r1 r2 of - Empty -> goL2 min1 l1 min2 l2 - NonEmpty max' maxV' r' -> Bin max' maxV' (goL2 min1 l1 min2 l2) r' + | max1 < max2 -> binNodeMapL (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> binNodeMapL (goL2 min1 l1 min2 l2) (goRFused max1 r1 r2) GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> Bin max1 maxV1 (goL2 min1 l1 min2 n2) r1 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> Bin max1 maxV1 l1 (goR2 max1 r1 max2 (Bin min2 dummyV l2 r2)) - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) of - Empty -> l1 - NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' - | otherwise -> case goRFused max1 r1 (Bin min2 dummyV l2 r2) of - Empty -> l1 - NonEmpty max' maxV' r' -> Bin max' maxV' l1 r' + | max1 < max2 -> binNodeMapL l1 (goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2)) + | otherwise -> binNodeMapL l1 (goRFused max1 r1 (Bin min2 dummyV l2 r2)) goLFused !_ Tip !_ = Empty goLFused !_ (Bin max1 maxV1 l1 r1) Tip = case deleteMinL max1 maxV1 l1 r1 of @@ -1548,20 +1542,12 @@ difference = start goR2 !max1 n1@(Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max1) (xorBounds min2 max2) of LT -> goR2 max1 n1 max2 r2 EQ | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> goR2 max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) - | otherwise -> case goLFused min1 l1 l2 of - Empty -> goR2 max1 r1 max2 r2 - NonEmpty min' minV' l' -> Bin min' minV' l' (goR2 max1 r1 max2 r2) + | min1 > min2 -> binMapNodeR (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) + | otherwise -> binMapNodeR (goLFused min1 l1 l2) (goR2 max1 r1 max2 r2) GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> Bin min1 minV1 l1 (goR2 max1 r1 max2 n2) -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> Bin min1 minV1 (goL2 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 - | min1 > min2 -> case goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) of - Empty -> r1 - NonEmpty min' minV' l' -> Bin min' minV' l' r1 - | otherwise -> case goLFused min1 l1 (Bin max2 dummyV l2 r2) of - Empty -> r1 - NonEmpty min' minV' l' -> Bin min' minV' l' r1 + | min1 > min2 -> binMapNodeR (goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2)) r1 + | otherwise -> binMapNodeR (goLFused min1 l1 (Bin max2 dummyV l2 r2)) r1 goRFused !_ Tip !_ = Empty goRFused !_ (Bin min1 minV1 l1 r1) Tip = case deleteMaxR min1 minV1 l1 r1 of @@ -1616,9 +1602,7 @@ intersection = start | otherwise -> r2lMap $ NonEmpty max1 maxV1 (goRFused max1 (Bin min1 minV1 l1 r1) r2) EQ | max1 > max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | max1 < max2 -> binL (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2)) + | otherwise -> binL (goL1 minV1 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) GT -> goL1 minV1 min1 l1 min2 n2 goL2 !_ Tip !_ !_ = Empty @@ -1628,9 +1612,7 @@ intersection = start LT -> goL2 min1 n1 min2 l2 EQ | max1 > max2 -> binL (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | max1 < max2 -> binL (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goL2 min1 l1 min2 l2 of - Empty -> r2lMap (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max1 maxV1 l' (goRFused max1 r1 r2)) + | otherwise -> binL (goL2 min1 l1 min2 l2) (NonEmpty max1 maxV1 (goRFused max1 r1 r2)) GT | xor (boundKey min2) min1 < xor (boundKey min2) max1 -> goL2 min1 l1 min2 n2 -- min2 is arbitrary here - we just need something from tree 2 | max1 > max2 -> r2lMap $ goR2 max1 r1 max2 (Bin min2 dummyV l2 r2) | max1 < max2 -> r2lMap $ goR1 maxV1 max1 r1 max2 (Bin min2 dummyV l2 r2) @@ -1640,15 +1622,9 @@ intersection = start goLFused !_ !_ Tip = Tip goLFused !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 _ l2 r2) = case compareMSB (xorBounds min max1) (xorBounds min max2) of LT -> goLFused min n1 l2 - EQ | max1 > max2 -> case goR2 max1 r1 max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' - | max1 < max2 -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l' - NonEmpty max' maxV' r' -> Bin max' maxV' l' r' - | otherwise -> Bin max1 maxV1 l' (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 - where - l' = goLFused min l1 l2 + EQ | max1 > max2 -> binNodeMapL (goLFused min l1 l2) (goR2 max1 r1 max2 r2) + | max1 < max2 -> binNodeMapL (goLFused min l1 l2) (goR1 maxV1 max1 r1 max2 r2) + | otherwise -> Bin max1 maxV1 (goLFused min l1 l2) (goRFused max1 r1 r2) -- we choose max1 arbitrarily, as max1 == max2 GT -> goLFused min l1 n2 goR1 _ !_ !_ !_ Tip = Empty @@ -1661,9 +1637,7 @@ intersection = start | otherwise -> l2rMap $ NonEmpty min1 minV1 (goLFused min1 (Bin max1 maxV1 l1 r1) l2) EQ | min1 < min2 -> binR (goL2 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR1 maxV1 max1 r1 max2 r2) - | otherwise -> case goR1 maxV1 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') + | otherwise -> binR (NonEmpty min1 minV1 (goLFused min1 l1 l2)) (goR1 maxV1 max1 r1 max2 r2) GT -> goR1 maxV1 max1 r1 max2 n2 goR2 !_ Tip !_ !_ = Empty @@ -1673,9 +1647,7 @@ intersection = start LT -> goR2 max1 n1 max2 r2 EQ | min1 < min2 -> binR (goL2 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) | min1 > min2 -> binR (goL1 minV1 min1 l1 min2 l2) (goR2 max1 r1 max2 r2) - | otherwise -> case goR2 max1 r1 max2 r2 of - Empty -> l2rMap (NonEmpty min1 minV1 (goLFused min1 l1 l2)) - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min1 minV1 (goLFused min1 l1 l2) r') + | otherwise -> binR (NonEmpty min1 minV1 (goLFused min1 l1 l2)) (goR2 max1 r1 max2 r2) GT | xor (boundKey max2) min1 > xor (boundKey max2) max1 -> goR2 max1 r1 max2 n2 -- max2 is arbitrary here - we just need something from tree 2 | min1 < min2 -> l2rMap $ goL2 min1 l1 min2 (Bin max2 dummyV l2 r2) | min1 > min2 -> l2rMap $ goL1 minV1 min1 l1 min2 (Bin max2 dummyV l2 r2) @@ -1685,15 +1657,9 @@ intersection = start goRFused !_ !_ Tip = Tip goRFused !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 _ l2 r2) = case compareMSB (xorBounds min1 max) (xorBounds min2 max) of LT -> goRFused max n1 r2 - EQ | min1 < min2 -> case goL2 min1 l1 min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' - | min1 > min2 -> case goL1 minV1 min1 l1 min2 l2 of - Empty -> r' - NonEmpty min' minV' l' -> Bin min' minV' l' r' - | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) r' -- we choose max1 arbitrarily, as max1 == max2 - where - r' = goRFused max r1 r2 + EQ | min1 < min2 -> binMapNodeR (goL2 min1 l1 min2 l2) (goRFused max r1 r2) + | min1 > min2 -> binMapNodeR (goL1 minV1 min1 l1 min2 l2) (goRFused max r1 r2) + | otherwise -> Bin min1 minV1 (goLFused min1 l1 l2) (goRFused max r1 r2) -- we choose min1 arbitrarily, as min1 == min2 GT -> goRFused max r1 n2 goLookupL1 !_ _ !_ Tip = Empty @@ -2085,33 +2051,21 @@ filterWithUKey p = start goL Tip = Tip goL (Bin max maxV l r) | p (boundUKey max) maxV = Bin max maxV (goL l) (goR r) - | otherwise = case goDeleteR r of - Empty -> goL l - NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' + | otherwise = binNodeMapL (goL l) (goDeleteR r) goR Tip = Tip goR (Bin min minV l r) | p (boundUKey min) minV = Bin min minV (goL l) (goR r) - | otherwise = case goDeleteL l of - Empty -> goR r - NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) + | otherwise = binMapNodeR (goDeleteL l) (goR r) goDeleteL Tip = Empty goDeleteL (Bin max maxV l r) - | p (boundUKey max) maxV = case goDeleteL l of - Empty -> case goR r of - Tip -> NonEmpty (maxToMin max) maxV Tip - Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) - NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV l' (goR r)) + | p (boundUKey max) maxV = binL (goDeleteL l) (NonEmpty max maxV (goR r)) | otherwise = binL (goDeleteL l) (goDeleteR r) goDeleteR Tip = Empty goDeleteR (Bin min minV l r) - | p (boundUKey min) minV = case goDeleteR r of - Empty -> case goL l of - Tip -> NonEmpty (minToMax min) minV Tip - Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) - NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV (goL l) r') + | p (boundUKey min) minV = binR (NonEmpty min minV (goL l)) (goDeleteR r) | otherwise = binR (goDeleteL l) (goDeleteR r) -- | /O(n+m)/. The restriction of a map to the keys in a set. @@ -2174,13 +2128,7 @@ partitionWithUKey p = start in Bin max maxV tl tr :*: binL fl fr | otherwise = let tl :*: fl = goTrueL l tr :*: fr = goFalseR r - t = case tr of - Empty -> tl - NonEmpty max' maxV' r' -> Bin max' maxV' tl r' - f = case fl of - Empty -> r2lMap $ NonEmpty max maxV fr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' fr) - in t :*: f + in binNodeMapL tl tr :*: binL fl (NonEmpty max maxV fr) goTrueR Tip = Tip :*: Empty goTrueR (Bin min minV l r) @@ -2189,26 +2137,14 @@ partitionWithUKey p = start in Bin min minV tl tr :*: binR fl fr | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goTrueR r - t = case tl of - Empty -> tr - NonEmpty min' minV' l' -> Bin min' minV' l' tr - f = case fr of - Empty -> l2rMap $ NonEmpty min minV fl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV fl r') - in t :*: f + in binMapNodeR tl tr :*: binR (NonEmpty min minV fl) fr goFalseL Tip = Empty :*: Tip goFalseL (Bin max maxV l r) | p (boundUKey max) maxV = let tl :*: fl = goFalseL l tr :*: fr = goTrueR r - t = case tl of - Empty -> r2lMap $ NonEmpty max maxV tr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max maxV l' tr) - f = case fr of - Empty -> fl - NonEmpty max' maxV' r' -> Bin max' maxV' fl r' - in t :*: f + in binL tl (NonEmpty max maxV tr) :*: binNodeMapL fl fr | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binL tl tr :*: Bin max maxV fl fr @@ -2218,13 +2154,7 @@ partitionWithUKey p = start | p (boundUKey min) minV = let tl :*: fl = goTrueL l tr :*: fr = goFalseR r - t = case tr of - Empty -> l2rMap $ NonEmpty min minV tl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min minV tl r') - f = case fl of - Empty -> fr - NonEmpty min' minV' l' -> Bin min' minV' l' fr - in t :*: f + in binR (NonEmpty min minV tl) tr :*: binMapNodeR fl fr | otherwise = let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binR tl tr :*: Bin min minV fl fr @@ -2649,6 +2579,16 @@ binR Empty r = r binR l Empty = l2rMap l binR (NonEmpty min minV l) (NonEmpty max maxV r) = NonEmpty max maxV (Bin min minV l r) +{-# INLINE binNodeMapL #-} +binNodeMapL :: Node L v -> IntMap_ R v -> Node L v +binNodeMapL l Empty = l +binNodeMapL l (NonEmpty max maxV r) = Bin max maxV l r + +{-# INLINE binMapNodeR #-} +binMapNodeR :: IntMap_ L v -> Node R v -> Node R v +binMapNodeR Empty r = r +binMapNodeR (NonEmpty min minV l) r = Bin min minV l r + {-# INLINE minToMax #-} minToMax :: Bound L -> Bound R minToMax = Bound . boundKey diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index b4d357f66..117781a28 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -1017,7 +1017,7 @@ intersectionWithUKey = start where xorCacheMin = xor k min -- | /O(n+m)/. An unsafe general combining function. --- +-- -- WARNING: This function can produce corrupt maps and its results -- may depend on the internal structures of its inputs. Users should -- prefer 'merge' or 'mergeA'. This function is also significantly slower @@ -1318,33 +1318,21 @@ mapMaybeWithUKey = start goL _ Tip = Tip goL f (Bin max maxV l r) = case f (boundUKey max) maxV of Just maxV' -> Bin max maxV' (goL f l) (goR f r) - Nothing -> case goDeleteR f r of - Empty -> goL f l - NonEmpty max' maxV' r' -> Bin max' maxV' (goL f l) r' + Nothing -> binNodeMapL (goL f l) (goDeleteR f r) goR _ Tip = Tip goR f (Bin min minV l r) = case f (boundUKey min) minV of Just minV' -> Bin min minV' (goL f l) (goR f r) - Nothing -> case goDeleteL f l of - Empty -> goR f r - NonEmpty min' minV' l' -> Bin min' minV' l' (goR f r) + Nothing -> binMapNodeR (goDeleteL f l) (goR f r) goDeleteL _ Tip = Empty goDeleteL f (Bin max maxV l r) = case f (boundUKey max) maxV of - Just maxV' -> case goDeleteL f l of - Empty -> case goR f r of - Tip -> NonEmpty (maxToMin max) maxV' Tip - Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) - NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR f r)) + Just maxV' -> binL (goDeleteL f l) (NonEmpty max maxV' (goR f r)) Nothing -> binL (goDeleteL f l) (goDeleteR f r) goDeleteR _ Tip = Empty goDeleteR f (Bin min minV l r) = case f (boundUKey min) minV of - Just minV' -> case goDeleteR f r of - Empty -> case goL f l of - Tip -> NonEmpty (minToMax min) minV' Tip - Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) - NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL f l) r') + Just minV' -> binR (NonEmpty min minV' (goL f l)) (goDeleteR f r) Nothing -> binR (goDeleteL f l) (goDeleteR f r) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. @@ -1390,13 +1378,7 @@ mapEitherWithUKey func = start in Bin max v tl tr :*: binL fl fr Right v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r - t = case tr of - Empty -> tl - NonEmpty max' maxV' r' -> Bin max' maxV' tl r' - f = case fl of - Empty -> r2lMap $ NonEmpty max v fr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' fr) - in t :*: f + in binNodeMapL tl tr :*: binL fl (NonEmpty max v fr) goTrueR Tip = Tip :*: Empty goTrueR (Bin min minV l r) = case func (boundUKey min) minV of @@ -1405,25 +1387,13 @@ mapEitherWithUKey func = start in Bin min v tl tr :*: binR fl fr Right v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r - t = case tl of - Empty -> tr - NonEmpty min' minV' l' -> Bin min' minV' l' tr - f = case fr of - Empty -> l2rMap $ NonEmpty min v fl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v fl r') - in t :*: f + in binMapNodeR tl tr :*: binR (NonEmpty min v fl) fr goFalseL Tip = Empty :*: Tip goFalseL (Bin max maxV l r) = case func (boundUKey max) maxV of Left v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r - t = case tl of - Empty -> r2lMap $ NonEmpty max v tr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' tr) - f = case fr of - Empty -> fl - NonEmpty max' maxV' r' -> Bin max' maxV' fl r' - in t :*: f + in binL tl (NonEmpty max v tr) :*: binNodeMapL fl fr Right v -> let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binL tl tr :*: Bin max v fl fr @@ -1432,13 +1402,7 @@ mapEitherWithUKey func = start goFalseR (Bin min minV l r) = case func (boundUKey min) minV of Left v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r - t = case tr of - Empty -> l2rMap $ NonEmpty min v tl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v tl r') - f = case fl of - Empty -> fr - NonEmpty min' minV' l' -> Bin min' minV' l' fr - in t :*: f + in binR (NonEmpty min v tl) tr :*: binMapNodeR fl fr Right v -> let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binR tl tr :*: Bin min v fl fr diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index c9c13d588..a9aedec36 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -360,33 +360,21 @@ filterMissingUKey p = WhenMissing (\k v -> pure (if p k v then Just v else Nothi goLKeep Tip = Tip goLKeep (Bin max maxV l r) | p (boundUKey max) maxV = Bin max maxV (goLKeep l) (goRKeep r) - | otherwise = case goR r of - Empty -> goLKeep l - NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' + | otherwise = binNodeMapL (goLKeep l) (goR r) goRKeep Tip = Tip goRKeep (Bin min minV l r) | p (boundUKey min) minV = Bin min minV (goLKeep l) (goRKeep r) - | otherwise = case goL l of - Empty -> goRKeep r - NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) + | otherwise = binMapNodeR (goL l) (goRKeep r) goL Tip = Empty goL (Bin max maxV l r) - | p (boundUKey max) maxV = case goL l of - Empty -> case goRKeep r of - Tip -> NonEmpty (maxToMin max) maxV Tip - Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) - NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV l' (goRKeep r)) + | p (boundUKey max) maxV = binL (goL l) (NonEmpty max maxV (goRKeep r)) | otherwise = binL (goL l) (goR r) goR Tip = Empty goR (Bin min minV l r) - | p (boundUKey min) minV = case goR r of - Empty -> case goLKeep l of - Tip -> NonEmpty (minToMax min) minV Tip - Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) - NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV (goLKeep l) r') + | p (boundUKey min) minV = binR (NonEmpty min minV (goLKeep l)) (goR r) | otherwise = binR (goL l) (goR r) -- | Filter the entries whose keys are missing from the other map @@ -735,14 +723,6 @@ mapToNodeR :: Bound R -> IntMap_ R v -> Node R v mapToNodeR !_ Empty = Tip mapToNodeR !externalMax (NonEmpty max maxV root) = insertMaxR (xor (boundKey max) externalMax) max maxV root -binNodeMapL :: Node L v -> IntMap_ R v -> Node L v -binNodeMapL l Empty = l -binNodeMapL l (NonEmpty max maxV r) = Bin max maxV l r - -binMapNodeR :: IntMap_ L v -> Node R v -> Node R v -binMapNodeR Empty r = r -binMapNodeR (NonEmpty min minV l) r = Bin min minV l r - {-# INLINE addMaxL #-} addMaxL :: Applicative f => Bound L -> Bound R -> f (Maybe v) -> f (Node L v) -> f (Node L v) addMaxL !min !k v n = liftA2 add n v where diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 38338025c..6a320ee8c 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1374,33 +1374,21 @@ mapMaybeWithUKey f = start goL Tip = Tip goL (Bin max maxV l r) = case f (boundUKey max) maxV of Just !maxV' -> Bin max maxV' (goL l) (goR r) - Nothing -> case goDeleteR r of - Empty -> goL l - NonEmpty max' maxV' r' -> Bin max' maxV' (goL l) r' + Nothing -> binNodeMapL (goL l) (goDeleteR r) goR Tip = Tip goR (Bin min minV l r) = case f (boundUKey min) minV of Just !minV' -> Bin min minV' (goL l) (goR r) - Nothing -> case goDeleteL l of - Empty -> goR r - NonEmpty min' minV' l' -> Bin min' minV' l' (goR r) + Nothing -> binMapNodeR (goDeleteL l) (goR r) goDeleteL Tip = Empty goDeleteL (Bin max maxV l r) = case f (boundUKey max) maxV of - Just !maxV' -> case goDeleteL l of - Empty -> case goR r of - Tip -> NonEmpty (maxToMin max) maxV' Tip - Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) - NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goR r)) + Just !maxV' -> binL (goDeleteL l) (NonEmpty max maxV' (goR r)) Nothing -> binL (goDeleteL l) (goDeleteR r) goDeleteR Tip = Empty goDeleteR (Bin min minV l r) = case f (boundUKey min) minV of - Just !minV' -> case goDeleteR r of - Empty -> case goL l of - Tip -> NonEmpty (minToMax min) minV' Tip - Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) - NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goL l) r') + Just !minV' -> binR (NonEmpty min minV' (goL l)) (goDeleteR r) Nothing -> binR (goDeleteL l) (goDeleteR r) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. @@ -1446,13 +1434,7 @@ mapEitherWithUKey func = start in Bin max v tl tr :*: binL fl fr Right !v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r - t = case tr of - Empty -> tl - NonEmpty max' maxV' r' -> Bin max' maxV' tl r' - f = case fl of - Empty -> r2lMap $ NonEmpty max v fr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' fr) - in t :*: f + in binNodeMapL tl tr :*: binL fl (NonEmpty max v fr) goTrueR Tip = Tip :*: Empty goTrueR (Bin min minV l r) = case func (boundUKey min) minV of @@ -1461,25 +1443,13 @@ mapEitherWithUKey func = start in Bin min v tl tr :*: binR fl fr Right !v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r - t = case tl of - Empty -> tr - NonEmpty min' minV' l' -> Bin min' minV' l' tr - f = case fr of - Empty -> l2rMap $ NonEmpty min v fl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v fl r') - in t :*: f + in binMapNodeR tl tr :*: binR (NonEmpty min v fl) fr goFalseL Tip = Empty :*: Tip goFalseL (Bin max maxV l r) = case func (boundUKey max) maxV of Left !v -> let tl :*: fl = goFalseL l tr :*: fr = goTrueR r - t = case tl of - Empty -> r2lMap $ NonEmpty max v tr - NonEmpty min' minV' l' -> NonEmpty min' minV' (Bin max v l' tr) - f = case fr of - Empty -> fl - NonEmpty max' maxV' r' -> Bin max' maxV' fl r' - in t :*: f + in binL tl (NonEmpty max v tr) :*: binNodeMapL fl fr Right !v -> let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binL tl tr :*: Bin max v fl fr @@ -1488,13 +1458,7 @@ mapEitherWithUKey func = start goFalseR (Bin min minV l r) = case func (boundUKey min) minV of Left !v -> let tl :*: fl = goTrueL l tr :*: fr = goFalseR r - t = case tr of - Empty -> l2rMap $ NonEmpty min v tl - NonEmpty max' maxV' r' -> NonEmpty max' maxV' (Bin min v tl r') - f = case fl of - Empty -> fr - NonEmpty min' minV' l' -> Bin min' minV' l' fr - in t :*: f + in binR (NonEmpty min v tl) tr :*: binMapNodeR fl fr Right !v -> let tl :*: fl = goFalseL l tr :*: fr = goFalseR r in binR tl tr :*: Bin min v fl fr From 4058ee8eaaf06e0779096a3e649f1a8791330db5 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 22 Jan 2020 21:52:47 -0600 Subject: [PATCH 128/147] Small modifications (@since in docs, a missing doc example, and more generic unions{,With}) to better match the existing Data.IntMap --- containers/src/Data/IntMap.hs | 1 - containers/src/Data/IntMap/Internal.hs | 12 ++++++++-- containers/src/Data/IntMap/Lazy.hs | 24 ++++++++++++++------ containers/src/Data/IntMap/Merge/Internal.hs | 19 ++++++++++++++-- containers/src/Data/IntMap/Merge/Lazy.hs | 11 ++++++++- containers/src/Data/IntMap/Strict.hs | 16 ++++++++++--- 6 files changed, 67 insertions(+), 16 deletions(-) diff --git a/containers/src/Data/IntMap.hs b/containers/src/Data/IntMap.hs index 495b0a2d0..8e59e0f6e 100644 --- a/containers/src/Data/IntMap.hs +++ b/containers/src/Data/IntMap.hs @@ -74,7 +74,6 @@ insertWithKey' :: Whoops "Data.IntMap.insertWithKey' is gone. Use Data.IntMap.St => (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWithKey' _ _ _ _ = undefined - -- | This function is being removed and is no longer usable. -- Use 'Data.IntMap.Lazy.foldr'. fold :: Whoops "Data.IntMap.fold' is gone. Use Data.IntMap.foldr or Prelude.foldr." diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index d6e7338b6..563a7cce6 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -795,6 +795,7 @@ instance Read a => Read (IntMap a) where #endif #if MIN_VERSION_base(4,9,0) +-- | @since 0.5.9 instance Read1 IntMap where #if defined(__GLASGOW_HASKELL__) && MIN_VERSION_base(4,10,0) liftReadPrec innerOne innerList = readData (readUnaryWith listOne "fromList" fromListLazy) @@ -835,6 +836,7 @@ instance Functor (Node t) where a <$ Bin k _ l r = Bin k a (a <$ l) (a <$ r) #endif +-- | Folds in order of increasing key. instance Data.Foldable.Foldable IntMap where {-# INLINE foldMap #-} foldMap f = start @@ -875,6 +877,7 @@ instance Data.Foldable.Foldable IntMap where go v (Bin _ boundV l r) = v == boundV || go v l || go v r #endif +-- | Traverses in order of increasing key. instance Traversable IntMap where {-# INLINE traverse #-} traverse f = start @@ -890,6 +893,7 @@ instance Traversable IntMap where #if MIN_VERSION_base(4,9,0) +-- | @since 0.5.7 instance Semigroup (IntMap a) where (<>) = union stimes = stimesIdempotentMonoid @@ -1285,6 +1289,10 @@ mapNodeLazy f (Bin bound value l r) = Bin bound (f value) (mapNodeLazy f l) (map -- | /O(min(n,W))/. Delete a key and its value from the map. -- When the key is not a member of the map, the original map is returned. +-- +-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" +-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] +-- > delete 5 empty == empty delete :: Key -> IntMap a -> IntMap a delete !_ (IntMap Empty) = IntMap Empty delete !k m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of @@ -1471,8 +1479,8 @@ unionDisjointR maxV1 !max1 (Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2 -- > == fromList [(3, "b"), (5, "a"), (7, "C")] -- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] -- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] -unions :: [IntMap a] -> IntMap a -unions = Data.List.foldl' union empty +unions :: Foldable f => f (IntMap a) -> IntMap a +unions = Data.Foldable.foldl' union empty -- | /O(n+m)/. Difference between two maps (based on keys). -- diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 117781a28..77831d24e 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -218,10 +218,19 @@ module Data.IntMap.Lazy ( , maxView , minViewWithKey , maxViewWithKey + +#if defined(__GLASGOW_HASKELL__) + -- * Debugging + , showTree + , showTreeWith +#endif ) where import Data.IntMap.Internal import qualified Data.IntMap.Merge.Lazy as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) +#if defined(__GLASGOW_HASKELL__) +import Data.IntMap.Internal.DeprecatedDebug +#endif #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..), (<$>)) @@ -230,6 +239,7 @@ import Control.Applicative (liftA2, liftA3) import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) +import qualified Data.Foldable (foldl') import qualified Data.List (foldl', map) import qualified Data.IntSet (IntSet, toList) @@ -477,7 +487,7 @@ alter f k m = case lookup k m of -- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, --- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f +-- or update a value in an 'IntMap'. In short : @'lookup' k '<$>' 'alterF' f k m = f -- ('lookup' k m)@. -- -- Example: @@ -655,8 +665,8 @@ unionWithUKey = start -- -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] -unionsWith :: (a -> a -> a) -> [IntMap a] -> IntMap a -unionsWith f = Data.List.foldl' (unionWith f) empty +unionsWith :: Foldable f => (a -> a -> a) -> f (IntMap a) -> IntMap a +unionsWith f = Data.Foldable.foldl' (unionWith f) empty -- | /O(n+m)/. Difference with a combining function. -- @@ -1018,10 +1028,10 @@ intersectionWithUKey = start -- | /O(n+m)/. An unsafe general combining function. -- --- WARNING: This function can produce corrupt maps and its results --- may depend on the internal structures of its inputs. Users should --- prefer 'merge' or 'mergeA'. This function is also significantly slower --- than 'merge'. +-- WARNING: This function can produce corrupt maps and its results may depend +-- on the internal structures of its inputs. Users should prefer +-- 'Data.IntMap.Merge.Lazy.merge' or 'Data.IntMap.Merge.Lazy.mergeA'. This +-- function is also significantly slower than 'Data.IntMap.Merge.Lazy.merge'. -- -- When 'mergeWithKey' is given three arguments, it is inlined to the call -- site. You should therefore use 'mergeWithKey' only to define custom diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index a9aedec36..0dcd86c87 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -269,6 +269,8 @@ instance Applicative Identity where -- -- A tactic of type @ WhenMissing f a c @ is an abstract representation -- of a function of type @ Key -> a -> f (Maybe c) @. +-- +-- @since 0.5.9 data WhenMissing f a b = WhenMissing { -- TODO: Instead of unconditionally putting the 'Maybe' inside the @f@, -- provide options for the deletion vs. not choice to be decided purely, @@ -289,6 +291,8 @@ data WhenMissing f a b = WhenMissing { -- -- A tactic of type @ SimpleWhenMissing a c @ is an abstract representation -- of a function of type @ Key -> a -> Maybe c @. +-- +-- @since 0.5.9 type SimpleWhenMissing = WhenMissing Identity -- | Along with 'traverseMaybeMissing', witnesses the isomorphism @@ -316,6 +320,8 @@ runWhenMissingAll miss (IntMap m) = IntMap <$> missingAllL miss m -- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing) -- -- but @dropMissing@ is much faster. +-- +-- @since 0.5.9 {-# INLINE dropMissing #-} dropMissing :: Applicative f => WhenMissing f a b dropMissing = WhenMissing (\_ _ -> pure Nothing) (const (pure Tip)) (const (pure Tip)) (const (pure Empty)) @@ -330,6 +336,8 @@ dropMissing = WhenMissing (\_ _ -> pure Nothing) (const (pure Tip)) (const (pure -- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x) -- -- but @preserveMissing@ is much faster. +-- +-- @since 0.5.9 {-# INLINE preserveMissing #-} preserveMissing :: Applicative f => WhenMissing f a a preserveMissing = WhenMissing (\_ v -> pure (Just v)) pure pure pure @@ -343,6 +351,8 @@ preserveMissing = WhenMissing (\_ v -> pure (Just v)) pure pure pure -- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x -- -- but this should be a little faster. +-- +-- @since 0.5.9 {-# INLINE filterMissing #-} filterMissing :: Applicative f => (Key -> a -> Bool) -> WhenMissing f a a filterMissing p = filterMissingUKey (\k a -> p (box k) a) @@ -415,6 +425,8 @@ filterAMissingUKey f = WhenMissing -- -- A tactic of type @ WhenMatched f a b c @ is an abstract representation -- of a function of type @ Key -> a -> b -> f (Maybe c) @. +-- +-- @since 0.5.9 newtype WhenMatched f a b c = WhenMatched { matchedSingle :: UKey -> a -> b -> f (Maybe c) } @@ -423,6 +435,8 @@ newtype WhenMatched f a b c = WhenMatched { -- -- A tactic of type @ SimpleWhenMatched a b c @ is an abstract representation -- of a function of type @ Key -> a -> b -> Maybe c @. +-- +-- @since 0.5.9 type SimpleWhenMatched = WhenMatched Identity -- | Along with 'zipWithMaybeAMatched', witnesses the isomorphism @@ -501,6 +515,8 @@ runWhenMatched match k = matchedSingle match (unbox k) -- prop> differenceWith f = merge preserveMissing dropMissing f -- prop> symmetricDifference = merge preserveMissing preserveMissing (zipWithMaybeMatched (\_ _ _ -> Nothing)) -- prop> mapEachPiece f g h = merge (mapMissing f) (mapMissing g) (zipWithMatched h) +-- +-- @since 0.5.9 {-# INLINE merge #-} -- TODO: Implementing 'merge' in terms of 'mergeA' leaves a lot to be desired -- on the performance front. Because the choice of whether to delete a key is @@ -514,8 +530,7 @@ runWhenMatched match k = matchedSingle match (unbox k) merge :: SimpleWhenMissing a c -> SimpleWhenMissing b c -> SimpleWhenMatched a b c -> IntMap a -> IntMap b -> IntMap c merge miss1 miss2 match = \m1 m2 -> runIdentity (mergeA miss1 miss2 match m1 m2) --- | An applicative version of 'merge'. Due to the necessity of performing actions --- in order, this can be significantly slower than 'merge'. +-- | An applicative version of 'merge'. -- -- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched' -- tactic and two maps. It uses the tactics to merge the maps. diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 32fda6925..6a0a60e1c 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -30,7 +30,8 @@ -- tactics are included because they are valid. However, they are -- inefficient in many cases and should usually be avoided. The instances -- for 'WhenMatched' tactics should not pose any major efficiency problems. - +-- +-- @since 0.5.9 module Data.IntMap.Merge.Lazy ( -- ** Simple merge tactic types SimpleWhenMissing @@ -96,6 +97,8 @@ import Data.IntMap.Merge.Internal -- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) -- -- but @mapMissing@ is somewhat faster. +-- +-- @since 0.5.9 {-# INLINE mapMissing #-} mapMissing :: Applicative f => (Key -> a -> b) -> WhenMissing f a b mapMissing f = mapMissingUKey (\k v -> f (box k) v) @@ -125,6 +128,8 @@ mapMissingUKey f = WhenMissing (\k v -> pure (Just (f k v))) (pure . goL) (pure -- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x)) -- -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. +-- +-- @since 0.5.9 {-# INLINE mapMaybeMissing #-} mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b mapMaybeMissing f = mapMaybeMissingUKey (\k a -> f (box k) a) @@ -178,6 +183,8 @@ mapMaybeMissingUKey f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pur -- zipWithMaybeMatched :: (Key -> a -> b -> Maybe c) -- -> SimpleWhenMatched a b c -- @ +-- +-- @since 0.5.9 {-# INLINE zipWithMaybeMatched #-} zipWithMaybeMatched :: Applicative f => (Key -> a -> b -> Maybe c) -> WhenMatched f a b c zipWithMaybeMatched f = WhenMatched (\k a b -> pure (f (box k) a b)) @@ -189,6 +196,8 @@ zipWithMaybeMatched f = WhenMatched (\k a b -> pure (f (box k) a b)) -- zipWithMatched :: (Key -> a -> b -> c) -- -> SimpleWhenMatched a b c -- @ +-- +-- @since 0.5.9 {-# INLINE zipWithMatched #-} zipWithMatched :: Applicative f => (Key -> a -> b -> c) -> WhenMatched f a b c zipWithMatched f = zipWithMaybeMatched (\k a b -> Just (f k a b)) diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 6a320ee8c..d474a8d72 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -238,6 +238,12 @@ module Data.IntMap.Strict ( , maxView , minViewWithKey , maxViewWithKey + +#if defined(__GLASGOW_HASKELL__) + -- * Debugging + , showTree + , showTreeWith +#endif ) where import Data.IntMap.Internal @@ -245,6 +251,9 @@ import Data.IntMap.Internal import qualified Data.IntMap.Lazy as L #endif import qualified Data.IntMap.Merge.Strict as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) +#if defined(__GLASGOW_HASKELL__) +import Data.IntMap.Internal.DeprecatedDebug +#endif #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..), (<$>)) @@ -253,6 +262,7 @@ import Control.Applicative (liftA2, liftA3) import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) +import qualified Data.Foldable (foldl') import qualified Data.List (foldl', map) import qualified Data.IntSet (IntSet, toList) @@ -504,7 +514,7 @@ alter f k m = case lookup k m of -- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, --- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f +-- or update a value in an 'IntMap'. In short : @'lookup' k '<$>' 'alterF' f k m = f -- ('lookup' k m)@. -- -- Example: @@ -682,8 +692,8 @@ unionWithUKey = start -- -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] -unionsWith :: (a -> a -> a) -> [IntMap a] -> IntMap a -unionsWith f = Data.List.foldl' (unionWith f) empty +unionsWith :: Foldable f => (a -> a -> a) -> f (IntMap a) -> IntMap a +unionsWith f = Data.Foldable.foldl' (unionWith f) empty -- | /O(n+m)/. Difference with a combining function. -- From 76d9947626299cce0d1851ba6d491ee4aa851d5b Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 22 Jan 2020 23:12:32 -0600 Subject: [PATCH 129/147] Implement the appropriate type classes for IntMap merge tactics --- containers/src/Data/IntMap/Merge/Internal.hs | 124 +++++++++++++++++++ containers/src/Data/IntMap/Merge/Lazy.hs | 21 +--- containers/src/Data/IntMap/Merge/Strict.hs | 4 +- 3 files changed, 129 insertions(+), 20 deletions(-) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index 0dcd86c87..d387030e7 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -229,6 +229,7 @@ module Data.IntMap.Merge.Internal ( , preserveMissing , filterMissing , filterAMissing + , traverseMaybeMissingUKeyLazy ) where import Prelude hiding (min, max) @@ -236,6 +237,8 @@ import Prelude hiding (min, max) import Data.IntMap.Internal import Control.Applicative (liftA2, liftA3) +import Control.Monad ((<=<)) +import qualified Control.Category as Category (Category(..)) #if MIN_VERSION_base (4,8,0) import Data.Functor.Identity (Identity, runIdentity) #else @@ -286,6 +289,81 @@ data WhenMissing f a b = WhenMissing { missingAllL :: IntMap_ L a -> f (IntMap_ L b) } +-- | @since 0.5.9 +instance (Applicative f, Monad f) => Category.Category (WhenMissing f) where + {-# INLINE id #-} + id = preserveMissing + + {-# INLINE (.) #-} + missF . missG = WhenMissing + (\k a -> do + mb <- missingSingle missG k a + case mb of + Nothing -> return Nothing + Just b -> missingSingle missF k b) + (missingLeft missF <=< missingLeft missG) + (missingRight missF <=< missingRight missG) + (missingAllL missF <=< missingAllL missG) + +-- | @since 0.5.9 +instance (Applicative f, Monad f) => Functor (WhenMissing f a) where + {-# INLINE fmap #-} + fmap f miss = WhenMissing + (\k a -> fmap f <$> missingSingle miss k a) + (\l -> fmap f <$> missingLeft miss l) + (\r -> fmap f <$> missingRight miss r) + (\m -> fmap f <$> missingAllL miss m) + +-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@ +-- +-- @since 0.5.9 +instance (Applicative f, Monad f) => Applicative (WhenMissing f a) where + {-# INLINE pure #-} + pure x = WhenMissing + (\_ _ -> pure (Just x)) + (\l -> pure (x <$ l)) + (\r -> pure (x <$ r)) + (\m -> pure (x <$ m)) + + {-# INLINE (<*>) #-} + missF <*> missX = traverseMaybeMissingUKeyLazy $ \k a -> + liftA2 (<*>) (missingSingle missF k a) (missingSingle missX k a) + +-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@ +-- +-- @since 0.5.9 +instance (Applicative f, Monad f) => Monad (WhenMissing f a) where +#if !MIN_VERSION_base(4,8,0) + {-# INLINE return #-} + return = pure +#endif + + {-# INLINE (>>=) #-} + missM >>= f = traverseMaybeMissingUKeyLazy $ \k a -> do + mb <- missingSingle missM k a + case mb of + Nothing -> return Nothing + Just b -> missingSingle (f b) k a + +-- | The inverse of 'missingSingle'. Is in the @Internal@ module for type class +-- instances. +{-# INLINE traverseMaybeMissingUKeyLazy #-} +traverseMaybeMissingUKeyLazy :: Applicative f => (UKey -> a -> f (Maybe b)) -> WhenMissing f a b +traverseMaybeMissingUKeyLazy f = WhenMissing + { missingAllL = start + , missingLeft = goL + , missingRight = goR + , missingSingle = f } + where + start Empty = pure Empty + start (NonEmpty min minV root) = liftA2 (maybe nodeToMapL (NonEmpty min)) (f (boundUKey min) minV) (goL root) + + goL Tip = pure Tip + goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> maybe extractBinL (Bin max) maxV' l' r') (goL l) (goR r) (f (boundUKey max) maxV) + + goR Tip = pure Tip + goR (Bin min minV l r) = liftA3 (\minV' l' r' -> maybe extractBinR (Bin min) minV' l' r') (f (boundUKey min) minV) (goL l) (goR r) + -- | A tactic for dealing with keys present in one map but not the other in -- 'merge'. -- @@ -431,6 +509,52 @@ newtype WhenMatched f a b c = WhenMatched { matchedSingle :: UKey -> a -> b -> f (Maybe c) } +-- | @since 0.5.9 +instance (Applicative f, Monad f) => Category.Category (WhenMatched f a) where + -- TODO: Expose this and it symmetric pair as @firstMatched@ and + -- @secondMatched@? + {-# INLINE id #-} + id = WhenMatched (\_ _ b -> pure (Just b)) + + {-# INLINE (.) #-} + matchF . matchG = WhenMatched $ \k a b -> do + mc <- matchedSingle matchG k a b + case mc of + Nothing -> return Nothing + Just c' -> matchedSingle matchF k a c' + +-- | @since 0.5.9 +instance Functor f => Functor (WhenMatched f a b) where + {-# INLINE fmap #-} + fmap f match = WhenMatched (\k a b -> fmap f <$> matchedSingle match k a b) + +-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@ +-- +-- @since 0.5.9 +instance (Applicative f, Monad f) => Applicative (WhenMatched f a b) where + {-# INLINE pure #-} + pure x = WhenMatched (\_ _ _ -> pure (Just x)) + + {-# INLINE (<*>) #-} + matchF <*> matchX = WhenMatched $ \k a b -> + liftA2 (<*>) (matchedSingle matchF k a b) (matchedSingle matchX k a b) + +-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@ +-- +-- @since 0.5.9 +instance (Applicative f, Monad f) => Monad (WhenMatched f a b) where +#if !MIN_VERSION_base(4,8,0) + {-# INLINE return #-} + return = pure +#endif + + {-# INLINE (>>=) #-} + matchM >>= f = WhenMatched $ \k a b -> do + mc <- matchedSingle matchM k a b + case mc of + Nothing -> return Nothing + Just c -> matchedSingle (f c) k a b + -- | A tactic for dealing with keys present in both maps in 'merge'. -- -- A tactic of type @ SimpleWhenMatched a b c @ is an abstract representation diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 6a0a60e1c..05c58a19f 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -26,8 +26,8 @@ -- -- == Efficiency note -- --- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing' --- tactics are included because they are valid. However, they are +-- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for +-- 'WhenMissing' tactics are included because they are valid. However, they are -- inefficient in many cases and should usually be avoided. The instances -- for 'WhenMatched' tactics should not pose any major efficiency problems. -- @@ -236,22 +236,7 @@ zipWithAMatched f = zipWithMaybeAMatched (\k a b -> Just <$> f k a b) {-# INLINE traverseMaybeMissing #-} traverseMaybeMissing :: Applicative f => (Key -> a -> f (Maybe b)) -> WhenMissing f a b -traverseMaybeMissing f = WhenMissing - { missingAllL = start - , missingLeft = goL - , missingRight = goR - , missingSingle = f' } - where - f' k a = f (box k) a - - start Empty = pure Empty - start (NonEmpty min minV root) = liftA2 (maybe nodeToMapL (NonEmpty min)) (f' (boundUKey min) minV) (goL root) - - goL Tip = pure Tip - goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> maybe extractBinL (Bin max) maxV' l' r') (goL l) (goR r) (f' (boundUKey max) maxV) - - goR Tip = pure Tip - goR (Bin min minV l r) = liftA3 (\minV' l' r' -> maybe extractBinR (Bin min) minV' l' r') (f' (boundUKey min) minV) (goL l) (goR r) +traverseMaybeMissing f = traverseMaybeMissingUKeyLazy (\k a -> f (box k) a) -- | Traverse over the entries whose keys are missing from the other -- map. diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index be7aeee99..107c7961c 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -26,8 +26,8 @@ -- -- == Efficiency note -- --- The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing' --- tactics are included because they are valid. However, they are +-- The 'Control.Category.Category', 'Applicative', and 'Monad' instances for +-- 'WhenMissing' tactics are included because they are valid. However, they are -- inefficient in many cases and should usually be avoided. The instances -- for 'WhenMatched' tactics should not pose any major efficiency problems. From 57badfe096f6eeb6c4d62396242ec9bcfb88ba7f Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Wed, 22 Jan 2020 23:40:32 -0600 Subject: [PATCH 130/147] Use the explicitly imported reference to Foldable --- containers/src/Data/IntMap/Internal.hs | 2 +- containers/src/Data/IntMap/Lazy.hs | 4 ++-- containers/src/Data/IntMap/Strict.hs | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 563a7cce6..debaadd9f 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -1479,7 +1479,7 @@ unionDisjointR maxV1 !max1 (Bin min1 minV1 l1 r1) !max2 n2@(Bin min2 minV2 l2 r2 -- > == fromList [(3, "b"), (5, "a"), (7, "C")] -- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] -- > == fromList [(3, "B3"), (5, "A3"), (7, "C")] -unions :: Foldable f => f (IntMap a) -> IntMap a +unions :: Data.Foldable.Foldable f => f (IntMap a) -> IntMap a unions = Data.Foldable.foldl' union empty -- | /O(n+m)/. Difference between two maps (based on keys). diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 77831d24e..9e975fb50 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -239,7 +239,7 @@ import Control.Applicative (liftA2, liftA3) import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) -import qualified Data.Foldable (foldl') +import qualified Data.Foldable (Foldable, foldl') import qualified Data.List (foldl', map) import qualified Data.IntSet (IntSet, toList) @@ -665,7 +665,7 @@ unionWithUKey = start -- -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] -unionsWith :: Foldable f => (a -> a -> a) -> f (IntMap a) -> IntMap a +unionsWith :: Data.Foldable.Foldable f => (a -> a -> a) -> f (IntMap a) -> IntMap a unionsWith f = Data.Foldable.foldl' (unionWith f) empty -- | /O(n+m)/. Difference with a combining function. diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index d474a8d72..fc91092e2 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -262,7 +262,7 @@ import Control.Applicative (liftA2, liftA3) import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) -import qualified Data.Foldable (foldl') +import qualified Data.Foldable (Foldable, foldl') import qualified Data.List (foldl', map) import qualified Data.IntSet (IntSet, toList) @@ -692,7 +692,7 @@ unionWithUKey = start -- -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] -unionsWith :: Foldable f => (a -> a -> a) -> f (IntMap a) -> IntMap a +unionsWith :: Data.Foldable.Foldable f => (a -> a -> a) -> f (IntMap a) -> IntMap a unionsWith f = Data.Foldable.foldl' (unionWith f) empty -- | /O(n+m)/. Difference with a combining function. From 4e3987ea71897f061e9cc18f3878e5b44518a5af Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 00:01:00 -0600 Subject: [PATCH 131/147] Implement mapping functions over IntMap tactics --- containers/src/Data/IntMap/Internal.hs | 20 +++++++++ containers/src/Data/IntMap/Merge/Lazy.hs | 48 ++++++++++++++++++++++ containers/src/Data/IntMap/Merge/Strict.hs | 27 ++++++++++++ containers/src/Data/IntMap/Strict.hs | 11 +---- 4 files changed, 96 insertions(+), 10 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index debaadd9f..8232296ca 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -380,6 +380,8 @@ module Data.IntMap.Internal ( -- * Traversal -- ** Map , mapLazy + , mapStrict_ + , mapNodeStrict -- * Folds , foldr @@ -1268,14 +1270,32 @@ mapNodeLazy :: (a -> b) -> Node t a -> Node t b mapNodeLazy _ Tip = Tip mapNodeLazy f (Bin bound value l r) = Bin bound (f value) (mapNodeLazy f l) (mapNodeLazy f r) +-- These need to be here to avoid a circular dependency between +-- Data.IntMap.Strict and Data.IntMap.Merge.Strict. +mapStrict_ :: (a -> b) -> IntMap_ t a -> IntMap_ t b +mapStrict_ _ Empty = Empty +mapStrict_ f (NonEmpty min minV root) = let !minV' = f minV + in NonEmpty min minV' (mapNodeStrict f root) + +mapNodeStrict :: (a -> b) -> Node t a -> Node t b +mapNodeStrict _ Tip = Tip +mapNodeStrict f (Bin bound value l r) = let !value' = f value + in Bin bound value' (mapNodeStrict f l) (mapNodeStrict f r) + #if USE_REWRITE_RULES {-# NOINLINE[1] mapLazy #-} {-# NOINLINE[1] mapLazy_ #-} {-# NOINLINE[1] mapNodeLazy #-} +{-# NOINLINE[1] mapStrict_ #-} +{-# NOINLINE[1] mapNodeStrict #-} {-# RULES "map/map" forall f g m . mapLazy f (mapLazy g m) = mapLazy (f . g) m "map_/map_" forall f g m . mapLazy_ f (mapLazy_ g m) = mapLazy_ (f . g) m +"mapS_/mapS_" forall f g m . mapStrict_ f (mapStrict_ g m) = mapStrict_ (\v -> f $! g v) m +"mapS_/map_" forall f g m . mapStrict_ f (mapLazy_ g m) = mapStrict_ (f . g) m "mapNode/mapNode" forall f g n . mapNodeLazy f (mapNodeLazy g n) = mapNodeLazy (f . g) n +"mapNodeS/mapNodeS" forall f g n . mapNodeStrict f (mapNodeStrict g n) = mapNodeStrict (\v -> f $! g v) n +"mapNodeS/mapNode" forall f g n . mapNodeStrict f (mapNodeLazy g n) = mapNodeStrict (f . g) n #-} #if __GLASGOW_HASKELL >= 709 -- Safe coercions were introduced in 7.8, but did not play well with RULES yes. diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 05c58a19f..7cf4be8ad 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -73,6 +73,15 @@ module Data.IntMap.Merge.Lazy ( , traverseMissing , filterAMissing + -- ** Covariant maps for tactics + , mapWhenMissing + , mapWhenMatched + + -- ** Contravariant maps for tactics + , lmapWhenMissing + , contramapFirstWhenMatched + , contramapSecondWhenMatched + -- ** Miscellaneous functions on tactics , runWhenMatched , runWhenMissing @@ -261,3 +270,42 @@ traverseMissing f = WhenMissing goR Tip = pure Tip goR (Bin min minV l r) = liftA3 (\minV' l' r' -> Bin min minV' l' r') (f' (boundUKey min) minV) (goL l) (goR r) + +-- | Map covariantly over a @'WhenMissing' f x@. +-- +-- @since 0.5.9 +{-# INLINE mapWhenMissing #-} +mapWhenMissing :: (Applicative f, Monad f) => (a -> b) -> WhenMissing f x a -> WhenMissing f x b +mapWhenMissing = fmap + +-- | Map covariantly over a @'WhenMatched' f x y@. +-- +-- @since 0.5.9 +{-# INLINE mapWhenMatched #-} +mapWhenMatched :: Functor f => (a -> b) -> WhenMatched f x y a -> WhenMatched f x y b +mapWhenMatched = fmap + +-- | Map contravariantly over a @'WhenMissing' f _ x@. +-- +-- @since 0.5.9 +{-# INLINE lmapWhenMissing #-} +lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x +lmapWhenMissing f miss = WhenMissing + (\k b -> missingSingle miss k (f b)) + (\l -> missingLeft miss (fmap f l)) + (\r -> missingRight miss (fmap f r)) + (\m -> missingAllL miss (fmap f m)) + +-- | Map contravariantly over a @'WhenMatched' f _ y z@. +-- +-- @since 0.5.9 +{-# INLINE contramapFirstWhenMatched #-} +contramapFirstWhenMatched :: (b -> a) -> WhenMatched f a y z -> WhenMatched f b y z +contramapFirstWhenMatched f match = WhenMatched (\k b y -> matchedSingle match k (f b) y) + +-- | Map contravariantly over a @'WhenMatched' f x _ z@. +-- +-- @since 0.5.9 +{-# INLINE contramapSecondWhenMatched #-} +contramapSecondWhenMatched :: (b -> a) -> WhenMatched f x a z -> WhenMatched f x b z +contramapSecondWhenMatched f match = WhenMatched (\k x b -> matchedSingle match k x (f b)) diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 107c7961c..7520ed560 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -72,6 +72,10 @@ module Data.IntMap.Merge.Strict ( , traverseMissing , filterAMissing + -- ** Covariant maps for tactics + , mapWhenMissing + , mapWhenMatched + -- ** Miscellaneous functions on tactics , runWhenMatched , runWhenMissing @@ -91,6 +95,11 @@ import Data.IntMap.Merge.Internal (#!) = ($!) (#) = ($) +{-# INLINE fmapMaybe' #-} +fmapMaybe' :: (a -> b) -> Maybe a -> Maybe b +fmapMaybe' _ Nothing = Nothing +fmapMaybe' f (Just x) = Just $! f x + -- | Map over the entries whose keys are missing from the other map. -- -- @ @@ -277,3 +286,21 @@ traverseMissing f = WhenMissing goR Tip = pure Tip goR (Bin min minV l r) = liftA3 (\ !minV' l' r' -> Bin min minV' l' r') (f' (boundUKey min) minV) (goL l) (goR r) + +-- | Map covariantly over a @'WhenMissing' f x@. +-- +-- @since 0.5.9 +{-# INLINE mapWhenMissing #-} +mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f x a -> WhenMissing f x b +mapWhenMissing f miss = WhenMissing + (\k x -> fmap (fmapMaybe' f) (missingSingle miss k x)) + (\l -> fmap (mapNodeStrict f) (missingLeft miss l)) + (\r -> fmap (mapNodeStrict f) (missingRight miss r)) + (\m -> fmap (mapStrict_ f) (missingAllL miss m)) + +-- | Map covariantly over a @'WhenMatched' f x y@. +-- +-- @since 0.5.9 +{-# INLINE mapWhenMatched #-} +mapWhenMatched :: Functor f => (a -> b) -> WhenMatched f x y a -> WhenMatched f x y b +mapWhenMatched f match = WhenMatched (\k x y -> fmap (fmapMaybe' f) (matchedSingle match k x y)) diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index fc91092e2..6b80b9452 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -1096,16 +1096,7 @@ mergeWithKey matched miss1 miss2 = Merge.merge (Merge.mapMaybeMissing (single mi -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] map :: (a -> b) -> IntMap a -> IntMap b -map f = start - where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f minV # goL root) - - goL Tip = Tip - goL (Bin k v l r) = Bin k #! f v # goL l # goR r - - goR Tip = Tip - goR (Bin k v l r) = Bin k #! f v # goL l # goR r +map f (IntMap m) = IntMap (mapStrict_ f m) -- | /O(n)/. Map a function over all values in the map. -- From db805553deb892ca53e0f1c516deaadaf1c1f4dc Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 00:22:52 -0600 Subject: [PATCH 132/147] Import <$ where necessary --- containers/src/Data/IntMap/Merge/Internal.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/containers/src/Data/IntMap/Merge/Internal.hs b/containers/src/Data/IntMap/Merge/Internal.hs index d387030e7..f5c85f95f 100644 --- a/containers/src/Data/IntMap/Merge/Internal.hs +++ b/containers/src/Data/IntMap/Merge/Internal.hs @@ -242,6 +242,7 @@ import qualified Control.Category as Category (Category(..)) #if MIN_VERSION_base (4,8,0) import Data.Functor.Identity (Identity, runIdentity) #else +import Data.Functor ((<$)) import Control.Applicative (Applicative(..), (<$>)) #if __GLASGOW_HASKELL__ >= 708 From c00a1c81eef1ec68f43f9a61d5f578bbba716ef6 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 00:27:17 -0600 Subject: [PATCH 133/147] Fix isProperSubmapOfBy documentation to refer to the keys of the two maps matching, not the maps themselves --- containers/src/Data/IntMap/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 8232296ca..20d82cbf7 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -2374,7 +2374,7 @@ isProperSubmapOf = isProperSubmapOfBy (==) {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when -@m1@ and @m2@ are not equal, +@'keys' m1@ and @'keys' m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when applied to their respective values. For example, the following expressions are all 'True': From ffefb3e04183af0dc507b668ac7e7d392e5e4f9f Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 01:07:52 -0600 Subject: [PATCH 134/147] Test IntMap merge tactics --- containers-tests/tests/intmap-properties.hs | 33 ++++++++++++++++----- 1 file changed, 26 insertions(+), 7 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index b8b1a4fea..bd650c24d 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -223,15 +223,12 @@ main = defaultMain , testProperty "traverseMaybeWithKey identity" prop_traverseMaybeWithKey_identity , testProperty "traverseMaybeWithKey->mapMaybeWithKey" prop_traverseMaybeWithKey_degrade_to_mapMaybeWithKey , testProperty "traverseMaybeWithKey->traverseWithKey" prop_traverseMaybeWithKey_degrade_to_traverseWithKey + , testProperty "filterMissing==filterWithKey" prop_filterMissingEqFilterWithKey + , testProperty "filterAMissing->filterMissing" prop_filterAMissing_degrade_to_filterMissing + , testProperty "mapMissing==mapWithKey" prop_mapMissingEqMapWithKey + , testProperty "traverseMissing->mapMissing" prop_traverseMissing_degrade_to_mapMissing ] -apply2 :: Fun (a, b) c -> a -> b -> c -apply2 f a b = apply f (a, b) - -apply3 :: Fun (a, b, c) d -> a -> b -> c -> d -apply3 f a b c = apply f (a, b, c) - - {-------------------------------------------------------------------- Arbitrary, reasonably balanced trees --------------------------------------------------------------------} @@ -1812,3 +1809,25 @@ prop_traverseMaybeWithKey_degrade_to_traverseWithKey fun mp = -- so this also checks the order of traversing is the same. where f k v = (show k, applyFun2 fun k v) g k v = fmap Just $ f k v + +prop_filterMissingEqFilterWithKey :: Fun (Int, A) Bool -> IntMap A -> Property +prop_filterMissingEqFilterWithKey fun m = + runIdentity (runWhenMissingAll (filterMissing f) m) === filterWithKey f m + where f = applyFun2 fun + +prop_filterAMissing_degrade_to_filterMissing :: Fun (Int, A) Bool -> IntMap A -> Property +prop_filterAMissing_degrade_to_filterMissing fun m = + runWhenMissingAll (filterAMissing (\k a -> Identity (f k a))) m + === runWhenMissingAll (filterMissing f) m + where f = applyFun2 fun + +prop_mapMissingEqMapWithKey :: Fun (Int, A) Int -> IntMap A -> Property +prop_mapMissingEqMapWithKey fun m = + runIdentity (runWhenMissingAll (mapMissing f) m) === mapWithKey f m + where f = applyFun2 fun + +prop_traverseMissing_degrade_to_mapMissing :: Fun (Int, A) Int -> IntMap A -> Property +prop_traverseMissing_degrade_to_mapMissing fun m = + runWhenMissingAll (traverseMissing (\k a -> Identity (f k a))) m + === runWhenMissingAll (mapMissing f) m + where f = applyFun2 fun From afab90f8f50ba1c0f5166898902bae93b014f7c5 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 01:18:07 -0600 Subject: [PATCH 135/147] Implement sum and product in terms of strict folds on IntMap --- containers/src/Data/IntMap/Internal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 20d82cbf7..add17cfdc 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -877,6 +877,10 @@ instance Data.Foldable.Foldable IntMap where go :: Eq v => v -> Node t v -> Bool go _ Tip = False go v (Bin _ boundV l r) = v == boundV || go v l || go v r + {-# INLINABLE sum #-} + sum = foldl' (+) 0 + {-# INLINABLE product #-} + product = foldl' (*) 1 #endif -- | Traverses in order of increasing key. From 2e6388227144f5289006f2aa87a3820711e14c27 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 01:46:49 -0600 Subject: [PATCH 136/147] Unify implementations of merge tactics and top-level functions for IntMap --- containers/src/Data/IntMap/Lazy.hs | 64 +++------------------- containers/src/Data/IntMap/Merge/Lazy.hs | 34 ++++-------- containers/src/Data/IntMap/Merge/Strict.hs | 35 ++++-------- containers/src/Data/IntMap/Strict.hs | 64 +++------------------- 4 files changed, 38 insertions(+), 159 deletions(-) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 9e975fb50..2aad9dc2b 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -227,15 +227,18 @@ module Data.IntMap.Lazy ( ) where import Data.IntMap.Internal -import qualified Data.IntMap.Merge.Lazy as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) +import qualified Data.IntMap.Merge.Internal as Merge (runWhenMissingAll) +import qualified Data.IntMap.Merge.Lazy as Merge (merge, mapMissing, mapMaybeMissing, traverseMissing, zipWithMaybeMatched) #if defined(__GLASGOW_HASKELL__) import Data.IntMap.Internal.DeprecatedDebug #endif -#if !MIN_VERSION_base(4,8,0) +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity (runIdentity) +#else +Import Data.IntMap.Merge.Internal (runIdentity) import Control.Applicative (Applicative(..), (<$>)) #endif -import Control.Applicative (liftA2, liftA3) import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) @@ -1076,16 +1079,7 @@ map = mapLazy -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b -mapWithKey f = start - where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min (f (boundKey min) minV) (goL root)) - - goL Tip = Tip - goL (Bin k v l r) = Bin k (f (boundKey k) v) (goL l) (goR r) - - goR Tip = Tip - goR (Bin k v l r) = Bin k (f (boundKey k) v) (goL l) (goR r) +mapWithKey f = runIdentity . Merge.runWhenMissingAll (Merge.mapMissing f) #if USE_REWRITE_RULES {-# NOINLINE[1] mapWithKey #-} @@ -1105,16 +1099,7 @@ mapWithKey f = start -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing {-# INLINE traverseWithKey #-} traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) -traverseWithKey f = start - where - start (IntMap Empty) = pure (IntMap Empty) - start (IntMap (NonEmpty min minV root)) = liftA2 (\minV' root' -> IntMap (NonEmpty min minV' root')) (f (boundKey min) minV) (goL root) - - goL Tip = pure Tip - goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> Bin max maxV' l' r') (goL l) (goR r) (f (boundKey max) maxV) - - goR Tip = pure Tip - goR (Bin min minV l r) = liftA3 (Bin min) (f (boundKey min) minV) (goL l) (goR r) +traverseWithKey f = Merge.runWhenMissingAll (Merge.traverseMissing f) -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. @@ -1312,38 +1297,7 @@ mapMaybe f = mapMaybeWithKey (const f) -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" {-# INLINE mapMaybeWithKey #-} mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b -mapMaybeWithKey f = mapMaybeWithUKey (\k a -> f (box k) a) - --- | /O(n)/. Map keys\/values and collect the 'Just' results with a mapping --- function that takes unboxed keys. Identical in functionality to --- 'mapMaybeWithKey'. -mapMaybeWithUKey :: (UKey -> a -> Maybe b) -> IntMap a -> IntMap b -mapMaybeWithUKey = start - where - start _ (IntMap Empty) = IntMap Empty - start f (IntMap (NonEmpty min minV root)) = case f (boundUKey min) minV of - Just minV' -> IntMap (NonEmpty min minV' (goL f root)) - Nothing -> IntMap (goDeleteL f root) - - goL _ Tip = Tip - goL f (Bin max maxV l r) = case f (boundUKey max) maxV of - Just maxV' -> Bin max maxV' (goL f l) (goR f r) - Nothing -> binNodeMapL (goL f l) (goDeleteR f r) - - goR _ Tip = Tip - goR f (Bin min minV l r) = case f (boundUKey min) minV of - Just minV' -> Bin min minV' (goL f l) (goR f r) - Nothing -> binMapNodeR (goDeleteL f l) (goR f r) - - goDeleteL _ Tip = Empty - goDeleteL f (Bin max maxV l r) = case f (boundUKey max) maxV of - Just maxV' -> binL (goDeleteL f l) (NonEmpty max maxV' (goR f r)) - Nothing -> binL (goDeleteL f l) (goDeleteR f r) - - goDeleteR _ Tip = Empty - goDeleteR f (Bin min minV l r) = case f (boundUKey min) minV of - Just minV' -> binR (NonEmpty min minV' (goL f l)) (goDeleteR f r) - Nothing -> binR (goDeleteL f l) (goDeleteR f r) +mapMaybeWithKey f = runIdentity . Merge.runWhenMissingAll (Merge.mapMaybeMissing f) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -- diff --git a/containers/src/Data/IntMap/Merge/Lazy.hs b/containers/src/Data/IntMap/Merge/Lazy.hs index 7cf4be8ad..99dc88649 100644 --- a/containers/src/Data/IntMap/Merge/Lazy.hs +++ b/containers/src/Data/IntMap/Merge/Lazy.hs @@ -116,15 +116,13 @@ mapMissing f = mapMissingUKey (\k v -> f (box k) v) -- function that takes an unboxed key. Identical in functionality to -- 'mapMissing'. mapMissingUKey :: Applicative f => (UKey -> a -> b) -> WhenMissing f a b -mapMissingUKey f = WhenMissing (\k v -> pure (Just (f k v))) (pure . goL) (pure . goR) (pure . start) where - start Empty = Empty - start (NonEmpty min minV root) = NonEmpty min (f (boundUKey min) minV) (goL root) - - goL Tip = Tip - goL (Bin k v l r) = Bin k (f (boundUKey k) v) (goL l) (goR r) +mapMissingUKey g = WhenMissing (\k v -> pure (Just (g k v))) (pure . go g) (pure . go g) (pure . start g) where + start _ Empty = Empty + start f (NonEmpty min minV root) = NonEmpty min (f (boundUKey min) minV) (go f root) - goR Tip = Tip - goR (Bin k v l r) = Bin k (f (boundUKey k) v) (goL l) (goR r) + go :: (UKey -> a -> b) -> Node t a -> Node t b + go _ Tip = Tip + go f (Bin k v l r) = Bin k (f (boundUKey k) v) (go f l) (go f r) -- | Map over the entries whose keys are missing from the other map, -- optionally removing some. This is the most powerful 'SimpleWhenMissing' @@ -156,33 +154,21 @@ mapMaybeMissingUKey f = WhenMissing (\k v -> pure (f k v)) (pure . goLKeep) (pur goLKeep Tip = Tip goLKeep (Bin max maxV l r) = case f (boundUKey max) maxV of Just maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) - Nothing -> case goR r of - Empty -> goLKeep l - NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' + Nothing -> binNodeMapL (goLKeep l) (goR r) goRKeep Tip = Tip goRKeep (Bin min minV l r) = case f (boundUKey min) minV of Just minV' -> Bin min minV' (goLKeep l) (goRKeep r) - Nothing -> case goL l of - Empty -> goRKeep r - NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) + Nothing -> binMapNodeR (goL l) (goRKeep r) goL Tip = Empty goL (Bin max maxV l r) = case f (boundUKey max) maxV of - Just maxV' -> case goL l of - Empty -> case goRKeep r of - Tip -> NonEmpty (maxToMin max) maxV' Tip - Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) - NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goRKeep r)) + Just maxV' -> binL (goL l) (NonEmpty max maxV' (goRKeep r)) Nothing -> binL (goL l) (goR r) goR Tip = Empty goR (Bin min minV l r) = case f (boundUKey min) minV of - Just minV' -> case goR r of - Empty -> case goLKeep l of - Tip -> NonEmpty (minToMax min) minV' Tip - Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) - NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goLKeep l) r') + Just minV' -> binR (NonEmpty min minV' (goLKeep l)) (goR r) Nothing -> binR (goL l) (goR r) -- | When a key is found in both maps, apply a function to the diff --git a/containers/src/Data/IntMap/Merge/Strict.hs b/containers/src/Data/IntMap/Merge/Strict.hs index 7520ed560..211aaea2d 100644 --- a/containers/src/Data/IntMap/Merge/Strict.hs +++ b/containers/src/Data/IntMap/Merge/Strict.hs @@ -117,15 +117,13 @@ mapMissing f = mapMissingUKey (\k v -> f (box k) v) -- function that takes an unboxed key. Identical in functionality to -- 'mapMissing'. mapMissingUKey :: Applicative f => (UKey -> a -> b) -> WhenMissing f a b -mapMissingUKey f = WhenMissing (\k v -> pure (Just $! f k v)) (pure . goL) (pure . goR) (pure . start) where - start Empty = Empty - start (NonEmpty min minV root) = NonEmpty min #! f (boundUKey min) minV # goL root - - goL Tip = Tip - goL (Bin k v l r) = Bin k #! f (boundUKey k) v # goL l # goR r +mapMissingUKey g = WhenMissing (\k v -> pure (Just $! g k v)) (pure . go g) (pure . go g) (pure . start g) where + start _ Empty = Empty + start f (NonEmpty min minV root) = NonEmpty min #! f (boundUKey min) minV # go f root - goR Tip = Tip - goR (Bin k v l r) = Bin k #! f (boundUKey k) v # goL l # goR r + go :: (UKey -> a -> b) -> Node t a -> Node t b + go _ Tip = Tip + go f (Bin k v l r) = Bin k #! f (boundUKey k) v # go f l # go f r -- | Map over the entries whose keys are missing from the other map, -- optionally removing some. This is the most powerful 'SimpleWhenMissing' @@ -158,36 +156,23 @@ mapMaybeMissingUKey f = WhenMissing (\k v -> case f k v of goLKeep Tip = Tip goLKeep (Bin max maxV l r) = case f (boundUKey max) maxV of Just !maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) - Nothing -> case goR r of - Empty -> goLKeep l - NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' + Nothing -> binNodeMapL (goLKeep l) (goR r) goRKeep Tip = Tip goRKeep (Bin min minV l r) = case f (boundUKey min) minV of Just !minV' -> Bin min minV' (goLKeep l) (goRKeep r) - Nothing -> case goL l of - Empty -> goRKeep r - NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) + Nothing -> binMapNodeR (goL l) (goRKeep r) goL Tip = Empty goL (Bin max maxV l r) = case f (boundUKey max) maxV of - Just !maxV' -> case goL l of - Empty -> case goRKeep r of - Tip -> NonEmpty (maxToMin max) maxV' Tip - Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) - NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goRKeep r)) + Just !maxV' -> binL (goL l) (NonEmpty max maxV' (goRKeep r)) Nothing -> binL (goL l) (goR r) goR Tip = Empty goR (Bin min minV l r) = case f (boundUKey min) minV of - Just !minV' -> case goR r of - Empty -> case goLKeep l of - Tip -> NonEmpty (minToMax min) minV' Tip - Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) - NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goLKeep l) r') + Just !minV' -> binR (NonEmpty min minV' (goLKeep l)) (goR r) Nothing -> binR (goL l) (goR r) - -- | When a key is found in both maps, apply a function to the -- key and values and maybe use the result in the merged map. -- diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 6b80b9452..f9b9b906e 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -250,15 +250,18 @@ import Data.IntMap.Internal #if USE_REWRITE_RULES import qualified Data.IntMap.Lazy as L #endif -import qualified Data.IntMap.Merge.Strict as Merge (merge, mapMaybeMissing, zipWithMaybeMatched) +import qualified Data.IntMap.Merge.Internal as Merge (runWhenMissingAll) +import qualified Data.IntMap.Merge.Strict as Merge (merge, mapMissing, mapMaybeMissing, traverseMissing, zipWithMaybeMatched) #if defined(__GLASGOW_HASKELL__) import Data.IntMap.Internal.DeprecatedDebug #endif -#if !MIN_VERSION_base(4,8,0) +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity (runIdentity) +#else +import Data.IntMap.Merge.Internal (runIdentity) import Control.Applicative (Applicative(..), (<$>)) #endif -import Control.Applicative (liftA2, liftA3) import Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) @@ -1103,16 +1106,7 @@ map f (IntMap m) = IntMap (mapStrict_ f m) -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b -mapWithKey f = start - where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = IntMap (NonEmpty min #! f (boundKey min) minV # goL root) - - goL Tip = Tip - goL (Bin k v l r) = Bin k #! f (boundKey k) v # goL l # goR r - - goR Tip = Tip - goR (Bin k v l r) = Bin k #! f (boundKey k) v # goL l # goR r +mapWithKey f = runIdentity . Merge.runWhenMissingAll (Merge.mapMissing f) #if USE_REWRITE_RULES -- Pay close attention to strictness here. We need to force the @@ -1150,16 +1144,7 @@ mapWithKey f = start -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing {-# INLINE traverseWithKey #-} traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) -traverseWithKey f = start - where - start (IntMap Empty) = pure (IntMap Empty) - start (IntMap (NonEmpty min minV root)) = liftA2 (\minV' root' -> IntMap (NonEmpty min minV' root')) (f (boundKey min) minV) (goL root) - - goL Tip = pure Tip - goL (Bin max maxV l r) = liftA3 (\l' r' maxV' -> Bin max #! maxV' # l' # r') (goL l) (goR r) (f (boundKey max) maxV) - - goR Tip = pure Tip - goR (Bin min minV l r) = liftA3 (\minV' l' r' -> Bin min #! minV' # l' # r') (f (boundKey min) minV) (goL l) (goR r) +traverseWithKey f = Merge.runWhenMissingAll (Merge.traverseMissing f) -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. @@ -1359,38 +1344,7 @@ mapMaybe f = mapMaybeWithKey (const f) -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" {-# INLINE mapMaybeWithKey #-} mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b -mapMaybeWithKey f = mapMaybeWithUKey (\k a -> f (box k) a) - --- | /O(n)/. Map keys\/values and collect the 'Just' results with a mapping --- function that takes unboxed keys. Identical in functionality to --- 'mapMaybeWithKey'. -mapMaybeWithUKey :: (UKey -> a -> Maybe b) -> IntMap a -> IntMap b -mapMaybeWithUKey f = start - where - start (IntMap Empty) = IntMap Empty - start (IntMap (NonEmpty min minV root)) = case f (boundUKey min) minV of - Just !minV' -> IntMap (NonEmpty min minV' (goL root)) - Nothing -> IntMap (goDeleteL root) - - goL Tip = Tip - goL (Bin max maxV l r) = case f (boundUKey max) maxV of - Just !maxV' -> Bin max maxV' (goL l) (goR r) - Nothing -> binNodeMapL (goL l) (goDeleteR r) - - goR Tip = Tip - goR (Bin min minV l r) = case f (boundUKey min) minV of - Just !minV' -> Bin min minV' (goL l) (goR r) - Nothing -> binMapNodeR (goDeleteL l) (goR r) - - goDeleteL Tip = Empty - goDeleteL (Bin max maxV l r) = case f (boundUKey max) maxV of - Just !maxV' -> binL (goDeleteL l) (NonEmpty max maxV' (goR r)) - Nothing -> binL (goDeleteL l) (goDeleteR r) - - goDeleteR Tip = Empty - goDeleteR (Bin min minV l r) = case f (boundUKey min) minV of - Just !minV' -> binR (NonEmpty min minV' (goL l)) (goDeleteR r) - Nothing -> binR (goDeleteL l) (goDeleteR r) +mapMaybeWithKey f = runIdentity . Merge.runWhenMissingAll (Merge.mapMaybeMissing f) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -- From d0b04c9f1379b2b555e1f576e254542f6e699735 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 01:54:13 -0600 Subject: [PATCH 137/147] Use runIdentity in tests when comparing the results of Applicative functions --- containers-tests/tests/intmap-properties.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index bd650c24d..fbe3c3168 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -1817,8 +1817,8 @@ prop_filterMissingEqFilterWithKey fun m = prop_filterAMissing_degrade_to_filterMissing :: Fun (Int, A) Bool -> IntMap A -> Property prop_filterAMissing_degrade_to_filterMissing fun m = - runWhenMissingAll (filterAMissing (\k a -> Identity (f k a))) m - === runWhenMissingAll (filterMissing f) m + runIdentity (runWhenMissingAll (filterAMissing (\k a -> Identity (f k a))) m) + === runIdentity (runWhenMissingAll (filterMissing f) m) where f = applyFun2 fun prop_mapMissingEqMapWithKey :: Fun (Int, A) Int -> IntMap A -> Property @@ -1828,6 +1828,6 @@ prop_mapMissingEqMapWithKey fun m = prop_traverseMissing_degrade_to_mapMissing :: Fun (Int, A) Int -> IntMap A -> Property prop_traverseMissing_degrade_to_mapMissing fun m = - runWhenMissingAll (traverseMissing (\k a -> Identity (f k a))) m - === runWhenMissingAll (mapMissing f) m + runIdentity (runWhenMissingAll (traverseMissing (\k a -> Identity (f k a))) m) + === runIdentity (runWhenMissingAll (mapMissing f) m) where f = applyFun2 fun From 964432109b43bf54efb4ef450ddaf9526a249620 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 02:13:19 -0600 Subject: [PATCH 138/147] Fix capitalization typo --- containers/src/Data/IntMap/Lazy.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 2aad9dc2b..1283834a6 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -236,7 +236,7 @@ import Data.IntMap.Internal.DeprecatedDebug #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (runIdentity) #else -Import Data.IntMap.Merge.Internal (runIdentity) +import Data.IntMap.Merge.Internal (runIdentity) import Control.Applicative (Applicative(..), (<$>)) #endif From 6e9668cccbfafd743f300f8e0f84f6caa8234e40 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 10:47:22 -0600 Subject: [PATCH 139/147] Compare IntMaps instead of lists where possible in tests. This implicitly checks that the returned maps are valid, since fromList is separately checked for validity. --- containers-tests/tests/intmap-properties.hs | 22 ++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index fbe3c3168..e1d7f07f0 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -1352,8 +1352,8 @@ prop_differenceModel xs ys = prop_differenceWithKeyModel :: Fun (Int, Int, Int) (Maybe Int) -> [(Int,Int)] -> [(Int,Int)] -> Property prop_differenceWithKeyModel f xs ys - = toList (differenceWithKey (\k x y -> apply f (k, x, y)) (fromList xs') (fromList ys')) - === Maybe.mapMaybe diffSingle (sort xs') + = differenceWithKey (\k x y -> apply f (k, x, y)) (fromList xs') (fromList ys') + === fromList (Maybe.mapMaybe diffSingle xs') where xs' = sortNubBy (compare `on` fst) xs ys' = sortNubBy (compare `on` fst) ys @@ -1371,16 +1371,16 @@ prop_intersectionModel xs ys = prop_intersectionWithModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_intersectionWithModel xs ys - = toList (intersectionWith f (fromList xs') (fromList ys')) - === [(kx, f vx vy ) | (kx, vx) <- xs', (ky, vy) <- ys', kx == ky] + = intersectionWith f (fromList xs') (fromList ys') + === fromList [(kx, f vx vy ) | (kx, vx) <- xs', (ky, vy) <- ys', kx == ky] where xs' = sortNubBy (compare `on` fst) xs ys' = sortNubBy (compare `on` fst) ys f l r = l + 2 * r prop_intersectionWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_intersectionWithKeyModel xs ys - = toList (intersectionWithKey f (fromList xs') (fromList ys')) - === [(kx, f kx vx vy) | (kx, vx) <- xs', (ky, vy) <- ys', kx == ky] + = intersectionWithKey f (fromList xs') (fromList ys') + === fromList [(kx, f kx vx vy) | (kx, vx) <- xs', (ky, vy) <- ys', kx == ky] where xs' = sortNubBy (compare `on` fst) xs ys' = sortNubBy (compare `on` fst) ys f k l r = k + 2 * l + 3 * r @@ -1423,7 +1423,7 @@ prop_mergeWithKeyModel xs ys ym = fromList ys' testMergeWithKey f keep_x keep_y - = toList (mergeWithKey f (keep keep_x) (keep keep_y) xm ym) == emulateMergeWithKey f keep_x keep_y + = mergeWithKey f (keep keep_x) (keep keep_y) xm ym === fromList (emulateMergeWithKey f keep_x keep_y) where keep False _ = empty keep True m = m @@ -1616,13 +1616,13 @@ prop_deleteMinModel :: [(Int, Int)] -> Property prop_deleteMinModel ys = length ys > 0 ==> let xs = sortNubBy (compare `on` fst) ys m = fromList xs - in toAscList (deleteMin m) === tail (sort xs) + in deleteMin m === fromList (tail xs) prop_deleteMaxModel :: [(Int, Int)] -> Property prop_deleteMaxModel ys = length ys > 0 ==> let xs = sortNubBy (compare `on` fst) ys m = fromList xs - in toAscList (deleteMax m) === init (sort xs) + in deleteMax m === fromList (init xs) prop_filter :: Fun Int Bool -> [(Int, Int)] -> Property prop_filter p ys = @@ -1673,8 +1673,8 @@ prop_splitModel n ys = (l, r) = split n $ fromList xs in validProp l .&&. validProp r .&&. - toAscList l === takeWhile ((< n) . fst) xs .&&. - toAscList r === dropWhile ((<= n) . fst) xs + l === fromList (takeWhile ((< n) . fst) xs) .&&. + r === fromList (dropWhile ((<= n) . fst) xs) prop_splitRoot :: IMap -> Property prop_splitRoot s = loop ls .&&. (s === unions ls) From 49caed08744384e764a94daa9e074019d48949d6 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 10:55:14 -0600 Subject: [PATCH 140/147] Test splitLookup with QuickCheck --- containers-tests/tests/intmap-properties.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index e1d7f07f0..a835551fa 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -195,6 +195,7 @@ main = defaultMain , testProperty "fmap" prop_fmap , testProperty "mapkeys" prop_mapkeys , testProperty "split" prop_splitModel + , testProperty "splitLookup" prop_splitLookupModel , testProperty "splitRoot" prop_splitRoot , testProperty "isSubmapOf" prop_isSubmapOf , testProperty "isSubmapOfBy" prop_isSubmapOfBy @@ -1676,6 +1677,11 @@ prop_splitModel n ys = l === fromList (takeWhile ((< n) . fst) xs) .&&. r === fromList (dropWhile ((<= n) . fst) xs) +prop_splitLookupModel :: Int -> IMap -> Property +prop_splitLookupModel k m = + let (l, r) = split k m + in (l, lookup k m, r) === splitLookup k m + prop_splitRoot :: IMap -> Property prop_splitRoot s = loop ls .&&. (s === unions ls) where From beb38f74ee8d2d9f05433300fa2710a212ab1114 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 11:06:03 -0600 Subject: [PATCH 141/147] Test IntMap.insertLookupWithKey with QuickCheck --- containers-tests/tests/intmap-properties.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index a835551fa..741976c2a 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -144,6 +144,7 @@ main = defaultMain , testProperty "insert to singleton" prop_singleton , testProperty "insert then lookup" prop_insertLookup , testProperty "insert then delete" prop_insertDelete + , testProperty "insertLookupWithKey" prop_insertLookupWithKeyModel , testProperty "delete non member" prop_deleteNonMember , testProperty "union model" prop_unionModel , testProperty "union singleton" prop_unionSingleton @@ -1317,6 +1318,11 @@ prop_insertDelete k t = case delete k (insert k () t) of t' -> validProp t' .&&. t' === t +prop_insertLookupWithKeyModel :: Fun (Key, A, A) A -> Key -> A -> IntMap A -> Property +prop_insertLookupWithKeyModel fun k v m = + insertLookupWithKey (applyFun3 fun) k v m + === (lookup k m, insertWithKey (applyFun3 fun) k v m) + prop_deleteNonMember :: Int -> UMap -> Property prop_deleteNonMember k t = notMember k t ==> (delete k t === t) From cdf036857011471b8d8051897d57eb0f440188aa Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 11:10:08 -0600 Subject: [PATCH 142/147] Slight improvement to unionSum test --- containers-tests/tests/intmap-properties.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 741976c2a..d77bd8aa7 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -27,6 +27,7 @@ import Prelude hiding (lookup, null, map, filter, foldr, foldl) import qualified Prelude (map) import Data.List (nub,sort) +import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified Data.IntSet as IntSet import Test.Framework @@ -1344,10 +1345,10 @@ prop_unionAssoc t1 t2 t3 = union t1 (union t2 t3) === union (union t1 t2) t3 prop_unionWith :: IMap -> IMap -> Property prop_unionWith t1 t2 = union t1 t2 === unionWith (\_ y -> y) t2 t1 -prop_unionSum :: [(Int,Int)] -> [(Int,Int)] -> Bool +prop_unionSum :: [(Int,Int)] -> [(Int,Int)] -> Property prop_unionSum xs ys - = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys))) - == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys)) + = Foldable.sum (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)) + === (sum (Prelude.map snd xs) + sum (Prelude.map snd ys)) prop_differenceModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_differenceModel xs ys = From 9ed62569cf5a55704950ced7f9d4a85146023854 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 11:35:33 -0600 Subject: [PATCH 143/147] Test deletion/update functions on IntMap with QuickCheck --- containers-tests/tests/intmap-properties.hs | 66 +++++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index d77bd8aa7..e2007ca96 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -147,6 +147,16 @@ main = defaultMain , testProperty "insert then delete" prop_insertDelete , testProperty "insertLookupWithKey" prop_insertLookupWithKeyModel , testProperty "delete non member" prop_deleteNonMember + , testProperty "delete" prop_deleteModel + , testProperty "adjust" prop_adjustModel + , testProperty "adjustWithKey" prop_adjustWithKeyModel + , testProperty "update" prop_updateModel + , testProperty "updateWithKey" prop_updateWithKeyModel + , testProperty "updateLookupWithKey" prop_updateLookupWithKeyModel + , testProperty "alter" prop_alterModel + , testProperty "alter lookup" prop_alterLookup + , testProperty "alterF" prop_alterFModel + , testProperty "alterF lookup" prop_alterFLookup , testProperty "union model" prop_unionModel , testProperty "union singleton" prop_unionSingleton , testProperty "union associative" prop_unionAssoc @@ -1329,6 +1339,62 @@ prop_deleteNonMember k t = notMember k t ==> (delete k t === t) ---------------------------------------------------------------- +prop_deleteModel :: Key -> IntMap A -> Property +prop_deleteModel k m = + delete k m === fromList (List.filter ((/= k) . fst) (toList m)) + +prop_adjustModel :: Fun A A -> Key -> IntMap A -> Property +prop_adjustModel fun k m = + adjust (apply fun) k m === alter (fmap (apply fun)) k m + +prop_adjustWithKeyModel :: Fun (Key, A) A -> Key -> IntMap A -> Property +prop_adjustWithKeyModel fun k m = + adjustWithKey (applyFun2 fun) k m === adjust (applyFun2 fun k) k m + +prop_updateModel :: Fun A (Maybe A) -> Key -> IntMap A -> Property +prop_updateModel fun k m = + update (apply fun) k m === alter (>>= apply fun) k m + +prop_updateWithKeyModel :: Fun (Key, A) (Maybe A) -> Key -> IntMap A -> Property +prop_updateWithKeyModel fun k m = + updateWithKey (applyFun2 fun) k m === update (applyFun2 fun k) k m + +prop_updateLookupWithKeyModel :: Fun (Key, A) (Maybe A) -> Key -> IntMap A -> Property +prop_updateLookupWithKeyModel fun k m = + updateLookupWithKey (applyFun2 fun) k m + === (lookup k m, updateWithKey (applyFun2 fun) k m) + +prop_alterModel :: Fun (Maybe A) (Maybe A) -> Key -> IntMap A -> Property +prop_alterModel fun k m = + alter (apply fun) k m + === let old = lookup k m + in case (old, apply fun old) of + (Nothing, Nothing) -> m + (Just _, Nothing) -> delete k m + (_, Just v) -> insert k v m + +prop_alterLookup :: Fun (Maybe A) (Maybe A) -> Key -> IntMap A -> Property +prop_alterLookup fun k m = + lookup k (alter (apply fun) k m) === apply fun (lookup k m) + +prop_alterFModel :: Fun (Maybe A) (Maybe A) -> Key -> IntMap A -> Property +prop_alterFModel fun k m = + alterF f k m + === let old = lookup k m + in (old, case (old, apply fun old) of + (Nothing, Nothing) -> m + (Just _, Nothing) -> delete k m + (_, Just v) -> insert k v m) + where + f mv = (mv, apply fun mv) + +prop_alterFLookup :: Fun (Maybe A) (Maybe A) -> Key -> IntMap A -> Property +prop_alterFLookup fun k m = + fmap (lookup k) (alterF f k m) === f (lookup k m) + where + f mv = (mv, apply fun mv) + + prop_unionModel :: [(Int,Int)] -> [(Int,Int)] -> Property prop_unionModel xs ys = case union (fromList xs) (fromList ys) of From bc33c32444ce7a4652471808f18545a9729fc289 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 11:44:22 -0600 Subject: [PATCH 144/147] Remove unused arguments from helpers in IntMap.{adjust,update,updateLookupWithKey}. --- containers/src/Data/IntMap/Lazy.hs | 54 ++++++++++++++-------------- containers/src/Data/IntMap/Strict.hs | 54 ++++++++++++++-------------- 2 files changed, 54 insertions(+), 54 deletions(-) diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index 1283834a6..1fe25e6c3 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -351,22 +351,22 @@ adjust f !k = start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV node)) = case compareMinBound k min of - InBound -> IntMap (NonEmpty min minV (goL (xor k min) min node)) + InBound -> IntMap (NonEmpty min minV (goL (xor k min) node)) OutOfBound -> m Matched -> IntMap (NonEmpty min (f minV) node) - goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache min l) r - | otherwise -> Bin max maxV l (goR xorCacheMax max r) + goL !_ Tip = Tip + goL !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache l) r + | otherwise -> Bin max maxV l (goR xorCacheMax r) OutOfBound -> n Matched -> Bin max (f maxV) l r where xorCacheMax = xor k max - goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache max r) - | otherwise -> Bin min minV (goL xorCacheMin min l) r + goR !_ Tip = Tip + goR !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache r) + | otherwise -> Bin min minV (goL xorCacheMin l) r OutOfBound -> n Matched -> Bin min (f minV) l r where xorCacheMin = xor k min @@ -394,26 +394,26 @@ update f !k = start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of - InBound -> IntMap (NonEmpty min minV (goL (xor k min) min root)) + InBound -> IntMap (NonEmpty min minV (goL (xor k min) root)) OutOfBound -> m Matched -> case f minV of Nothing -> IntMap (nodeToMapL root) Just minV' -> IntMap (NonEmpty min minV' root) - goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache min l) r - | otherwise -> Bin max maxV l (goR xorCacheMax max r) + goL !_ Tip = Tip + goL !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache l) r + | otherwise -> Bin max maxV l (goR xorCacheMax r) OutOfBound -> n Matched -> case f maxV of Nothing -> extractBinL l r Just maxV' -> Bin max maxV' l r where xorCacheMax = xor k max - goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache max r) - | otherwise -> Bin min minV (goL xorCacheMin min l) r + goR !_ Tip = Tip + goR !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache r) + | otherwise -> Bin min minV (goL xorCacheMin l) r OutOfBound -> n Matched -> case f minV of Nothing -> extractBinR l r @@ -445,18 +445,18 @@ updateLookupWithKey = start where start _ !_ (IntMap Empty) = (Nothing, IntMap Empty) start f !k m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of - InBound -> let mv :*: root' = goL f k (xor k min) min root + InBound -> let mv :*: root' = goL f k (xor k min) root in (mv, IntMap (NonEmpty min minV root')) OutOfBound -> (Nothing, m) Matched -> (Just minV, case f (boundKey min) minV of Nothing -> IntMap (nodeToMapL root) Just minV' -> IntMap (NonEmpty min minV' root)) - goL _ !_ !_ _ Tip = Nothing :*: Tip - goL f !k !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> let mv :*: l' = goL f k xorCache min l + goL _ !_ !_ Tip = Nothing :*: Tip + goL f !k !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> let mv :*: l' = goL f k xorCache l in mv :*: Bin max maxV l' r - | otherwise -> let mv :*: r' = goR f k xorCacheMax max r + | otherwise -> let mv :*: r' = goR f k xorCacheMax r in mv :*: Bin max maxV l r' OutOfBound -> Nothing :*: n Matched -> Just maxV :*: case f (boundKey max) maxV of @@ -464,11 +464,11 @@ updateLookupWithKey = start Just maxV' -> Bin max maxV' l r where xorCacheMax = xor k max - goR _ !_ !_ _ Tip = Nothing :*: Tip - goR f !k !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> let mv :*: r' = goR f k xorCache max r + goR _ !_ !_ Tip = Nothing :*: Tip + goR f !k !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> let mv :*: r' = goR f k xorCache r in mv :*: Bin min minV l r' - | otherwise -> let mv :*: l' = goL f k xorCacheMin min l + | otherwise -> let mv :*: l' = goL f k xorCacheMin l in mv :*: Bin min minV l' r OutOfBound -> Nothing :*: n Matched -> Just minV :*: case f (boundKey min) minV of diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index f9b9b906e..779abdcea 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -378,22 +378,22 @@ adjust f !k = start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV node)) = case compareMinBound k min of - InBound -> IntMap (NonEmpty min minV (goL (xor k min) min node)) + InBound -> IntMap (NonEmpty min minV (goL (xor k min) node)) OutOfBound -> m Matched -> IntMap (NonEmpty min #! f minV # node) - goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache min l) r - | otherwise -> Bin max maxV l (goR xorCacheMax max r) + goL !_ Tip = Tip + goL !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache l) r + | otherwise -> Bin max maxV l (goR xorCacheMax r) OutOfBound -> n Matched -> Bin max #! f maxV # l # r where xorCacheMax = xor k max - goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache max r) - | otherwise -> Bin min minV (goL xorCacheMin min l) r + goR !_ Tip = Tip + goR !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache r) + | otherwise -> Bin min minV (goL xorCacheMin l) r OutOfBound -> n Matched -> Bin min #! f minV # l # r where xorCacheMin = xor k min @@ -421,26 +421,26 @@ update f !k = start where start (IntMap Empty) = IntMap Empty start m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of - InBound -> IntMap (NonEmpty min minV (goL (xor k min) min root)) + InBound -> IntMap (NonEmpty min minV (goL (xor k min) root)) OutOfBound -> m Matched -> case f minV of Nothing -> IntMap (nodeToMapL root) Just !minV' -> IntMap (NonEmpty min minV' root) - goL !_ _ Tip = Tip - goL !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache min l) r - | otherwise -> Bin max maxV l (goR xorCacheMax max r) + goL !_ Tip = Tip + goL !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> Bin max maxV (goL xorCache l) r + | otherwise -> Bin max maxV l (goR xorCacheMax r) OutOfBound -> n Matched -> case f maxV of Nothing -> extractBinL l r Just !maxV' -> Bin max maxV' l r where xorCacheMax = xor k max - goR !_ _ Tip = Tip - goR !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache max r) - | otherwise -> Bin min minV (goL xorCacheMin min l) r + goR !_ Tip = Tip + goR !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> Bin min minV l (goR xorCache r) + | otherwise -> Bin min minV (goL xorCacheMin l) r OutOfBound -> n Matched -> case f minV of Nothing -> extractBinR l r @@ -472,18 +472,18 @@ updateLookupWithKey = start where start _ !_ (IntMap Empty) = (Nothing, IntMap Empty) start f !k m@(IntMap (NonEmpty min minV root)) = case compareMinBound k min of - InBound -> let mv :*: root' = goL f k (xor k min) min root + InBound -> let mv :*: root' = goL f k (xor k min) root in (mv, IntMap (NonEmpty min minV root')) OutOfBound -> (Nothing, m) Matched -> (Just minV, case f k minV of Nothing -> IntMap (nodeToMapL root) Just !minV' -> IntMap (NonEmpty min minV' root)) - goL _ !_ !_ _ Tip = Nothing :*: Tip - goL f !k !xorCache min n@(Bin max maxV l r) = case compareMaxBound k max of - InBound | xorCache < xorCacheMax -> let mv :*: l' = goL f k xorCache min l + goL _ !_ !_ Tip = Nothing :*: Tip + goL f !k !xorCache n@(Bin max maxV l r) = case compareMaxBound k max of + InBound | xorCache < xorCacheMax -> let mv :*: l' = goL f k xorCache l in mv :*: Bin max maxV l' r - | otherwise -> let mv :*: r' = goR f k xorCacheMax max r + | otherwise -> let mv :*: r' = goR f k xorCacheMax r in mv :*: Bin max maxV l r' OutOfBound -> Nothing :*: n Matched -> Just maxV :*: case f k maxV of @@ -491,11 +491,11 @@ updateLookupWithKey = start Just !maxV' -> Bin max maxV' l r where xorCacheMax = xor k max - goR _ !_ !_ _ Tip = Nothing :*: Tip - goR f !k !xorCache max n@(Bin min minV l r) = case compareMinBound k min of - InBound | xorCache < xorCacheMin -> let mv :*: r' = goR f k xorCache max r + goR _ !_ !_ Tip = Nothing :*: Tip + goR f !k !xorCache n@(Bin min minV l r) = case compareMinBound k min of + InBound | xorCache < xorCacheMin -> let mv :*: r' = goR f k xorCache r in mv :*: Bin min minV l r' - | otherwise -> let mv :*: l' = goL f k xorCacheMin min l + | otherwise -> let mv :*: l' = goL f k xorCacheMin l in mv :*: Bin min minV l' r OutOfBound -> Nothing :*: n Matched -> Just minV :*: case f k minV of From fedcd58b1432e71a5ce6f7f637c35d464276f17d Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 12:54:45 -0600 Subject: [PATCH 145/147] Test map{Maybe,Either}{,WithKey} for IntMap using QuickCheck --- containers-tests/tests/intmap-properties.hs | 35 +++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index e2007ca96..1d409e5e1 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -203,6 +203,10 @@ main = defaultMain , testProperty "filter" prop_filter , testProperty "partition" prop_partition , testProperty "partitionWithKey" prop_partitionWithKey + , testProperty "mapMaybe" prop_mapMaybeModel + , testProperty "mapMaybeWithKey" prop_mapMaybeWithKeyModel + , testProperty "mapEither" prop_mapEitherModel + , testProperty "mapEitherWithKey" prop_mapEitherWithKeyModel , testProperty "map" prop_map , testProperty "fmap" prop_fmap , testProperty "mapkeys" prop_mapkeys @@ -1723,6 +1727,37 @@ prop_partitionWithKey p ys = m === let (a,b) = (List.partition (apply p) xs) in (fromList a, fromList b) +prop_mapMaybeModel :: Fun A (Maybe B) -> IntMap A -> Property +prop_mapMaybeModel fun m = + mapMaybe (apply fun) m + === mapMaybeWithKey (const (apply fun)) m + +prop_mapMaybeWithKeyModel :: Fun (Key, A) (Maybe B) -> IntMap A -> Property +prop_mapMaybeWithKeyModel fun m = + mapMaybeWithKey (applyFun2 fun) m + === fromList (Maybe.mapMaybe fPair (toList m)) + where + fPair (k, v) = case apply fun (k, v) of + Nothing -> Nothing + Just v' -> Just (k, v') + +prop_mapEitherModel :: Fun A (Either B C) -> IntMap A -> Property +prop_mapEitherModel fun m = + mapEither (apply fun) m + === mapEitherWithKey (const (apply fun)) m + +prop_mapEitherWithKeyModel :: Fun (Key, A) (Either B C) -> IntMap A -> Property +prop_mapEitherWithKeyModel fun m = + mapEitherWithKey (applyFun2 fun) m + === ( mapMaybeWithKey (\k v -> maybeLeft (apply fun (k, v))) m + , mapMaybeWithKey (\k v -> maybeRight (apply fun (k, v))) m) + where + maybeLeft (Left v) = Just v + maybeLeft _ = Nothing + + maybeRight (Right v) = Just v + maybeRight _ = Nothing + prop_map :: Fun Int Int -> [(Int, Int)] -> Property prop_map f ys = let xs = sortNubBy (compare `on` fst) ys From b4880048fa81c03faeadfb02a00c5803b333d021 Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Thu, 23 Jan 2020 17:45:14 -0600 Subject: [PATCH 146/147] Don't optimize the IntMap tests. There isn't much speed to be gained from optimization, since the tests are just calling functions. The compile+test total time seems to be ~3.5x smaller after this change. --- containers-tests/containers-tests.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index ade9f74f7..da7dcf76a 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -326,7 +326,7 @@ test-suite intmap-lazy-properties , base >=4.6 && <5 , deepseq >=1.2 && <1.5 - ghc-options: -O2 + ghc-options: -O0 other-extensions: BangPatterns CPP @@ -349,7 +349,7 @@ test-suite intmap-strict-properties , base >=4.6 && <5 , deepseq >=1.2 && <1.5 - ghc-options: -O2 + ghc-options: -O0 other-extensions: BangPatterns CPP From 49b6997472412fe43d63a6f7cf62cff9aced2b9e Mon Sep 17 00:00:00 2001 From: Jonathan S Date: Fri, 24 Jan 2020 01:22:15 -0600 Subject: [PATCH 147/147] Re-enable optimization for IntMap tests to ensure testing of rewrite rules --- containers-tests/containers-tests.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index da7dcf76a..c9cc16472 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -326,7 +326,7 @@ test-suite intmap-lazy-properties , base >=4.6 && <5 , deepseq >=1.2 && <1.5 - ghc-options: -O0 + ghc-options: -O1 other-extensions: BangPatterns CPP @@ -349,7 +349,7 @@ test-suite intmap-strict-properties , base >=4.6 && <5 , deepseq >=1.2 && <1.5 - ghc-options: -O0 + ghc-options: -O1 other-extensions: BangPatterns CPP