├── LICENSE ├── README.md ├── benchmarks ├── IntMapBench.hs ├── IntSet.hs └── report.html ├── bounded-intmap.cabal ├── src └── Data │ ├── IntMap │ ├── Bounded.hs │ └── Bounded │ │ ├── Base.hs │ │ ├── Lazy.hs │ │ └── Strict.hs │ ├── StrictPair.hs │ ├── WordMap.hs │ ├── WordMap │ ├── Base.hs │ ├── Lazy.hs │ ├── Merge │ │ ├── Base.hs │ │ ├── Lazy.hs │ │ └── Strict.hs │ └── Strict.hs │ ├── WordSet.hs │ └── WordSet │ └── Internal.hs └── tests └── WordMap.hs /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2013 gereeter 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | bounded-intmap 2 | ============== 3 | 4 | The most current work on this is being done in [haskell/containers#340](https://github.com/haskell/containers/pull/340). This repository is not obsolete because it is still the best description of the algorithm, but it is unmaintained. 5 | 6 | `bounded-intmap` is a reimplementation of `Data.IntMap` that uses minimum and maximum bounds on subtrees instread of bit prefixes. The original idea, by Edward Kmett, is described [here](https://www.schoolofhaskell.com/user/edwardk/revisiting-matrix-multiplication/part-4). As per my current benchmark results, this implemenation seems to range from 33% faster to 33% slower than stock `Data.IntMap`. However, only four types of function in the benchmark, `intersection`, `difference`, `fromAscList`, and `foldlWithKey`, are slower than stock `Data.IntMap`, and not all of these are slower in all cases. In comparison, `lookup`, `member`, `map`, `mapMaybe`, `insert`, `delete`, `update`, 'alter', and `union` are all faster than stock `Data.IntMap`. Additionally, this implementation, on GHC, has an overhead of 3 words per key/value pair, while stock `Data.IntMap` has an overhead of 6 words per key/value pair. 7 | 8 | I deviate from Edward Kmett's implementation in a couple of ways: 9 | 10 | * I removed the redundant encoding of bounds. Previously, you might have a tree like this: 11 | 12 | 0,7 13 | / \ 14 | 0,3 4,7 15 | / \ / \ 16 | 0,1 2,3 4,5 6,7 17 | 18 | Now, you have trees like this: 19 | 20 | 0,7 21 | / \ 22 | 3 4 23 | / \ / \ 24 | 1 2 5 6 25 | 26 | Note that this means that this implementation consumes less memory than the current `Data.IntMap`. 27 | 28 | * I factored the datatype into two pieces: `Node` for non-empty trees, and `WordMap` for possibly empty trees. 29 | * I cache some of the computation for locating a key as I traverse the key, making it quicker to decide which way to go. 30 | * The values associated with each key are stored with the key instead of at the leaves. 31 | 32 | Why `WordMap`? 33 | -------------- 34 | 35 | Although the main goal of this project is to replace `Data.IntMap`, I also expose another module, `Data.WordMap`. In fact, my `IntMap` implementation is mostly just a wrapper of the `WordMap` code. The primary reason for this is code readability. Fundamentally, the data structure implemented here is a trie, and wants to work with lexographically ordered strings of bits. `Word`s have the correct ordering and more naturally fit the idea of bitstring than an `Int`, which is used for arithmetic. Given that I, unlike the previous `Data.IntMap`, actually use comparisons, the convenience for using `Word`s is even larger. The decision to expose `Data.WordMap` was then a simple one: I had already written the code, so why not? 36 | 37 | Secondarily, I believe that the Haskell community doesn't use `Word`s enough, even when they are most applicable (which is weird, given the love of more accurately showing invariants in the type system), and having some libraries that actually use them would help. 38 | 39 | Benchmark Results 40 | ----------------- 41 | The criterion report is [here](http://gereeter.github.io/bounded-intmap/report.html). 42 | 43 | Current Progress 44 | ---------------- 45 | Below is a listing of every function in stock `Data.IntMap`, along with the implementation state in `bounded-intmap`. There are three implementation states: 46 | 47 | * Raw means that I have implemented the function directly. These functions should be on par with or faster than their corresponding functions in stock `Data.IntMap`. 48 | * Delegated means that I have implemented the function, but in terms of other functions. This usually means that it will be slower than stock `Data.IntMap`, sometimes asymptotically, and I haven't figured out how to implement it (or implement it nicely) yet. Note that some functions marked as such, like `insertWithKey`, are trivial uses of other functions are should have almost no performance hit. 49 | * Unimplemented means that I have yet to implement the function in any form. 50 | 51 | ### Operators 52 | * `(!)`. Delegated, using `findWithDefault`. 53 | * `(\\)`. Delegated, using `difference`. 54 | 55 | ### Query 56 | * `null`. Raw. 57 | * `size`. Raw. 58 | * `member`. Raw. 59 | * `notMember`. Raw. 60 | * `lookup`. Raw. 61 | * `findWithDefault`. Raw. 62 | * `lookupLT`. Raw. 63 | * `lookupGT`. Raw. 64 | * `lookupLE`. Raw. 65 | * `lookupGE`. Raw. 66 | 67 | ### Construction 68 | * `empty`. Raw. 69 | * `singleton`. Raw. 70 | 71 | #### Insertion 72 | * `insert`. Raw. 73 | * `insertWith`. Raw. 74 | * `insertWithKey`. Delegated, using `insertWith`. 75 | * `insertLookupWithKey`. Raw. 76 | 77 | #### Delete/Update 78 | * `delete`. Raw. 79 | * `adjust`. Raw. 80 | * `adjustWithkey`. Delegated, using `adjust`. 81 | * `update`. Raw. 82 | * `updateWithKey`. Delegated, using `update`. 83 | * `updateLookupWithKey`. Raw. 84 | * `alter`. Delegated, using `lookup` and either `delete` or `insert`. 85 | * `alterF`. Delegated, using `lookup` and either `delete` or `insert`. 86 | 87 | ### Combine 88 | #### Union 89 | * `union`. Raw. 90 | * `unionWith`. Delegated, using `unionWithKey`. 91 | * `unionWithKey`. Raw. 92 | * `unions`. Delegated, using lots of `union`s. 93 | * `unionsWith`. Delegated, using lots of `unionWith`s. 94 | 95 | #### Difference 96 | * `difference`. Raw. 97 | * `differenceWith`. Delegated, using `differenceWithKey`. 98 | * `differenceWithKey`. Raw. 99 | 100 | #### Intersection 101 | * `intersection`. Raw. See note on `intersectionWithKey`. 102 | * `intersectionWith`. Delegated, using `intersectionWithKey`. 103 | * `intersectionWithKey`. Raw. Note that it is still slower than stock `Data.IntMap` by up to (though not necessarily) 50%. 104 | 105 | #### Universal combining function 106 | * `mergeWithKey`. Delegated, using `merge`. Much slower than stock `mergeWithKey` and always will be - this function is terrible and abstraction-breaking. 107 | 108 | ### Traversal 109 | #### Map 110 | * `map`. Raw. Actually, this is sort of delegated to `fmap`, but since the delegation is just `map = fmap` and will probably be inlined, I count this as raw. 111 | * `mapWithKey`. Raw. 112 | * `traverseWithKey`. Raw. 113 | * `mapAccum`. Delegated, using `mapAccumWithKey`. 114 | * `mapAccumWithKey`. Raw. 115 | * `mapAccumRWithKey`. Raw. 116 | * `mapKeys`. Delegated, using `foldrWithKey'` and lots of `insert`s. 117 | * `mapKeysWith`. Delegated, using `foldrWithKey'` and lots of `insertWith`s. 118 | * `mapKeysMonotonic`. Delegated, using `mapKeys`. 119 | 120 | #### Folds 121 | * `foldr`. Raw. 122 | * `foldl`. Raw. 123 | * `foldrWithKey`. Raw. 124 | * `foldlWithKey`. Raw. 125 | * `foldMapWithKey`. Raw. 126 | 127 | #### Strict folds 128 | * `foldr'`. Raw. 129 | * `foldl'`. Raw. 130 | * `foldrWithKey'`. Raw. 131 | * `foldlWithKey'`. Raw. 132 | 133 | ### Conversion 134 | * `elems`. Delegated, using `foldr`. 135 | * `keys`. Delegated, using `foldrWithKey`. 136 | * `assocs`. Delegated, using `toAscList`. 137 | * `keysSet`. Delegated, using `keys` and `Data.IntSet.fromDistinctAscList`. Note that this is only for `IntMap`, not for `WordMap`, as I'm not sure what to convert to. 138 | * `fromSet`. Delegated, using `Data.IntSet.toList` and `fromDistinctAscList`. Note that this is only for `IntMap`, not for `WordMap`, as I'm not sure what to convert from. 139 | 140 | #### Lists 141 | * `toList`. Delegated, using `toAscList`. 142 | * `fromList`. Delegated, using lots of `insert`s. 143 | * `fromListWith`. Delegated, using lots of `insert`s. 144 | * `fromListWithKey`. Delegated, using lots of `insert`s. 145 | 146 | #### Ordered lists 147 | * `toAscList`. Delegated, using `foldrWithKey`. 148 | * `toDescList`. Delegated, using `foldlWithKey`. 149 | * `fromAscList`. Delegated, using `fromList`. 150 | * `fromAscListWith`. Delegated, using `fromListWith`. 151 | * `fromAscListWithKey`. Delegated, using `fromListWithKey`. 152 | * `fromDistinctAscList`. Delegated, using `fromList`. 153 | 154 | ### Filter 155 | * `filter`. Delegated, using `filterWithKey`. 156 | * `filterWithKey`. Raw. 157 | * `restrictKeys`. Delegated, using `filterWithKey` and `Data.IntSet.member`. Note that this is only for `IntMap`, not for `WordMap`, as I'm not sure what set to intersect with. 158 | * `withoutKeys`. Delegated, using `filterWithKey` and `Data.IntSet.notMember`. Note that this is only for `IntMap`, not for `WordMap`, as I'm not sure what set to intersect with. 159 | * `partition`. Delegated, using `partitionWithKey`. 160 | * `partitionWithKey`. Raw. 161 | * `mapMaybe`. Delegated, using `mapMaybeWithKey`. 162 | * `mapMaybeWithKey`. Raw. 163 | * `mapEither`. Delegated, using `mapEitherWithKey`. 164 | * `mapEitherWithKey`. Raw. 165 | * `split`. Delegated, using `splitLookup`. 166 | * `splitLookup`. Raw. 167 | * `splitRoot`. Raw. 168 | 169 | ### Submap 170 | * `isSubmapOf`. Delegated, using `isSubmapOfBy`. 171 | * `isSubmapOfBy`. Raw. 172 | * `isProperSubmapOf`. Delegated, using `isProperSubmapOfBy`. 173 | * `isProperSubmapOfBy`. Raw. 174 | 175 | ### Min/Max 176 | * `findMin`. Raw. Note that this is asymptotically faster than stock `Data.IntMap`. 177 | * `findMax`. Raw. Note that this is asymptotically faster than stock `Data.IntMap`. 178 | * `deleteMin`. Delegated, using `findMin` and `delete`. 179 | * `deleteMax`. Delegated, using `findMin` and `delete`. 180 | * `deleteFindMin`. Delegated, using `findMin` and `delete`. 181 | * `deleteFindMax`. Delegated, using `findMin` and `delete`. 182 | * `updateMin`. Delegated, using `findMin` and `update`. 183 | * `updateMax`. Delegated, using `findMin` and `update`. 184 | * `updateMinWithKey`. Delegated, using `findMin` and `updateWithKey`. 185 | * `updateMaxWithKey`. Delegated, using `findMin` and `updateWithKey`. 186 | * `minView`. Delegated, using `findMin` and `delete`. 187 | * `maxView`. Delegated, using `findMin` and `delete`. 188 | * `minViewWithKey`. Delegated, using `findMin` and `delete`. 189 | * `maxViewWithKey`. Delegated, using `findMin` and `delete`. 190 | 191 | ### Debugging 192 | Note that this section shouldn't matter to the average user. 193 | * `showTree`. Raw. 194 | * `showTreeWith`. _Unimplemented_. 195 | 196 | Description of the internals 197 | ---------------------------- 198 | ### The basic integer map: the bitwise trie ### 199 | 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 instead as strings of bits. Once we change our mindset, we can use the standard _trie_ data structure to build our mapping. As bits are particularly simple, so is the resulting structure: 200 | 201 | ```haskell 202 | data WordMap a = Bin (WordMap a) (WordMap a) | Tip a | Nil 203 | ``` 204 | 205 | The `Bin` constructor represents a bitwise branch, and the `Tip` constructor comes after (on my machine) 64 `Bin` construtors in the tree. The associated basic operations are fairly simple: 206 | 207 | ```haskell 208 | lookup :: Word -> WordMap a -> Maybe a 209 | lookup k = go 0 210 | where 211 | go b (Bin l r) = if testBit b k 212 | then go (b + 1) l 213 | else go (b + 1) r 214 | go _ (Tip x) = Just x 215 | go _ Nil = Nothing 216 | 217 | insert :: Word -> a -> WordMap a -> WordMap a 218 | insert k a = go 0 219 | where 220 | go 64 _ = Tip a 221 | go b (Bin l r) = if testBit b k 222 | then Bin (go (b + 1) l) r 223 | else Bin l (go (b + 1) r) 224 | go b _ = if testBit b k 225 | then Bin (go (b + 1) Nil) Nil 226 | else Bin Nil (go (b + 1) Nil) 227 | ``` 228 | 229 | `delete` follows similarly, and `union` isn't to hard - I leave it as an exercise to the reader. Unfortunately, this approach is horribly slow and space efficient. To see why, let us look at the tree structure for `singleton 5 "hello"`: 230 | 231 | ``` 232 | \0 233 | \0 234 | \0 235 | \0 236 | \0 237 | \0 238 | \0 239 | \0 240 | \0 241 | \0 242 | \0 243 | \0 244 | \0 245 | 1/ 246 | \0 247 | 1/ 248 | "hello" 249 | ``` 250 | 251 | Note that, for brevity, I have shortened the word size to 16 bits - the diagram is 4 times larger for our 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` or `insert` or `delete` must traverse 64 pointers, resulting in 64 cache misses and a terrible runtime. So, how do we fix this? 252 | 253 | ### Path compression: PATRICIA trees and stock `Data.IntMap` ### 254 | The key observation to reducing the space usage is that we can compress nodes that only have one child together - since they form a linear chain, we can simply concatenate the bits within that chain. For example, again temporarily shortening the word size to 16 bits: 255 | 256 | ``` 257 | singleton 5 "hello": 258 | 259 | | 0000000000000101 260 | "hello" 261 | 262 | fromList [(1, "1"), (4, "4"), (5, "5")]: 263 | 264 | | 0000000000000___ 265 | 001/ \10_ 266 | "1" 0/ \1 267 | "4" "5" 268 | ``` 269 | 270 | This clearly produces a much more space efficient structure, and the basic operations, while more complicated, are still straightforward. In Haskell, the structure is: 271 | 272 | ```haskell 273 | data WordMap a = Bin Prefix Mask (WordMap a) (WordMap a) | Tip Word a | Nil 274 | ``` 275 | 276 | Note that in the above representation, the `Mask` is used to tell how long the `Prefix` is, and the `Word` in the `Tip` nodes is to avoid the for using `Bin` for singletons. This final representation is known as the big-endian PATRICIA tree, and is what today's `Data.IntMap` uses internally, albeit with some optimizations like strictness and unpacking, which I have omitted for simplicity. However, we can take this structure a few steps farther, which is the goal of this package. 277 | 278 | ### Implicit prefixes: a simpler representation ### 279 | 280 | The central observation for this step comes from Edward Kmett, as mentioned in a previous section. 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 largest and smallest keys stored within a subtree are - the common prefix of all the keys is just the common prefix of the minimum and maximum keys. Using this observation, we get another representation: 281 | 282 | ```haskell 283 | data WordMap a = Bin Word Word (WordMap a) (WordMap a) | Tip Word a | Nil 284 | ``` 285 | 286 | In tree form: 287 | ``` 288 | singleton 5 hello: 289 | 290 | | 5 291 | "hello" 292 | 293 | fromList [(1, "1"), (4, "4"), (5, "5")]: 294 | 295 | | (1, 5) 296 | 1/ \ (4, 5) 297 | "1" 4/ \5 298 | "4" "5" 299 | ``` 300 | 301 | Traversing this tree efficiently is a bit more difficult, but still possible. For details, see the section below titled "Figuring out which way to go". This representation, since it gives exact minimums and maximums, can actually be more efficient than the PATRICIA tree, as seaches can terminate earlier. The range of values between the minimum and maximum is generally smaller than the range of values with the correct prefix, and so searches will know earlier if they are going to fail. However, the big gains of this representation come after a few more steps. 302 | 303 | ### Removing redundancy ### 304 | You may have noticed that 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 reason for this is very simple. In the {1,4,5} example, we knew that the minimum was 1 and the maximum was 5. At the first branch, we split the set into two parts - {1} and {4,5}. However, the minimum of the smaller set was exactly the minimum of the original set. Similarly, the maximum of the larger set was exactly the maximum of the original set. Since we always travers the tree downward, this information is not needed. We can restructure the tree to only store 1 new value at each branch, removing the redundancy. Note that we also have to add an extra value at the root node, where this transformation does not work. In summary: 305 | 306 | ```haskell 307 | data WordMap a = Empty | NonEmpty Word (Node a) 308 | data Node a = Bin Word (Node a) (Node a) | Tip a 309 | ``` 310 | 311 | In tree form: 312 | ``` 313 | | 1 314 | | 5 315 | / \ 316 | "1" 4/ \ 317 | "4" "5" 318 | ``` 319 | 320 | With this optimization, the operations get more complicated again, but we have achieved something amazing - this new representation is more memory efficient than stock `Data.IntMap`. We will improve this again, as well as the runtime, with our final optimization. 321 | 322 | ### Moving the values upward ### 323 | If you look carefully at the tree structure from the previous section, you will notice that we removed the redundancy perfectly - every key is stored exactly once. However, if the keys are stored in a unique location in the tree, why are the values stored far away? We can move the values upward in the tree to pair them with their keys and so get a simpler structure. 324 | 325 | In Haskell: 326 | ```haskell 327 | data WordMap a = Empty | NonEmpty Word a (Node a) 328 | data Node a = Bin Word a (Node a) (Node a) | Tip 329 | ``` 330 | 331 | In tree form: 332 | ``` 333 | | 1 "1" 334 | | 5 "5" 335 | / \ 336 | / \ 4 "4" 337 | ``` 338 | 339 | At first, this seems to improve neither runtime nor space usage - after all, all we did was move the values around. However, the `Tip` constructor is now empty, meaning that it can be shared among all the leaves of every tree. The `Tip` constructor essentiall disappears from the space usage profile, and we get a gain in memory. The runtime effect is even larger. Because the values are now high in the tree, functions like `lookup` don't have to go all the way to the leaves. This means following fewer pointers, which means fewer cache misses and just a shorter loop. Admittedly, after all this work, our functions have become much larger than the sizes they started with, but we have won speed gains and significant memory gains from the current state of the art. 340 | 341 | ### Figuring out which way to go ### 342 | Suppose we are looking up a key `k` in a tree. We know that the minimum key in the tree is `min` and that the maximum key is `max`. Represented in binary: 343 | 344 | shared prefix bit to split on 345 | /----------\ / 346 | min: 010010010101 0 ???????? 347 | max: 010010010101 1 ???????? 348 | k: 010010010101 ? ???????? 349 | 350 | To figure out in which subtree we need to recursively search for `k`, we need to know whether the bit to split on is zero or one. Now, if it is zero, then 351 | 352 | xor min k: 000000000000 0 ???????? 353 | xor k max: 000000000000 1 ???????? 354 | 355 | If it is one: 356 | 357 | xor min k: 000000000000 1 ???????? 358 | xor k max: 000000000000 0 ???????? 359 | 360 | Therefore, the splitting bit is set iff `xor min k > xor k max`. Taking the terminology from the original article, `insideR k min max = xor min k > xor k max`. 361 | -------------------------------------------------------------------------------- /benchmarks/IntMapBench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Main where 3 | 4 | import Control.DeepSeq 5 | import Control.Exception (evaluate) 6 | import Criterion.Main 7 | import Data.List (foldl') 8 | import qualified Data.IntMap as M 9 | import qualified Data.IntMap.Bounded as W 10 | import Data.Maybe (fromMaybe) 11 | import Prelude hiding (lookup) 12 | 13 | main = do 14 | let denseM = M.fromAscList elems :: M.IntMap Int 15 | denseW = W.fromList elems :: W.IntMap Int 16 | sparseM = M.fromAscList sElems :: M.IntMap Int 17 | sparseW = W.fromList sElems :: W.IntMap Int 18 | sparseM' = M.fromAscList sElemsSearch :: M.IntMap Int 19 | sparseW' = W.fromList sElemsSearch :: W.IntMap Int 20 | evaluate $ rnf [denseM, sparseM, sparseM'] 21 | evaluate $ rnf [denseW, sparseW, sparseW'] 22 | evaluate $ rnf [elems, sElems, sElemsSearch] 23 | evaluate $ rnf [keys, sKeys, sKeysSearch] 24 | evaluate $ rnf [values, sValues] 25 | defaultMain 26 | [ bgroup "lookup" 27 | [ bgroup "present" 28 | [ bench "IntMap" $ whnf (\m -> foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 keys) denseM 29 | , bench "WordMap" $ whnf (\m -> foldl' (\n k -> fromMaybe n (W.lookup k m)) 0 keys) denseW 30 | ] 31 | , bgroup "absent" 32 | [ bench "IntMap" $ whnf (\m -> foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 sKeysSearch) sparseM 33 | , bench "WordMap" $ whnf (\m -> foldl' (\n k -> fromMaybe n (W.lookup k m)) 0 sKeysSearch) sparseW 34 | ] 35 | ] 36 | , bgroup "member" 37 | [ bgroup "present" 38 | [ bench "IntMap" $ whnf (\m -> foldl' (\n x -> if M.member x m then n + 1 else n) 0 keys) denseM 39 | , bench "WordMap" $ whnf (\m -> foldl' (\n x -> if W.member x m then n + 1 else n) 0 keys) denseW 40 | ] 41 | , bgroup "absent" 42 | [ bench "IntMap" $ whnf (\m -> foldl' (\n x -> if M.member x m then n + 1 else n) 0 sKeysSearch) sparseM 43 | , bench "WordMap" $ whnf (\m -> foldl' (\n x -> if W.member x m then n + 1 else n) 0 sKeysSearch) sparseW 44 | ] 45 | , bgroup "specialized" 46 | [ bgroup "present" 47 | [ bench "IntMap" $ whnf (M.member 1234) denseM 48 | , bench "WordMap" $ whnf (W.member 1234) denseW 49 | ] 50 | , bgroup "absent" 51 | [ bench "IntMap" $ whnf (M.member 1234) sparseM 52 | , bench "WordMap" $ whnf (W.member 1234) sparseW 53 | ] 54 | ] 55 | ] 56 | , bgroup "insert" 57 | [ bgroup "present" 58 | [ bench "IntMap" $ whnf (\m -> foldl' (\m (k, v) -> M.insert k v m) m elems) denseM 59 | , bench "WordMap" $ whnf (\m -> foldl' (\m (k, v) -> W.insert k v m) m elems) denseW 60 | ] 61 | , bgroup "absent" 62 | [ bench "IntMap" $ whnf (\m -> foldl' (\m (k, v) -> M.insert k v m) m sElemsSearch) sparseM 63 | , bench "WordMap" $ whnf (\m -> foldl' (\m (k, v) -> W.insert k v m) m sElemsSearch) sparseW 64 | ] 65 | ] 66 | , bgroup "insertWith" 67 | [ bgroup "present" 68 | [ bench "IntMap" $ whnf (\m -> foldl' (\m (k, v) -> M.insertWith (+) k v m) m elems) denseM 69 | , bench "WordMap" $ whnf (\m -> foldl' (\m (k, v) -> W.insertWith (+) k v m) m elems) denseW 70 | ] 71 | , bgroup "absent" 72 | [ bench "IntMap" $ whnf (\m -> foldl' (\m (k, v) -> M.insertWith (+) k v m) m sElemsSearch) sparseM 73 | , bench "WordMap" $ whnf (\m -> foldl' (\m (k, v) -> W.insertWith (+) k v m) m sElemsSearch) sparseW 74 | ] 75 | ] 76 | , bgroup "map" 77 | [ bench "IntMap" $ whnf (M.map (+1)) denseM 78 | , bench "WordMap" $ whnf (W.map (+1)) denseW 79 | ] 80 | , bgroup "mapWithKey" 81 | [ bench "IntMap" $ whnf (M.mapWithKey (+)) denseM 82 | , bench "WordMap" $ whnf (W.mapWithKey (+)) denseW 83 | ] 84 | , bgroup "foldlWithKey" 85 | [ bench "IntMap" $ whnf (M.foldlWithKey add3 0) denseM 86 | , bench "WordMap" $ whnf (W.foldlWithKey add3 0) denseW 87 | ] 88 | , bgroup "foldlWithKey'" 89 | [ bench "IntMap" $ whnf (M.foldlWithKey' add3 0) denseM 90 | , bench "WordMap" $ whnf (W.foldlWithKey' add3 0) denseW 91 | ] 92 | , bgroup "mapMaybe" 93 | [ bgroup "present" 94 | [ bench "IntMap" $ whnf (M.mapMaybe Just) denseM 95 | , bench "WordMap" $ whnf (W.mapMaybe Just) denseW 96 | ] 97 | , bgroup "absent" 98 | [ bench "IntMap" $ whnf (M.mapMaybe (const Nothing)) denseM 99 | , bench "WordMap" $ whnf (W.mapMaybe (const Nothing)) denseW 100 | ] 101 | ] 102 | , bgroup "mapMaybeWithKey" 103 | [ bgroup "present" 104 | [ bench "IntMap" $ whnf (M.mapMaybeWithKey (const Just)) denseM 105 | , bench "WordMap" $ whnf (W.mapMaybeWithKey (const Just)) denseW 106 | ] 107 | , bgroup "absent" 108 | [ bench "IntMap" $ whnf (M.mapMaybeWithKey (const (const Nothing))) denseM 109 | , bench "WordMap" $ whnf (W.mapMaybeWithKey (const (const Nothing))) denseW 110 | ] 111 | ] 112 | , bgroup "delete" 113 | [ bgroup "present" 114 | [ bench "IntMap" $ whnf (\m -> foldl' (\m k -> M.delete k m) m keys) denseM 115 | , bench "WordMap" $ whnf (\m -> foldl' (\m k -> W.delete k m) m keys) denseW 116 | ] 117 | , bgroup "absent" 118 | [ bench "IntMap" $ whnf (\m -> foldl' (\m k -> M.delete k m) m sKeysSearch) sparseM 119 | , bench "WordMap" $ whnf (\m -> foldl' (\m k -> W.delete k m) m sKeysSearch) sparseW 120 | ] 121 | , bgroup "specialized" 122 | [ bgroup "present" 123 | [ bench "IntMap" $ whnf (M.delete 1234) denseM 124 | , bench "WordMap" $ whnf (W.delete 1234) denseW 125 | ] 126 | , bgroup "absent" 127 | [ bench "IntMap" $ whnf (M.delete 1234) sparseM 128 | , bench "WordMap" $ whnf (W.delete 1234) sparseW 129 | ] 130 | ] 131 | ] 132 | , bgroup "update" 133 | [ bgroup "present" 134 | [ bench "IntMap" $ whnf (\m -> foldl' (\m k -> M.update Just k m) m keys) denseM 135 | , bench "WordMap" $ whnf (\m -> foldl' (\m k -> W.update Just k m) m keys) denseW 136 | ] 137 | , bgroup "absent" 138 | [ bench "IntMap" $ whnf (\m -> foldl' (\m k -> M.update Just k m) m sKeysSearch) sparseM 139 | , bench "WordMap" $ whnf (\m -> foldl' (\m k -> W.update Just k m) m sKeysSearch) sparseW 140 | ] 141 | ] 142 | , bgroup "alter" 143 | [ bgroup "id" 144 | [ bgroup "present" 145 | [ bench "IntMap" $ whnf (\m -> foldl' (\m k -> M.alter id k m) m keys) denseM 146 | , bench "WordMap" $ whnf (\m -> foldl' (\m k -> W.alter id k m) m keys) denseW 147 | ] 148 | , bgroup "absent" 149 | [ bench "IntMap" $ whnf (\m -> foldl' (\m k -> M.alter id k m) m sKeysSearch) sparseM 150 | , bench "WordMap" $ whnf (\m -> foldl' (\m k -> W.alter id k m) m sKeysSearch) sparseW 151 | ] 152 | ] 153 | , bgroup "delete" 154 | [ bgroup "present" 155 | [ bench "IntMap" $ whnf (\m -> foldl' (\m k -> M.alter (const Nothing) k m) m keys) denseM 156 | , bench "WordMap" $ whnf (\m -> foldl' (\m k -> W.alter (const Nothing) k m) m keys) denseW 157 | ] 158 | , bgroup "absent" 159 | [ bench "IntMap" $ whnf (\m -> foldl' (\m k -> M.alter (const Nothing) k m) m sKeysSearch) sparseM 160 | , bench "WordMap" $ whnf (\m -> foldl' (\m k -> W.alter (const Nothing) k m) m sKeysSearch) sparseW 161 | ] 162 | ] 163 | ] 164 | , bgroup "union" 165 | [ bgroup "present" 166 | [ bench "IntMap" $ whnf (uncurry M.union) (denseM, sparseM) 167 | , bench "WordMap" $ whnf (uncurry W.union) (denseW, sparseW) 168 | , bench "NewWordMap" $ whnf (uncurry W.unionM) (denseW, sparseW) 169 | ] 170 | , bgroup "absent" 171 | [ bench "IntMap" $ whnf (uncurry M.union) (sparseM, sparseM') 172 | , bench "WordMap" $ whnf (uncurry W.union) (sparseW, sparseW') 173 | , bench "NewWordMap" $ whnf (uncurry W.unionM) (sparseW, sparseW') 174 | ] 175 | ] 176 | , bgroup "unionWithKey" 177 | [ bgroup "present" 178 | [ bench "IntMap" $ whnf (uncurry (M.unionWithKey (\k v1 v2 -> k + v1 + v2))) (denseM, sparseM) 179 | , bench "WordMap" $ whnf (uncurry (W.unionWithKey (\k v1 v2 -> k + v1 + v2))) (denseW, sparseW) 180 | , bench "NewWordMap" $ whnf (uncurry (W.unionWithM (\k v1 v2 -> k + v1 + v2))) (denseW, sparseW) 181 | ] 182 | , bgroup "absent" 183 | [ bench "IntMap" $ whnf (uncurry (M.unionWithKey (\k v1 v2 -> k + v1 + v2))) (sparseM, sparseM') 184 | , bench "WordMap" $ whnf (uncurry (W.unionWithKey (\k v1 v2 -> k + v1 + v2))) (sparseW, sparseW') 185 | , bench "NewWordMap" $ whnf (uncurry (W.unionWithM (\k v1 v2 -> k + v1 + v2))) (sparseW, sparseW') 186 | ] 187 | ] 188 | , bgroup "difference" 189 | [ bgroup "present" 190 | [ bench "IntMap" $ whnf (uncurry M.difference) (denseM, sparseM) 191 | , bench "WordMap" $ whnf (uncurry W.difference) (denseW, sparseW) 192 | , bench "NewWordMap" $ whnf (uncurry W.differenceM) (denseW, sparseW) 193 | ] 194 | , bgroup "absent" 195 | [ bench "IntMap" $ whnf (uncurry M.difference) (sparseM, sparseM') 196 | , bench "WordMap" $ whnf (uncurry W.difference) (sparseW, sparseW') 197 | , bench "NewWordMap" $ whnf (uncurry W.differenceM) (sparseW, sparseW') 198 | ] 199 | ] 200 | , bgroup "intersection" 201 | [ bgroup "present" 202 | [ bench "IntMap" $ whnf (uncurry M.intersection) (denseM, sparseM) 203 | , bench "WordMap" $ whnf (uncurry W.intersection) (denseW, sparseW) 204 | , bench "NewWordMap" $ whnf (uncurry W.intersectionM) (denseW, sparseW) 205 | ] 206 | , bgroup "absent" 207 | [ bench "IntMap" $ whnf (uncurry M.intersection) (sparseM, sparseM') 208 | , bench "WordMap" $ whnf (uncurry W.intersection) (sparseW, sparseW') 209 | , bench "NewWordMap" $ whnf (uncurry W.intersectionM) (sparseW, sparseW') 210 | ] 211 | ] 212 | , bgroup "intersectionWithKey" 213 | [ bgroup "present" 214 | [ bench "IntMap" $ whnf (uncurry (M.intersectionWithKey (\k v1 v2 -> k + v1 + v2))) (denseM, sparseM) 215 | , bench "WordMap" $ whnf (uncurry (W.intersectionWithKey (\k v1 v2 -> k + v1 + v2))) (denseW, sparseW) 216 | , bench "NewWordMap" $ whnf (uncurry (W.intersectionWithM (\k v1 v2 -> k + v1 + v2))) (denseW, sparseW) 217 | ] 218 | , bgroup "absent" 219 | [ bench "IntMap" $ whnf (uncurry (M.intersectionWithKey (\k v1 v2 -> k + v1 + v2))) (sparseM, sparseM') 220 | , bench "WordMap" $ whnf (uncurry (W.intersectionWithKey (\k v1 v2 -> k + v1 + v2))) (sparseW, sparseW') 221 | , bench "NewWordMap" $ whnf (uncurry (W.intersectionWithM (\k v1 v2 -> k + v1 + v2))) (sparseW, sparseW') 222 | ] 223 | ] 224 | , bgroup "fromList" 225 | [ bench "IntMap" $ whnf M.fromList elems 226 | , bench "WordMap" $ whnf W.fromList elems 227 | ] 228 | , bgroup "fromAscList" 229 | [ bench "IntMap" $ whnf M.fromAscList elems 230 | , bench "WordMap" $ whnf W.fromAscList elems 231 | ] 232 | , bgroup "fromDistinctAscList" 233 | [ bench "IntMap" $ whnf M.fromDistinctAscList elems 234 | , bench "WordMap" $ whnf W.fromDistinctAscList elems 235 | ] 236 | ] 237 | where 238 | elems = zip keys values 239 | keys = [1..2^12] 240 | values = [1..2^12] 241 | sElems = zip sKeys sValues 242 | sElemsSearch = zip sKeysSearch sValues 243 | sKeys = [1,3..2^12] 244 | sKeysSearch = [2,4..2^12] 245 | sValues = [1,3..2^12] 246 | 247 | {-# INLINE add3 #-} 248 | add3 :: Int -> Int -> Int -> Int 249 | add3 a b c = a + b + c 250 | -------------------------------------------------------------------------------- /benchmarks/IntSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Main where 4 | 5 | import Control.DeepSeq 6 | import Control.Exception (evaluate) 7 | import Criterion.Main 8 | import Data.List (foldl') 9 | import qualified Data.IntSet as S 10 | import qualified Data.WordSet as W 11 | import Data.Word (Word) 12 | 13 | main = do 14 | let s = S.fromAscList elems :: S.IntSet 15 | s_even = S.fromAscList elems_even :: S.IntSet 16 | s_odd = S.fromAscList elems_odd :: S.IntSet 17 | w = W.fromAscList elemsW :: W.WordSet 18 | w_even = W.fromAscList elemsW_even :: W.WordSet 19 | w_odd = W.fromAscList elemsW_odd :: W.WordSet 20 | evaluate $ rnf [s, s_even, s_odd] 21 | evaluate $ rnf [w, w_even, w_odd] 22 | defaultMain 23 | [ bgroup "member" 24 | [ bench "IntSet" $ whnf (member elems) s 25 | , bench "WordSet" $ whnf (memberW elemsW) w 26 | ] 27 | , bgroup "insert" 28 | [ bench "IntSet" $ whnf (ins elems) S.empty 29 | , bench "WordSet" $ whnf (insW elemsW) W.empty 30 | ] 31 | , bgroup "map" 32 | [ bench "IntSet" $ whnf (S.map (+ 1)) s 33 | , bench "WordSet" $ whnf (W.map (+ 1)) w 34 | ] 35 | , bgroup "filter" 36 | [ bench "IntSet" $ whnf (S.filter ((== 0) . (`mod` 2))) s 37 | , bench "WordSet" $ whnf (W.filter ((== 0) . (`mod` 2))) w 38 | ] 39 | , bgroup "partition" 40 | [ bench "IntSet" $ nf (S.partition ((== 0) . (`mod` 2))) s 41 | , bench "WordSet" $ nf (W.partition ((== 0) . (`mod` 2))) w 42 | ] 43 | , bgroup "foldr" 44 | [ bench "IntSet" $ whnf (S.foldr (+) 0) s 45 | , bench "WordSet" $ whnf (W.foldr (+) 0) w 46 | ] 47 | , bgroup "delete" 48 | [ bench "IntSet" $ whnf (del elems) s 49 | , bench "WordSet" $ whnf (delW elemsW) w 50 | ] 51 | , bgroup "findMin" 52 | [ bench "IntSet" $ whnf S.findMin s 53 | , bench "WordSet" $ whnf W.findMin w 54 | ] 55 | , bgroup "findMax" 56 | [ bench "IntSet" $ whnf S.findMax s 57 | , bench "WordSet" $ whnf W.findMax w 58 | ] 59 | , bgroup "deleteMin" 60 | [ bench "IntSet" $ whnf S.deleteMin s 61 | , bench "WordSet" $ whnf W.deleteMin w 62 | ] 63 | , bgroup "deleteMax" 64 | [ bench "IntSet" $ whnf S.deleteMax s 65 | , bench "WordSet" $ whnf W.deleteMax w 66 | ] 67 | , bgroup "unions" 68 | [ bench "IntSet" $ whnf S.unions [s_even, s_odd] 69 | , bench "WordSet" $ whnf W.unions [w_even, w_odd] 70 | ] 71 | , bgroup "union" 72 | [ bench "IntSet" $ whnf (S.union s_even) s_odd 73 | , bench "WordSet" $ whnf (W.union w_even) w_odd 74 | ] 75 | , bgroup "difference" 76 | [ bench "IntSet" $ whnf (S.difference s) s_even 77 | , bench "WordSet" $ whnf (W.difference w) w_even 78 | ] 79 | , bgroup "intersection" 80 | [ bench "IntSet" $ whnf (S.intersection s) s_even 81 | , bench "WordSet" $ whnf (W.intersection w) w_even 82 | ] 83 | , bgroup "fromList" 84 | [ bench "IntSet" $ whnf S.fromList elems 85 | , bench "WordSet" $ whnf W.fromList elemsW 86 | ] 87 | , bgroup "fromAscList" 88 | [ bench "IntSet" $ whnf S.fromAscList elems 89 | , bench "WordSet" $ whnf W.fromAscList elemsW 90 | ] 91 | , bgroup "fromDistinctAscList" 92 | [ bench "IntSet" $ whnf S.fromDistinctAscList elems 93 | , bench "WordSet" $ whnf W.fromDistinctAscList elemsW 94 | ] 95 | ] 96 | where 97 | elems = [1..2^12] 98 | elems_even = [2,4..2^12] 99 | elems_odd = [1,3..2^12] 100 | elemsW = [1..2^12] 101 | elemsW_even = [2,4..2^12] 102 | elemsW_odd = [1,3..2^12] 103 | 104 | member :: [Int] -> S.IntSet -> Int 105 | member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs 106 | 107 | memberW :: [Word] -> W.WordSet -> Int 108 | memberW xs s = foldl' (\n x -> if W.member x s then n + 1 else n) 0 xs 109 | 110 | ins :: [Int] -> S.IntSet -> S.IntSet 111 | ins xs s0 = foldl' (\s a -> S.insert a s) s0 xs 112 | 113 | insW :: [Word] -> W.WordSet -> W.WordSet 114 | insW xs s0 = foldl' (\s a -> W.insert a s) s0 xs 115 | 116 | del :: [Int] -> S.IntSet -> S.IntSet 117 | del xs s0 = foldl' (\s k -> S.delete k s) s0 xs 118 | 119 | delW :: [Word] -> W.WordSet -> W.WordSet 120 | delW xs s0 = foldl' (\s k -> W.delete k s) s0 xs 121 | -------------------------------------------------------------------------------- /bounded-intmap.cabal: -------------------------------------------------------------------------------- 1 | Name: bounded-intmap 2 | Version: 0.1 3 | Description: A reimplementation of `Data.IntMap` that uses minimum and maximum bounds on subtrees instread of bit prefixes. 4 | Author: Jonathan S 5 | License: MIT 6 | License-File: LICENSE 7 | Build-Type: Simple 8 | Cabal-Version: >=1.8 9 | 10 | library 11 | HS-Source-Dirs: src 12 | Build-Depends: base, deepseq, bits-extras, containers 13 | Exposed-modules: Data.WordMap, 14 | Data.WordMap.Base, 15 | Data.WordMap.Lazy, 16 | Data.WordMap.Strict, 17 | Data.WordMap.Merge.Base, 18 | Data.WordMap.Merge.Lazy, 19 | Data.WordMap.Merge.Strict, 20 | Data.WordSet, 21 | Data.WordSet.Internal, 22 | Data.IntMap.Bounded, 23 | Data.IntMap.Bounded.Base, 24 | Data.IntMap.Bounded.Lazy, 25 | Data.IntMap.Bounded.Strict 26 | Other-Modules: Data.StrictPair 27 | ghc-options: -Wall 28 | 29 | benchmark intmap 30 | Type: exitcode-stdio-1.0 31 | HS-Source-Dirs: benchmarks 32 | Main-Is: IntMapBench.hs 33 | Build-Depends: base, containers, deepseq, criterion, bounded-intmap 34 | ghc-options: -Wall 35 | 36 | benchmark intset 37 | Type: exitcode-stdio-1.0 38 | HS-Source-Dirs: benchmarks 39 | Main-Is: IntSet.hs 40 | Build-Depends: base, containers, deepseq, criterion, bounded-intmap 41 | ghc-options: -Wall 42 | 43 | test-suite wordmap 44 | Type: exitcode-stdio-1.0 45 | HS-Source-Dirs: tests 46 | Main-Is: WordMap.hs 47 | Build-Depends: base, tasty, QuickCheck, tasty-quickcheck, tasty-hunit, bounded-intmap 48 | GHC-Options: -Wall 49 | -------------------------------------------------------------------------------- /src/Data/IntMap/Bounded.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | A reimplementation of Data.IntMap in terms of Data.WordMap. 4 | 5 | module Data.IntMap.Bounded ( 6 | module Data.IntMap.Bounded.Lazy 7 | , insertWith' 8 | , insertWithKey' 9 | , fold 10 | , foldWithKey 11 | ) where 12 | 13 | import Prelude hiding (foldr) 14 | import Data.IntMap.Bounded.Lazy 15 | import qualified Data.IntMap.Bounded.Strict as S 16 | 17 | -- | /Deprecated./ As of version 0.5, replaced by 18 | -- 'Data.IntMap.Strict.insertWith'. 19 | -- 20 | -- /O(log n)/. Same as 'insertWith', but the result of the combining function 21 | -- is evaluated to WHNF before inserted to the map. 22 | {-# INLINE insertWith' #-} 23 | insertWith' :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 24 | insertWith' = S.insertWith 25 | 26 | -- | /Deprecated./ As of version 0.5, replaced by 27 | -- 'Data.IntMap.Strict.insertWithKey'. 28 | -- 29 | -- /O(log n)/. Same as 'insertWithKey', but the result of the combining 30 | -- function is evaluated to WHNF before inserted to the map. 31 | {-# INLINE insertWithKey' #-} 32 | insertWithKey' :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 33 | insertWithKey' = S.insertWithKey 34 | 35 | -- | /Deprecated./ As of version 0.5, replaced by 'foldr'. 36 | -- 37 | -- /O(n)/. Fold the values in the map using the given 38 | -- right-associative binary operator. This function is an equivalent 39 | -- of 'foldr' and is present for compatibility only. 40 | {-# INLINE fold #-} 41 | fold :: (a -> b -> b) -> b -> IntMap a -> b 42 | fold = foldr 43 | 44 | -- | /Deprecated./ As of version 0.5, replaced by 'foldrWithKey'. 45 | -- 46 | -- /O(n)/. Fold the keys and values in the map using the given 47 | -- right-associative binary operator. This function is an equivalent 48 | -- of 'foldrWithKey' and is present for compatibility only. 49 | {-# INLINE foldWithKey #-} 50 | foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b 51 | foldWithKey = foldrWithKey 52 | -------------------------------------------------------------------------------- /src/Data/IntMap/Bounded/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- TODO: Add some comments describing how this implementation works. 4 | 5 | -- | A reimplementation of Data.WordMap that seems to be 1.4-4x faster. 6 | 7 | module Data.IntMap.Bounded.Lazy ( 8 | -- * Map type 9 | IntMap, Key 10 | 11 | -- * Operators 12 | , (!) 13 | , (\\) 14 | 15 | -- * Query 16 | , null 17 | , size 18 | , member 19 | , notMember 20 | , lookup 21 | , findWithDefault 22 | , lookupLT 23 | , lookupGT 24 | , lookupLE 25 | , lookupGE 26 | 27 | -- * Construction 28 | , empty 29 | , singleton 30 | 31 | -- ** Insertion 32 | , insert 33 | , insertWith 34 | , insertWithKey 35 | , insertLookupWithKey 36 | 37 | -- ** Delete\/Update 38 | , delete 39 | , adjust 40 | , adjustWithKey 41 | , update 42 | , updateWithKey 43 | , updateLookupWithKey 44 | , alter 45 | , alterF 46 | 47 | -- * Combine 48 | -- ** Union 49 | , union 50 | , unionM 51 | , unionWith 52 | , unionWithM 53 | , unionWithKey 54 | , unions 55 | , unionsWith 56 | 57 | -- ** Difference 58 | , difference 59 | , differenceM 60 | , differenceWith 61 | , differenceWithKey 62 | 63 | -- ** Intersection 64 | , intersection 65 | , intersectionM 66 | , intersectionWith 67 | , intersectionWithM 68 | , intersectionWithKey 69 | 70 | -- ** Deprecated, unsafe general combining function 71 | , mergeWithKey 72 | 73 | -- * Traversal 74 | -- ** Map 75 | , map 76 | , mapWithKey 77 | , traverseWithKey 78 | , mapAccum 79 | , mapAccumWithKey 80 | , mapAccumRWithKey 81 | , mapKeys 82 | , mapKeysWith 83 | , mapKeysMonotonic 84 | 85 | -- ** Folds 86 | , foldr 87 | , foldl 88 | , foldrWithKey 89 | , foldlWithKey 90 | , foldMapWithKey 91 | 92 | -- ** Strict folds 93 | , foldr' 94 | , foldl' 95 | , foldrWithKey' 96 | , foldlWithKey' 97 | 98 | -- * Conversion 99 | , elems 100 | , keys 101 | , assocs 102 | , keysSet 103 | , fromSet 104 | 105 | -- ** Lists 106 | , toList 107 | , fromList 108 | , fromListWith 109 | , fromListWithKey 110 | 111 | -- ** Ordered Lists 112 | , toAscList 113 | , toDescList 114 | , fromAscList 115 | , fromAscListWith 116 | , fromAscListWithKey 117 | , fromDistinctAscList 118 | 119 | -- * Filter 120 | , filter 121 | , filterWithKey 122 | , restrictKeys 123 | , withoutKeys 124 | , partition 125 | , partitionWithKey 126 | , mapMaybe 127 | , mapMaybeWithKey 128 | , mapEither 129 | , mapEitherWithKey 130 | , split 131 | , splitLookup 132 | , splitRoot 133 | 134 | -- * Submap 135 | , isSubmapOf 136 | , isSubmapOfBy 137 | , isProperSubmapOf 138 | , isProperSubmapOfBy 139 | 140 | -- * Min\/Max 141 | , findMin 142 | , findMax 143 | , deleteMin 144 | , deleteMax 145 | , deleteFindMin 146 | , deleteFindMax 147 | , updateMin 148 | , updateMax 149 | , updateMinWithKey 150 | , updateMaxWithKey 151 | , minView 152 | , maxView 153 | , minViewWithKey 154 | , maxViewWithKey 155 | 156 | -- * Debugging 157 | , showTree 158 | , valid 159 | ) where 160 | 161 | import Data.Functor ((<$>)) 162 | import Control.Applicative (Applicative(..)) 163 | 164 | import Data.Bits (xor) 165 | 166 | import Data.IntMap.Bounded.Base 167 | 168 | import Data.WordMap.Base (WordMap(..), WordMap_(..), Node(..)) 169 | import qualified Data.WordMap.Lazy as W 170 | import qualified Data.WordMap.Merge.Lazy as WM 171 | 172 | import qualified Data.IntSet (IntSet, toList) 173 | 174 | import qualified Data.List (foldl', map) 175 | 176 | import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) 177 | 178 | -- | /O(1)/. A map of one element. 179 | singleton :: Key -> a -> IntMap a 180 | singleton k v = IntMap (W.singleton (i2w k) v) 181 | 182 | -- | /O(min(n,W))/. Insert a new key\/value pair in the map. 183 | -- If the key is already present in the map, the associated value 184 | -- is replaced with the supplied value. 185 | insert :: Key -> a -> IntMap a -> IntMap a 186 | insert k v (IntMap m) = IntMap (W.insert (i2w k) v m) 187 | 188 | -- | /O(min(n,W))/. Insert with a combining function. 189 | -- @'insertWith' f key value mp@ 190 | -- will insert the pair (key, value) into @mp@ if key does 191 | -- not exist in the map. If the key does exist, the function will 192 | -- insert @f new_value old_value@. 193 | -- 194 | -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] 195 | -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] 196 | -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" 197 | insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 198 | insertWith combine k v (IntMap m) = IntMap (W.insertWith combine (i2w k) v m) 199 | 200 | -- | /O(min(n,W))/. Insert with a combining function. 201 | -- @'insertWithKey' f key value mp@ 202 | -- will insert the pair (key, value) into @mp@ if key does 203 | -- not exist in the map. If the key does exist, the function will 204 | -- insert @f key new_value old_value@. 205 | -- 206 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 207 | -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] 208 | -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] 209 | -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" 210 | insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 211 | insertWithKey combine k v (IntMap m) = IntMap (W.insertWithKey (combine . w2i) (i2w k) v m) 212 | 213 | -- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) 214 | -- is a pair where the first element is equal to (@'lookup' k map@) 215 | -- and the second element equal to (@'insertWithKey' f k x map@). 216 | -- 217 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 218 | -- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) 219 | -- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) 220 | -- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") 221 | -- 222 | -- This is how to define @insertLookup@ using @insertLookupWithKey@: 223 | -- 224 | -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t 225 | -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) 226 | -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) 227 | insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) 228 | insertLookupWithKey combine k v (IntMap m) = 229 | let (mv, m') = W.insertLookupWithKey (combine . w2i) (i2w k) v m 230 | in mv `seq` m' `seq` (mv, IntMap m') 231 | 232 | -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not 233 | -- a member of the map, the original map is returned. 234 | -- 235 | -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] 236 | -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 237 | -- > adjust ("new " ++) 7 empty == empty 238 | adjust :: (a -> a) -> Key -> IntMap a -> IntMap a 239 | adjust f k (IntMap m) = IntMap (W.adjust f (i2w k) m) 240 | 241 | -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not 242 | -- a member of the map, the original map is returned. 243 | -- 244 | -- > let f key x = (show key) ++ ":new " ++ x 245 | -- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] 246 | -- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 247 | -- > adjustWithKey f 7 empty == empty 248 | adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a 249 | adjustWithKey f k (IntMap m) = IntMap (W.adjustWithKey (f . w2i) (i2w k) m) 250 | 251 | -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ 252 | -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is 253 | -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. 254 | -- 255 | -- > let f x = if x == "a" then Just "new a" else Nothing 256 | -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] 257 | -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 258 | -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 259 | update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a 260 | update f k (IntMap m) = IntMap (W.update f (i2w k) m) 261 | 262 | -- | /O(min(n,W))/. The expression (@'updateWithKey' f k map@) updates the value @x@ 263 | -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is 264 | -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. 265 | -- 266 | -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 267 | -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] 268 | -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 269 | -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 270 | updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a 271 | updateWithKey f k (IntMap m) = IntMap (W.updateWithKey (f . w2i) (i2w k) m) 272 | 273 | -- | /O(min(n,W))/. Lookup and update. 274 | -- The function returns original value, if it is updated. 275 | -- This is different behavior than 'Data.Map.updateLookupWithKey'. 276 | -- Returns the original key value if the map entry is deleted. 277 | -- 278 | -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 279 | -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) 280 | -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) 281 | -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") 282 | updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) 283 | updateLookupWithKey f k (IntMap m) = 284 | let (mv, m') = W.updateLookupWithKey (f . w2i) (i2w k) m 285 | in (mv, IntMap m') 286 | 287 | -- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. 288 | -- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. 289 | -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. 290 | alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a 291 | alter f k (IntMap m) = IntMap (W.alter f (i2w k) m) 292 | 293 | -- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at 294 | -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, 295 | -- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f 296 | -- ('lookup' k m)@. 297 | -- 298 | -- Example: 299 | -- 300 | -- @ 301 | -- interactiveAlter :: Int -> IntMap String -> IO (IntMap String) 302 | -- interactiveAlter k m = alterF f k m where 303 | -- f Nothing -> do 304 | -- putStrLn $ show k ++ 305 | -- " was not found in the map. Would you like to add it?" 306 | -- getUserResponse1 :: IO (Maybe String) 307 | -- f (Just old) -> do 308 | -- putStrLn "The key is currently bound to " ++ show old ++ 309 | -- ". Would you like to change or delete it?" 310 | -- getUserresponse2 :: IO (Maybe String) 311 | -- @ 312 | -- 313 | -- 'alterF' is the most general operation for working with an individual 314 | -- key that may or may not be in a given map. 315 | -- 316 | -- Note: 'alterF' is a flipped version of the 'at' combinator from 317 | -- 'Control.Lens.At'. 318 | -- 319 | -- @since 0.5.8 320 | alterF :: Functor f => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a) 321 | alterF f k (IntMap m) = fmap IntMap (W.alterF f (i2w k) m) 322 | 323 | -- | /O(n+m)/. The union with a combining function. 324 | -- 325 | -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] 326 | unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a 327 | unionWith f (IntMap m1) (IntMap m2) = IntMap (W.unionWith f m1 m2) 328 | 329 | -- | /O(n+m)/. The union with a combining function. 330 | -- 331 | -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value 332 | -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] 333 | unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a 334 | unionWithKey f (IntMap m1) (IntMap m2) = IntMap (W.unionWithKey (f . w2i) m1 m2) 335 | 336 | unionWithM :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a 337 | unionWithM f (IntMap m1) (IntMap m2) = IntMap (W.unionWithM (f . w2i) m1 m2) 338 | 339 | -- | The union of a list of maps, with a combining operation. 340 | -- 341 | -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] 342 | -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] 343 | unionsWith :: (a -> a -> a) -> [IntMap a] -> IntMap a 344 | unionsWith f = Data.List.foldl' (unionWith f) empty 345 | 346 | -- | /O(n+m)/. Difference with a combining function. 347 | -- 348 | -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing 349 | -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) 350 | -- > == singleton 3 "b:B" 351 | differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a 352 | differenceWith f (IntMap m1) (IntMap m2) = IntMap (W.differenceWith f m1 m2) 353 | 354 | -- | /O(n+m)/. Difference with a combining function. When two equal keys are 355 | -- encountered, the combining function is applied to the key and both values. 356 | -- If it returns 'Nothing', the element is discarded (proper set difference). 357 | -- If it returns (@'Just' y@), the element is updated with a new value @y@. 358 | -- 359 | -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing 360 | -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) 361 | -- > == singleton 3 "3:b|B" 362 | differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a 363 | differenceWithKey f (IntMap m1) (IntMap m2) = IntMap (W.differenceWithKey (f . w2i) m1 m2) 364 | 365 | -- | /O(n+m)/. The intersection with a combining function. 366 | -- 367 | -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" 368 | intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c 369 | intersectionWith f (IntMap m1) (IntMap m2) = IntMap (W.intersectionWith f m1 m2) 370 | 371 | -- | /O(n+m)/. The intersection with a combining function. 372 | -- 373 | -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar 374 | -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" 375 | intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c 376 | intersectionWithKey f (IntMap m1) (IntMap m2) = IntMap (W.intersectionWithKey (f . w2i) m1 m2) 377 | 378 | intersectionWithM :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c 379 | intersectionWithM f (IntMap m1) (IntMap m2) = IntMap (W.intersectionWithM (f . w2i) m1 m2) 380 | 381 | -- | /O(n+m)/. An unsafe general combining function. 382 | -- 383 | -- WARNING: This function can produce corrupt maps and its results 384 | -- may depend on the internal structures of its inputs. Users should 385 | -- prefer 'merge' or 'mergeA'. This function is also significantly slower 386 | -- than 'merge'. 387 | -- 388 | -- When 'mergeWithKey' is given three arguments, it is inlined to the call 389 | -- site. You should therefore use 'mergeWithKey' only to define custom 390 | -- combining functions. For example, you could define 'unionWithKey', 391 | -- 'differenceWithKey' and 'intersectionWithKey' as 392 | -- 393 | -- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 394 | -- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 395 | -- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2 396 | -- 397 | -- When calling @'mergeWithKey' combine only1 only2@, a function combining two 398 | -- 'IntMap's is created, such that 399 | -- 400 | -- * if a key is present in both maps, it is passed with both corresponding 401 | -- values to the @combine@ function. Depending on the result, the key is either 402 | -- present in the result with specified value, or is left out; 403 | -- 404 | -- * a nonempty subtree present only in the first map is passed to @only1@ and 405 | -- the output is added to the result; 406 | -- 407 | -- * a nonempty subtree present only in the second map is passed to @only2@ and 408 | -- the output is added to the result. 409 | -- 410 | -- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/. 411 | -- The values can be modified arbitrarily. Most common variants of @only1@ and 412 | -- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@, 413 | -- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@. 414 | mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) -> IntMap a -> IntMap b -> IntMap c 415 | mergeWithKey matched miss1 miss2 = start where 416 | start (IntMap m1) (IntMap m2) = IntMap (WM.merge (WM.mapMaybeMissing (single miss1)) (WM.mapMaybeMissing (single miss2)) (WM.zipWithMaybeMatched (matched . w2i)) m1 m2) 417 | 418 | single miss k v = case miss (IntMap (WordMap (NonEmpty k v Tip))) of 419 | IntMap (WordMap Empty) -> Nothing 420 | IntMap (WordMap (NonEmpty _ v' _)) -> Just v' 421 | 422 | -- | /O(n)/. Map a function over all values in the map. 423 | -- 424 | -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] 425 | map :: (a -> b) -> IntMap a -> IntMap b 426 | map f (IntMap m) = IntMap (W.map f m) 427 | 428 | -- | /O(n)/. Map a function over all values in the map. 429 | -- 430 | -- > let f key x = (show key) ++ ":" ++ x 431 | -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] 432 | mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b 433 | mapWithKey f (IntMap m) = IntMap (W.mapWithKey (f . w2i) m) 434 | 435 | -- | /O(n)/. 436 | -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ 437 | -- That is, behaves exactly like a regular 'traverse' except that the traversing 438 | -- function also has access to the key associated with a value. 439 | -- 440 | -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) 441 | -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing 442 | traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) 443 | traverseWithKey f = start 444 | where 445 | start (IntMap (WordMap Empty)) = pure (IntMap (WordMap Empty)) 446 | start (IntMap (WordMap (NonEmpty min minV Tip))) = (\minV' -> IntMap (WordMap (NonEmpty min minV' Tip))) <$> f (w2i min) minV 447 | start (IntMap (WordMap (NonEmpty min minV (Bin max maxV l r)))) 448 | | w2i (xor min max) < 0 = 449 | (\r' maxV' minV' l' -> IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 450 | <$> goR r <*> f (w2i max) maxV <*> f (w2i min) minV <*> goL l 451 | | otherwise = 452 | (\minV' l' r' maxV' -> IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 453 | <$> f (w2i min) minV <*> goL l <*> goR r <*> f (w2i max) maxV 454 | 455 | goL Tip = pure Tip 456 | goL (Bin max maxV l r) = (\l' r' v' -> Bin max v' l' r') <$> goL l <*> goR r <*> f (w2i max) maxV 457 | 458 | goR Tip = pure Tip 459 | goR (Bin min minV l r) = Bin min <$> f (w2i min) minV <*> goL l <*> goR r 460 | 461 | -- | /O(n)/. The function @'mapAccum'@ threads an accumulating 462 | -- argument through the map in ascending order of keys. 463 | -- 464 | -- > let f a b = (a ++ b, b ++ "X") 465 | -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) 466 | mapAccum :: (a -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) 467 | mapAccum f = mapAccumWithKey (\a _ x -> f a x) 468 | 469 | -- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating 470 | -- argument through the map in ascending order of keys. 471 | -- 472 | -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") 473 | -- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) 474 | mapAccumWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) 475 | mapAccumWithKey f = start 476 | where 477 | start a (IntMap (WordMap Empty)) = (a, IntMap (WordMap Empty)) 478 | start a (IntMap (WordMap (NonEmpty min minV Tip))) = 479 | let (a', minV') = f a (w2i min) minV 480 | in (a', IntMap (WordMap (NonEmpty min minV' Tip))) 481 | start a (IntMap (WordMap (NonEmpty min minV (Bin max maxV l r)))) 482 | | w2i (xor min max) < 0 = 483 | let (a', r') = goR r a 484 | (a'', maxV') = f a' (w2i max) maxV 485 | (a''', minV') = f a'' (w2i min) minV 486 | (a'''', l') = goL l a''' 487 | in (a'''', IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 488 | | otherwise = 489 | let (a', minV') = f a (w2i min) minV 490 | (a'', l') = goL l a' 491 | (a''', r') = goR r a'' 492 | (a'''', maxV') = f a''' (w2i max) maxV 493 | in (a'''', IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 494 | 495 | goL Tip a = (a, Tip) 496 | goL (Bin max maxV l r) a = 497 | let (a', l') = goL l a 498 | (a'', r') = goR r a' 499 | (a''', maxV') = f a'' (w2i max) maxV 500 | in (a''', Bin max maxV' l' r') 501 | 502 | goR Tip a = (a, Tip) 503 | goR (Bin min minV l r) a = 504 | let (a', minV') = f a (w2i min) minV 505 | (a'', l') = goL l a' 506 | (a''', r') = goR r a'' 507 | in (a''', Bin min minV' l' r') 508 | 509 | -- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating 510 | -- argument through the map in descending order of keys. 511 | mapAccumRWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) 512 | mapAccumRWithKey f = start 513 | where 514 | start a (IntMap (WordMap Empty)) = (a, IntMap (WordMap Empty)) 515 | start a (IntMap (WordMap (NonEmpty min minV Tip))) = 516 | let (a', minV') = f a (w2i min) minV 517 | in (a', IntMap (WordMap (NonEmpty min minV' Tip))) 518 | start a (IntMap (WordMap (NonEmpty min minV (Bin max maxV l r)))) 519 | | w2i (xor min max) < 0 = 520 | let (a', l') = goL l a 521 | (a'', minV') = f a' (w2i min) minV 522 | (a''', maxV') = f a'' (w2i max) maxV 523 | (a'''', r') = goR r a''' 524 | in (a'''', IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 525 | | otherwise = 526 | let (a', maxV') = f a (w2i max) maxV 527 | (a'', r') = goR r a' 528 | (a''', l') = goL l a'' 529 | (a'''', minV') = f a''' (w2i min) minV 530 | in (a'''', IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 531 | 532 | goL Tip a = (a, Tip) 533 | goL (Bin max maxV l r) a = 534 | let (a', maxV') = f a (w2i max) maxV 535 | (a'', r') = goR r a' 536 | (a''', l') = goL l a'' 537 | in (a''', Bin max maxV' l' r') 538 | 539 | goR Tip a = (a, Tip) 540 | goR (Bin min minV l r) a = 541 | let (a', r') = goR r a 542 | (a'', l') = goL l a' 543 | (a''', minV') = f a'' (w2i min) minV 544 | in (a''', Bin min minV' l' r') 545 | 546 | -- | /O(n*min(n,W))/. 547 | -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. 548 | -- 549 | -- The size of the result may be smaller if @f@ maps two or more distinct 550 | -- keys to the same new key. In this case the value at the greatest of the 551 | -- original keys is retained. 552 | -- 553 | -- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] 554 | -- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" 555 | -- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" 556 | mapKeys :: (Key -> Key) -> IntMap a -> IntMap a 557 | mapKeys f = foldlWithKey' (\m k a -> insert (f k) a m) empty 558 | 559 | -- | /O(n*min(n,W))/. 560 | -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. 561 | -- 562 | -- The size of the result may be smaller if @f@ maps two or more distinct 563 | -- keys to the same new key. In this case the associated values will be 564 | -- combined using @c@. 565 | -- 566 | -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" 567 | -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" 568 | mapKeysWith :: (a -> a -> a) -> (Key -> Key) -> IntMap a -> IntMap a 569 | mapKeysWith combine f = foldlWithKey' (\m k a -> insertWith combine (f k) a m) empty 570 | 571 | -- | /O(n*min(n,W))/. 572 | -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ 573 | -- is strictly monotonic. 574 | -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. 575 | -- /The precondition is not checked./ 576 | -- Semi-formally, we have: 577 | -- 578 | -- > and [x < y ==> f x < f y | x <- ls, y <- ls] 579 | -- > ==> mapKeysMonotonic f s == mapKeys f s 580 | -- > where ls = keys s 581 | -- 582 | -- This means that @f@ maps distinct original keys to distinct resulting keys. 583 | -- This function has slightly better performance than 'mapKeys'. 584 | -- 585 | -- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] 586 | mapKeysMonotonic :: (Key -> Key) -> IntMap a -> IntMap a 587 | mapKeysMonotonic = mapKeys 588 | 589 | -- | /O(n)/. Build a map from a set of keys and a function which for each key 590 | -- computes its value. 591 | -- 592 | -- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] 593 | -- > fromSet undefined Data.IntSet.empty == empty 594 | fromSet :: (Key -> a) -> Data.IntSet.IntSet -> IntMap a 595 | fromSet f = fromDistinctAscList . Data.List.map (\k -> (k, f k)) . Data.IntSet.toList 596 | 597 | -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. 598 | fromList :: [(Key, a)] -> IntMap a 599 | fromList = Data.List.foldl' (\t (k, a) -> insert k a t) empty 600 | 601 | -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. 602 | -- 603 | -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] 604 | -- > fromListWith (++) [] == empty 605 | fromListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a 606 | fromListWith f = Data.List.foldl' (\t (k, a) -> insertWith f k a t) empty 607 | 608 | -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. 609 | -- 610 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 611 | -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] 612 | -- > fromListWithKey f [] == empty 613 | fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a 614 | fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty 615 | 616 | -- TODO: Use the ordering 617 | 618 | -- | /O(n)/. Build a map from a list of key\/value pairs where 619 | -- the keys are in ascending order. 620 | -- 621 | -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] 622 | -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] 623 | fromAscList :: [(Key, a)] -> IntMap a 624 | fromAscList = fromList 625 | 626 | -- | /O(n)/. Build a map from a list of key\/value pairs where 627 | -- the keys are in ascending order. 628 | -- 629 | -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] 630 | -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] 631 | fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a 632 | fromAscListWith = fromListWith 633 | 634 | -- | /O(n)/. Build a map from a list of key\/value pairs where 635 | -- the keys are in ascending order, with a combining function on equal keys. 636 | -- /The precondition (input list is ascending) is not checked./ 637 | -- 638 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 639 | -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] 640 | fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a 641 | fromAscListWithKey = fromListWithKey 642 | 643 | -- | /O(n)/. Build a map from a list of key\/value pairs where 644 | -- the keys are in ascending order and all distinct. 645 | -- /The precondition (input list is strictly ascending) is not checked./ 646 | -- 647 | -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] 648 | fromDistinctAscList :: [(Key, a)] -> IntMap a 649 | fromDistinctAscList = fromList 650 | 651 | -- | /O(n)/. Map values and collect the 'Just' results. 652 | -- 653 | -- > let f x = if x == "a" then Just "new a" else Nothing 654 | -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" 655 | mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b 656 | mapMaybe f (IntMap m) = IntMap (W.mapMaybe f m) 657 | 658 | -- | /O(n)/. Map keys\/values and collect the 'Just' results. 659 | -- 660 | -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing 661 | -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" 662 | mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b 663 | mapMaybeWithKey f (IntMap m) = IntMap (W.mapMaybeWithKey (f . w2i) m) 664 | 665 | -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. 666 | -- 667 | -- > let f a = if a < "c" then Left a else Right a 668 | -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 669 | -- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) 670 | -- > 671 | -- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 672 | -- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 673 | mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) 674 | mapEither f (IntMap m) = let (m1, m2) = W.mapEither f m in (IntMap m1, IntMap m2) 675 | 676 | -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. 677 | -- 678 | -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) 679 | -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 680 | -- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) 681 | -- > 682 | -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 683 | -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) 684 | mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) 685 | mapEitherWithKey f (IntMap m) = let (m1, m2) = W.mapEitherWithKey (f . w2i) m in (IntMap m1, IntMap m2) 686 | 687 | -- | /O(min(n,W))/. Update the value at the minimal key. 688 | -- 689 | -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] 690 | -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 691 | updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a 692 | updateMin _ (IntMap (WordMap Empty)) = IntMap (WordMap Empty) 693 | updateMin f m = update f (fst (findMin m)) m 694 | 695 | -- | /O(min(n,W))/. Update the value at the maximal key. 696 | -- 697 | -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] 698 | -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" 699 | updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a 700 | updateMax _ (IntMap (WordMap Empty)) = IntMap (WordMap Empty) 701 | updateMax f m = update f (fst (findMax m)) m 702 | 703 | -- | /O(min(n,W))/. Update the value at the minimal key. 704 | -- 705 | -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] 706 | -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 707 | updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a 708 | updateMinWithKey _ (IntMap (WordMap Empty)) = IntMap (WordMap Empty) 709 | updateMinWithKey f m = updateWithKey f (fst (findMin m)) m 710 | 711 | -- | /O(min(n,W))/. Update the value at the maximal key. 712 | -- 713 | -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] 714 | -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" 715 | updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a 716 | updateMaxWithKey _ (IntMap (WordMap Empty)) = IntMap (WordMap Empty) 717 | updateMaxWithKey f m = updateWithKey f (fst (findMax m)) m 718 | -------------------------------------------------------------------------------- /src/Data/IntMap/Bounded/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- TODO: Add some comments describing how this implementation works. 4 | 5 | -- | A reimplementation of Data.WordMap that seems to be 1.4-4x faster. 6 | 7 | module Data.IntMap.Bounded.Strict ( 8 | -- * Map type 9 | IntMap, Key 10 | 11 | -- * Operators 12 | , (!) 13 | , (\\) 14 | 15 | -- * Query 16 | , null 17 | , size 18 | , member 19 | , notMember 20 | , lookup 21 | , findWithDefault 22 | , lookupLT 23 | , lookupGT 24 | , lookupLE 25 | , lookupGE 26 | 27 | -- * Construction 28 | , empty 29 | , singleton 30 | 31 | -- ** Insertion 32 | , insert 33 | , insertWith 34 | , insertWithKey 35 | , insertLookupWithKey 36 | 37 | -- ** Delete\/Update 38 | , delete 39 | , adjust 40 | , adjustWithKey 41 | , update 42 | , updateWithKey 43 | , updateLookupWithKey 44 | , alter 45 | , alterF 46 | 47 | -- * Combine 48 | -- ** Union 49 | , union 50 | , unionWith 51 | , unionWithKey 52 | , unions 53 | , unionsWith 54 | 55 | -- ** Difference 56 | , difference 57 | , differenceWith 58 | , differenceWithKey 59 | 60 | -- ** Intersection 61 | , intersection 62 | , intersectionWith 63 | , intersectionWithKey 64 | 65 | -- ** Deprecated, unsafe general combining function 66 | , mergeWithKey 67 | 68 | -- * Traversal 69 | -- ** Map 70 | , map 71 | , mapWithKey 72 | , traverseWithKey 73 | , mapAccum 74 | , mapAccumWithKey 75 | , mapAccumRWithKey 76 | , mapKeys 77 | , mapKeysWith 78 | , mapKeysMonotonic 79 | 80 | -- ** Folds 81 | , foldr 82 | , foldl 83 | , foldrWithKey 84 | , foldlWithKey 85 | , foldMapWithKey 86 | 87 | -- ** Strict folds 88 | , foldr' 89 | , foldl' 90 | , foldrWithKey' 91 | , foldlWithKey' 92 | 93 | -- * Conversion 94 | , elems 95 | , keys 96 | , assocs 97 | , keysSet 98 | , fromSet 99 | 100 | -- ** Lists 101 | , toList 102 | , fromList 103 | , fromListWith 104 | , fromListWithKey 105 | 106 | -- ** Ordered Lists 107 | , toAscList 108 | , toDescList 109 | , fromAscList 110 | , fromAscListWith 111 | , fromAscListWithKey 112 | , fromDistinctAscList 113 | 114 | -- * Filter 115 | , filter 116 | , filterWithKey 117 | , restrictKeys 118 | , withoutKeys 119 | , partition 120 | , partitionWithKey 121 | , mapMaybe 122 | , mapMaybeWithKey 123 | , mapEither 124 | , mapEitherWithKey 125 | , split 126 | , splitLookup 127 | , splitRoot 128 | 129 | -- * Submap 130 | , isSubmapOf 131 | , isSubmapOfBy 132 | , isProperSubmapOf 133 | , isProperSubmapOfBy 134 | 135 | -- * Min\/Max 136 | , findMin 137 | , findMax 138 | , deleteMin 139 | , deleteMax 140 | , deleteFindMin 141 | , deleteFindMax 142 | , updateMin 143 | , updateMax 144 | , updateMinWithKey 145 | , updateMaxWithKey 146 | , minView 147 | , maxView 148 | , minViewWithKey 149 | , maxViewWithKey 150 | 151 | -- * Debugging 152 | , showTree 153 | , valid 154 | ) where 155 | 156 | import Data.Functor ((<$>)) 157 | import Control.Applicative (Applicative(..)) 158 | 159 | import Data.Bits (xor) 160 | 161 | import Data.IntMap.Bounded.Base 162 | 163 | import Data.WordMap.Base (WordMap(..), WordMap_(..), Node(..)) 164 | import qualified Data.WordMap.Strict as W 165 | import qualified Data.WordMap.Merge.Strict as WM 166 | 167 | import qualified Data.IntSet (IntSet, toList) 168 | 169 | import qualified Data.List (foldl', map) 170 | 171 | import Prelude hiding (foldr, foldl, lookup, null, map, filter, min, max) 172 | 173 | -- | /O(1)/. A map of one element. 174 | singleton :: Key -> a -> IntMap a 175 | singleton k v = IntMap (W.singleton (i2w k) v) 176 | 177 | -- | /O(min(n,W))/. Insert a new key\/value pair in the map. 178 | -- If the key is already present in the map, the associated value 179 | -- is replaced with the supplied value. 180 | insert :: Key -> a -> IntMap a -> IntMap a 181 | insert k v (IntMap m) = IntMap (W.insert (i2w k) v m) 182 | 183 | -- | /O(min(n,W))/. Insert with a combining function. 184 | -- @'insertWith' f key value mp@ 185 | -- will insert the pair (key, value) into @mp@ if key does 186 | -- not exist in the map. If the key does exist, the function will 187 | -- insert @f new_value old_value@. 188 | -- 189 | -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] 190 | -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] 191 | -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" 192 | insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 193 | insertWith combine k v (IntMap m) = IntMap (W.insertWith combine (i2w k) v m) 194 | 195 | -- | /O(min(n,W))/. Insert with a combining function. 196 | -- @'insertWithKey' f key value mp@ 197 | -- will insert the pair (key, value) into @mp@ if key does 198 | -- not exist in the map. If the key does exist, the function will 199 | -- insert @f key new_value old_value@. 200 | -- 201 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 202 | -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] 203 | -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] 204 | -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" 205 | insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a 206 | insertWithKey combine k v (IntMap m) = IntMap (W.insertWithKey (combine . w2i) (i2w k) v m) 207 | 208 | -- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@) 209 | -- is a pair where the first element is equal to (@'lookup' k map@) 210 | -- and the second element equal to (@'insertWithKey' f k x map@). 211 | -- 212 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 213 | -- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) 214 | -- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) 215 | -- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx") 216 | -- 217 | -- This is how to define @insertLookup@ using @insertLookupWithKey@: 218 | -- 219 | -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t 220 | -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) 221 | -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) 222 | insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) 223 | insertLookupWithKey combine k v (IntMap m) = 224 | let (mv, m') = W.insertLookupWithKey (combine . w2i) (i2w k) v m 225 | in mv `seq` m' `seq` (mv, IntMap m') 226 | 227 | -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not 228 | -- a member of the map, the original map is returned. 229 | -- 230 | -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] 231 | -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 232 | -- > adjust ("new " ++) 7 empty == empty 233 | adjust :: (a -> a) -> Key -> IntMap a -> IntMap a 234 | adjust f k (IntMap m) = IntMap (W.adjust f (i2w k) m) 235 | 236 | -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not 237 | -- a member of the map, the original map is returned. 238 | -- 239 | -- > let f key x = (show key) ++ ":new " ++ x 240 | -- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] 241 | -- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 242 | -- > adjustWithKey f 7 empty == empty 243 | adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a 244 | adjustWithKey f k (IntMap m) = IntMap (W.adjustWithKey (f . w2i) (i2w k) m) 245 | 246 | -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ 247 | -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is 248 | -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. 249 | -- 250 | -- > let f x = if x == "a" then Just "new a" else Nothing 251 | -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")] 252 | -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 253 | -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 254 | update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a 255 | update f k (IntMap m) = IntMap (W.update f (i2w k) m) 256 | 257 | -- | /O(min(n,W))/. The expression (@'updateWithKey' f k map@) updates the value @x@ 258 | -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is 259 | -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. 260 | -- 261 | -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 262 | -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")] 263 | -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")] 264 | -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 265 | updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a 266 | updateWithKey f k (IntMap m) = IntMap (W.updateWithKey (f . w2i) (i2w k) m) 267 | 268 | -- | /O(min(n,W))/. Lookup and update. 269 | -- The function returns original value, if it is updated. 270 | -- This is different behavior than 'Data.Map.updateLookupWithKey'. 271 | -- Returns the original key value if the map entry is deleted. 272 | -- 273 | -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 274 | -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")]) 275 | -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")]) 276 | -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") 277 | updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) 278 | updateLookupWithKey f k (IntMap m) = 279 | let (mv, m') = W.updateLookupWithKey (f . w2i) (i2w k) m 280 | in (mv, IntMap m') 281 | 282 | -- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. 283 | -- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. 284 | -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. 285 | alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a 286 | alter f k (IntMap m) = IntMap (W.alter f (i2w k) m) 287 | 288 | -- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at 289 | -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete, 290 | -- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f 291 | -- ('lookup' k m)@. 292 | -- 293 | -- Example: 294 | -- 295 | -- @ 296 | -- interactiveAlter :: Int -> IntMap String -> IO (IntMap String) 297 | -- interactiveAlter k m = alterF f k m where 298 | -- f Nothing -> do 299 | -- putStrLn $ show k ++ 300 | -- " was not found in the map. Would you like to add it?" 301 | -- getUserResponse1 :: IO (Maybe String) 302 | -- f (Just old) -> do 303 | -- putStrLn "The key is currently bound to " ++ show old ++ 304 | -- ". Would you like to change or delete it?" 305 | -- getUserresponse2 :: IO (Maybe String) 306 | -- @ 307 | -- 308 | -- 'alterF' is the most general operation for working with an individual 309 | -- key that may or may not be in a given map. 310 | -- 311 | -- Note: 'alterF' is a flipped version of the 'at' combinator from 312 | -- 'Control.Lens.At'. 313 | -- 314 | -- @since 0.5.8 315 | alterF :: Functor f => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a) 316 | alterF f k (IntMap m) = fmap IntMap (W.alterF f (i2w k) m) 317 | 318 | -- | /O(n+m)/. The union with a combining function. 319 | -- 320 | -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] 321 | unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a 322 | unionWith f (IntMap m1) (IntMap m2) = IntMap (W.unionWith f m1 m2) 323 | 324 | -- | /O(n+m)/. The union with a combining function. 325 | -- 326 | -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value 327 | -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")] 328 | unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a 329 | unionWithKey f (IntMap m1) (IntMap m2) = IntMap (W.unionWithKey (f . w2i) m1 m2) 330 | 331 | -- | The union of a list of maps, with a combining operation. 332 | -- 333 | -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] 334 | -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] 335 | unionsWith :: (a -> a -> a) -> [IntMap a] -> IntMap a 336 | unionsWith f = Data.List.foldl' (unionWith f) empty 337 | 338 | -- | /O(n+m)/. Difference with a combining function. 339 | -- 340 | -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing 341 | -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) 342 | -- > == singleton 3 "b:B" 343 | differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a 344 | differenceWith f (IntMap m1) (IntMap m2) = IntMap (W.differenceWith f m1 m2) 345 | 346 | -- | /O(n+m)/. Difference with a combining function. When two equal keys are 347 | -- encountered, the combining function is applied to the key and both values. 348 | -- If it returns 'Nothing', the element is discarded (proper set difference). 349 | -- If it returns (@'Just' y@), the element is updated with a new value @y@. 350 | -- 351 | -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing 352 | -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) 353 | -- > == singleton 3 "3:b|B" 354 | differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a 355 | differenceWithKey f (IntMap m1) (IntMap m2) = IntMap (W.differenceWithKey (f . w2i) m1 m2) 356 | 357 | -- | /O(n+m)/. The intersection with a combining function. 358 | -- 359 | -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" 360 | intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c 361 | intersectionWith f (IntMap m1) (IntMap m2) = IntMap (W.intersectionWith f m1 m2) 362 | 363 | -- | /O(n+m)/. The intersection with a combining function. 364 | -- 365 | -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar 366 | -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A" 367 | intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c 368 | intersectionWithKey f (IntMap m1) (IntMap m2) = IntMap (W.intersectionWithKey (f . w2i) m1 m2) 369 | 370 | -- | /O(n+m)/. An unsafe general combining function. 371 | -- 372 | -- WARNING: This function can produce corrupt maps and its results 373 | -- may depend on the internal structures of its inputs. Users should 374 | -- prefer 'merge' or 'mergeA'. This function is also significantly slower 375 | -- than 'merge'. 376 | -- 377 | -- When 'mergeWithKey' is given three arguments, it is inlined to the call 378 | -- site. You should therefore use 'mergeWithKey' only to define custom 379 | -- combining functions. For example, you could define 'unionWithKey', 380 | -- 'differenceWithKey' and 'intersectionWithKey' as 381 | -- 382 | -- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2 383 | -- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2 384 | -- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1$ 385 | -- 386 | -- When calling @'mergeWithKey' combine only1 only2@, a function combining two 387 | -- 'IntMap's is created, such that 388 | -- 389 | -- * if a key is present in both maps, it is passed with both corresponding 390 | -- values to the @combine@ function. Depending on the result, the key is either 391 | -- present in the result with specified value, or is left out; 392 | -- 393 | -- * a nonempty subtree present only in the first map is passed to @only1@ and 394 | -- the output is added to the result; 395 | -- 396 | -- * a nonempty subtree present only in the second map is passed to @only2@ and 397 | -- the output is added to the result. 398 | -- 399 | -- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given m$ 400 | -- The values can be modified arbitrarily. Most common variants of @only1@ and 401 | -- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@, 402 | -- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@. 403 | mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c) -> IntMap a -> IntMap b -> IntMap c 404 | mergeWithKey matched miss1 miss2 = start where 405 | start (IntMap m1) (IntMap m2) = IntMap (WM.merge (WM.mapMaybeMissing (single miss1)) (WM.mapMaybeMissing (single miss2)) (WM.zipWithMaybeMatched (matched . w2i)) m1 m2) 406 | 407 | single miss k v = case miss (IntMap (WordMap (NonEmpty k v Tip))) of 408 | IntMap (WordMap Empty) -> Nothing 409 | IntMap (WordMap (NonEmpty _ v' _)) -> Just v' 410 | 411 | -- | /O(n)/. Map a function over all values in the map. 412 | -- 413 | -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] 414 | map :: (a -> b) -> IntMap a -> IntMap b 415 | map f (IntMap m) = IntMap (W.map f m) 416 | 417 | -- | /O(n)/. Map a function over all values in the map. 418 | -- 419 | -- > let f key x = (show key) ++ ":" ++ x 420 | -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] 421 | mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b 422 | mapWithKey f (IntMap m) = IntMap (W.mapWithKey (f . w2i) m) 423 | 424 | -- | /O(n)/. 425 | -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ 426 | -- That is, behaves exactly like a regular 'traverse' except that the traversing 427 | -- function also has access to the key associated with a value. 428 | -- 429 | -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')]) 430 | -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing 431 | traverseWithKey :: Applicative f => (Key -> a -> f b) -> IntMap a -> f (IntMap b) 432 | traverseWithKey f = start 433 | where 434 | start (IntMap (WordMap Empty)) = pure (IntMap (WordMap Empty)) 435 | start (IntMap (WordMap (NonEmpty min minV Tip))) = (\(!minV') -> IntMap (WordMap (NonEmpty min minV' Tip))) <$> f (w2i min) minV 436 | start (IntMap (WordMap (NonEmpty min minV (Bin max maxV l r)))) 437 | | w2i (xor min max) < 0 = 438 | (\r' (!maxV') (!minV') l' -> IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 439 | <$> goR r <*> f (w2i max) maxV <*> f (w2i min) minV <*> goL l 440 | | otherwise = 441 | (\(!minV') l' r' (!maxV') -> IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 442 | <$> f (w2i min) minV <*> goL l <*> goR r <*> f (w2i max) maxV 443 | 444 | goL Tip = pure Tip 445 | goL (Bin max maxV l r) = (\l' r' (!v') -> Bin max v' l' r') <$> goL l <*> goR r <*> f (w2i max) maxV 446 | 447 | goR Tip = pure Tip 448 | goR (Bin min minV l r) = (\(!v') l' r' -> Bin min v' l' r') <$> f (w2i min) minV <*> goL l <*> goR r 449 | 450 | -- | /O(n)/. The function @'mapAccum'@ threads an accumulating 451 | -- argument through the map in ascending order of keys. 452 | -- 453 | -- > let f a b = (a ++ b, b ++ "X") 454 | -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) 455 | mapAccum :: (a -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) 456 | mapAccum f = mapAccumWithKey (\a _ x -> f a x) 457 | 458 | -- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating 459 | -- argument through the map in ascending order of keys. 460 | -- 461 | -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") 462 | -- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) 463 | mapAccumWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) 464 | mapAccumWithKey f = start 465 | where 466 | start a (IntMap (WordMap Empty)) = (a, IntMap (WordMap Empty)) 467 | start a (IntMap (WordMap (NonEmpty min minV Tip))) = 468 | let (a', !minV') = f a (w2i min) minV 469 | in (a', IntMap (WordMap (NonEmpty min minV' Tip))) 470 | start a (IntMap (WordMap (NonEmpty min minV (Bin max maxV l r)))) 471 | | w2i (xor min max) < 0 = 472 | let (a', r') = goR r a 473 | (a'', !maxV') = f a' (w2i max) maxV 474 | (a''', !minV') = f a'' (w2i min) minV 475 | (a'''', l') = goL l a''' 476 | in (a'''', IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 477 | | otherwise = 478 | let (a', !minV') = f a (w2i min) minV 479 | (a'', l') = goL l a' 480 | (a''', r') = goR r a'' 481 | (a'''',!maxV') = f a''' (w2i max) maxV 482 | in (a'''', IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 483 | 484 | goL Tip a = (a, Tip) 485 | goL (Bin max maxV l r) a = 486 | let (a', l') = goL l a 487 | (a'', r') = goR r a' 488 | (a''',!maxV') = f a'' (w2i max) maxV 489 | in (a''', Bin max maxV' l' r') 490 | 491 | goR Tip a = (a, Tip) 492 | goR (Bin min minV l r) a = 493 | let (a', !minV') = f a (w2i min) minV 494 | (a'', l') = goL l a' 495 | (a''', r') = goR r a'' 496 | in (a''', Bin min minV' l' r') 497 | 498 | -- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating 499 | -- argument through the map in descending order of keys. 500 | mapAccumRWithKey :: (a -> Key -> b -> (a, c)) -> a -> IntMap b -> (a, IntMap c) 501 | mapAccumRWithKey f = start 502 | where 503 | start a (IntMap (WordMap Empty)) = (a, IntMap (WordMap Empty)) 504 | start a (IntMap (WordMap (NonEmpty min minV Tip))) = 505 | let (a', !minV') = f a (w2i min) minV 506 | in (a', IntMap (WordMap (NonEmpty min minV' Tip))) 507 | start a (IntMap (WordMap (NonEmpty min minV (Bin max maxV l r)))) 508 | | w2i (xor min max) < 0 = 509 | let (a', l') = goL l a 510 | (a'', !minV') = f a' (w2i min) minV 511 | (a''', !maxV') = f a'' (w2i max) maxV 512 | (a'''', r') = goR r a''' 513 | in (a'''', IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 514 | | otherwise = 515 | let (a', !maxV') = f a (w2i max) maxV 516 | (a'', r') = goR r a' 517 | (a''', l') = goL l a'' 518 | (a'''',!minV') = f a''' (w2i min) minV 519 | in (a'''', IntMap (WordMap (NonEmpty min minV' (Bin max maxV' l' r')))) 520 | 521 | goL Tip a = (a, Tip) 522 | goL (Bin max maxV l r) a = 523 | let (a', !maxV') = f a (w2i max) maxV 524 | (a'', r') = goR r a' 525 | (a''', l') = goL l a'' 526 | in (a''', Bin max maxV' l' r') 527 | 528 | goR Tip a = (a, Tip) 529 | goR (Bin min minV l r) a = 530 | let (a', r') = goR r a 531 | (a'', l') = goL l a' 532 | (a''',!minV') = f a'' (w2i min) minV 533 | in (a''', Bin min minV' l' r') 534 | 535 | -- | /O(n*min(n,W))/. 536 | -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. 537 | -- 538 | -- The size of the result may be smaller if @f@ maps two or more distinct 539 | -- keys to the same new key. In this case the value at the greatest of the 540 | -- original keys is retained. 541 | -- 542 | -- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")] 543 | -- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c" 544 | -- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c" 545 | mapKeys :: (Key -> Key) -> IntMap a -> IntMap a 546 | mapKeys f = foldlWithKey' (\m k a -> insert (f k) a m) empty 547 | 548 | -- | /O(n*min(n,W))/. 549 | -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. 550 | -- 551 | -- The size of the result may be smaller if @f@ maps two or more distinct 552 | -- keys to the same new key. In this case the associated values will be 553 | -- combined using @c@. 554 | -- 555 | -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" 556 | -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab" 557 | mapKeysWith :: (a -> a -> a) -> (Key -> Key) -> IntMap a -> IntMap a 558 | mapKeysWith combine f = foldlWithKey' (\m k a -> insertWith combine (f k) a m) empty 559 | 560 | -- | /O(n*min(n,W))/. 561 | -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ 562 | -- is strictly monotonic. 563 | -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. 564 | -- /The precondition is not checked./ 565 | -- Semi-formally, we have: 566 | -- 567 | -- > and [x < y ==> f x < f y | x <- ls, y <- ls] 568 | -- > ==> mapKeysMonotonic f s == mapKeys f s 569 | -- > where ls = keys s 570 | -- 571 | -- This means that @f@ maps distinct original keys to distinct resulting keys. 572 | -- This function has slightly better performance than 'mapKeys'. 573 | -- 574 | -- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")] 575 | mapKeysMonotonic :: (Key -> Key) -> IntMap a -> IntMap a 576 | mapKeysMonotonic = mapKeys 577 | 578 | -- | /O(n)/. Build a map from a set of keys and a function which for each key 579 | -- computes its value. 580 | -- 581 | -- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")] 582 | -- > fromSet undefined Data.IntSet.empty == empty 583 | fromSet :: (Key -> a) -> Data.IntSet.IntSet -> IntMap a 584 | fromSet f = fromDistinctAscList . Data.List.map (\k -> (k, f k)) . Data.IntSet.toList 585 | 586 | -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. 587 | fromList :: [(Key, a)] -> IntMap a 588 | fromList = Data.List.foldl' (\t (k, a) -> insert k a t) empty 589 | 590 | -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. 591 | -- 592 | -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")] 593 | -- > fromListWith (++) [] == empty 594 | fromListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a 595 | fromListWith f = Data.List.foldl' (\t (k, a) -> insertWith f k a t) empty 596 | 597 | -- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. 598 | -- 599 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 600 | -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] 601 | -- > fromListWithKey f [] == empty 602 | fromListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a 603 | fromListWithKey f = Data.List.foldl' (\t (k, a) -> insertWithKey f k a t) empty 604 | 605 | -- TODO: Use the ordering 606 | 607 | -- | /O(n)/. Build a map from a list of key\/value pairs where 608 | -- the keys are in ascending order. 609 | -- 610 | -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] 611 | -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] 612 | fromAscList :: [(Key, a)] -> IntMap a 613 | fromAscList = fromList 614 | 615 | -- | /O(n)/. Build a map from a list of key\/value pairs where 616 | -- the keys are in ascending order. 617 | -- 618 | -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] 619 | -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] 620 | fromAscListWith :: (a -> a -> a) -> [(Key, a)] -> IntMap a 621 | fromAscListWith = fromListWith 622 | 623 | -- | /O(n)/. Build a map from a list of key\/value pairs where 624 | -- the keys are in ascending order, with a combining function on equal keys. 625 | -- /The precondition (input list is ascending) is not checked./ 626 | -- 627 | -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 628 | -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] 629 | fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key, a)] -> IntMap a 630 | fromAscListWithKey = fromListWithKey 631 | 632 | -- | /O(n)/. Build a map from a list of key\/value pairs where 633 | -- the keys are in ascending order and all distinct. 634 | -- /The precondition (input list is strictly ascending) is not checked./ 635 | -- 636 | -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] 637 | fromDistinctAscList :: [(Key, a)] -> IntMap a 638 | fromDistinctAscList = fromList 639 | 640 | -- | /O(n)/. Map values and collect the 'Just' results. 641 | -- 642 | -- > let f x = if x == "a" then Just "new a" else Nothing 643 | -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" 644 | mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b 645 | mapMaybe f (IntMap m) = IntMap (W.mapMaybe f m) 646 | 647 | -- | /O(n)/. Map keys\/values and collect the 'Just' results. 648 | -- 649 | -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing 650 | -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" 651 | mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b 652 | mapMaybeWithKey f (IntMap m) = IntMap (W.mapMaybeWithKey (f . w2i) m) 653 | 654 | -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. 655 | -- 656 | -- > let f a = if a < "c" then Left a else Right a 657 | -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 658 | -- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) 659 | -- > 660 | -- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 661 | -- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 662 | mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) 663 | mapEither f (IntMap m) = let (m1, m2) = W.mapEither f m in (IntMap m1, IntMap m2) 664 | 665 | -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. 666 | -- 667 | -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) 668 | -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 669 | -- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) 670 | -- > 671 | -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 672 | -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) 673 | mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) 674 | mapEitherWithKey f (IntMap m) = let (m1, m2) = W.mapEitherWithKey (f . w2i) m in (IntMap m1, IntMap m2) 675 | 676 | -- | /O(min(n,W))/. Update the value at the minimal key. 677 | -- 678 | -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] 679 | -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 680 | updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a 681 | updateMin _ (IntMap (WordMap Empty)) = IntMap (WordMap Empty) 682 | updateMin f m = update f (fst (findMin m)) m 683 | 684 | -- | /O(min(n,W))/. Update the value at the maximal key. 685 | -- 686 | -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] 687 | -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" 688 | updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a 689 | updateMax _ (IntMap (WordMap Empty)) = IntMap (WordMap Empty) 690 | updateMax f m = update f (fst (findMax m)) m 691 | 692 | -- | /O(min(n,W))/. Update the value at the minimal key. 693 | -- 694 | -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] 695 | -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" 696 | updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a 697 | updateMinWithKey _ (IntMap (WordMap Empty)) = IntMap (WordMap Empty) 698 | updateMinWithKey f m = updateWithKey f (fst (findMin m)) m 699 | 700 | -- | /O(min(n,W))/. Update the value at the maximal key. 701 | -- 702 | -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] 703 | -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" 704 | updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a 705 | updateMaxWithKey _ (IntMap (WordMap Empty)) = IntMap (WordMap Empty) 706 | updateMaxWithKey f m = updateWithKey f (fst (findMax m)) m 707 | -------------------------------------------------------------------------------- /src/Data/StrictPair.hs: -------------------------------------------------------------------------------- 1 | module Data.StrictPair where 2 | 3 | data StrictPair a b = !a :*: !b 4 | 5 | {-# INLINE toPair #-} 6 | toPair :: StrictPair a b -> (a, b) 7 | toPair (a :*: b) = (a, b) 8 | -------------------------------------------------------------------------------- /src/Data/WordMap.hs: -------------------------------------------------------------------------------- 1 | -- | A reimplementation of Data.IntMap that seems to be 1.4-4x faster. 2 | 3 | module Data.WordMap ( 4 | module Data.WordMap.Lazy 5 | ) where 6 | 7 | import Data.WordMap.Lazy 8 | -------------------------------------------------------------------------------- /src/Data/WordMap/Merge/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Data.WordMap.Merge.Base where 4 | 5 | import Data.WordMap.Base 6 | 7 | import Data.Bits (xor) 8 | import Data.Functor.Identity (Identity, runIdentity) 9 | 10 | import Prelude hiding (min, max) 11 | 12 | -- | A tactic for dealing with keys present in one map but not the other in 13 | -- 'merge' or 'mergeA'. 14 | -- 15 | -- A tactic of type @ WhenMissing f a c @ is an abstract representation 16 | -- of a function of type @ Key -> a -> f (Maybe c) @. 17 | data WhenMissing f a b = WhenMissing { 18 | missingSingle :: Key -> a -> Maybe b, 19 | missingLeft :: Node L a -> Node L b, 20 | missingRight :: Node R a -> Node R b, 21 | missingAll :: WordMap a -> f (WordMap b) 22 | } 23 | 24 | -- | A tactic for dealing with keys present in one map but not the other in 25 | -- 'merge'. 26 | -- 27 | -- A tactic of type @ SimpleWhenMissing a c @ is an abstract representation 28 | -- of a function of type @ Key -> a -> Maybe c @. 29 | type SimpleWhenMissing = WhenMissing Identity 30 | 31 | -- | Drop all the entries whose keys are missing from the other 32 | -- map. 33 | -- 34 | -- @ 35 | -- dropMissing :: SimpleWhenMissing a b 36 | -- @ 37 | -- 38 | -- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing) 39 | -- 40 | -- but @dropMissing@ is much faster. 41 | {-# INLINE dropMissing #-} 42 | dropMissing :: Applicative f => WhenMissing f a b 43 | dropMissing = WhenMissing (\_ _ -> Nothing) (const Tip) (const Tip) (const (pure (WordMap Empty))) 44 | 45 | -- | Preserve, unchanged, the entries whose keys are missing from 46 | -- the other map. 47 | -- 48 | -- @ 49 | -- preserveMissing :: SimpleWhenMissing a a 50 | -- @ 51 | -- 52 | -- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x) 53 | -- 54 | -- but @preserveMissing@ is much faster. 55 | {-# INLINE preserveMissing #-} 56 | preserveMissing :: Applicative f => WhenMissing f a a 57 | preserveMissing = WhenMissing (\_ v -> Just v) id id pure 58 | 59 | -- | Filter the entries whose keys are missing from the other map. 60 | -- 61 | -- @ 62 | -- filterMissing :: (Key -> x -> Bool) -> SimpleWhenMissing a a 63 | -- @ 64 | -- 65 | -- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x 66 | -- 67 | -- but this should be a little faster. 68 | filterMissing :: Applicative f => (Key -> a -> Bool) -> WhenMissing f a a 69 | filterMissing p = WhenMissing (\k v -> if p k v then Just v else Nothing) goLKeep goRKeep (pure . start) where 70 | start (WordMap Empty) = WordMap Empty 71 | start (WordMap (NonEmpty min minV root)) 72 | | p min minV = WordMap (NonEmpty min minV (goLKeep root)) 73 | | otherwise = WordMap (goL root) 74 | 75 | goLKeep Tip = Tip 76 | goLKeep (Bin max maxV l r) 77 | | p max maxV = Bin max maxV (goLKeep l) (goRKeep r) 78 | | otherwise = case goR r of 79 | Empty -> goLKeep l 80 | NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' 81 | 82 | goRKeep Tip = Tip 83 | goRKeep (Bin min minV l r) 84 | | p min minV = Bin min minV (goLKeep l) (goRKeep r) 85 | | otherwise = case goL l of 86 | Empty -> goRKeep r 87 | NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) 88 | 89 | goL Tip = Empty 90 | goL (Bin max maxV l r) 91 | | p max maxV = case goL l of 92 | Empty -> case goRKeep r of 93 | Tip -> NonEmpty max maxV Tip 94 | Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV lI rI) 95 | NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV l' (goRKeep r)) 96 | | otherwise = binL (goL l) (goR r) 97 | 98 | goR Tip = Empty 99 | goR (Bin min minV l r) 100 | | p min minV = case goR r of 101 | Empty -> case goLKeep l of 102 | Tip -> NonEmpty min minV Tip 103 | Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV lI rI) 104 | NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV (goLKeep l) r') 105 | | otherwise = binR (goL l) (goR r) 106 | 107 | -- | A tactic for dealing with keys present in both 108 | -- maps in 'merge' or 'mergeA'. 109 | -- 110 | -- A tactic of type @ WhenMatched f a b c @ is an abstract representation 111 | -- of a function of type @ Key -> a -> b -> f (Maybe c) @. 112 | newtype WhenMatched f a b c = WhenMatched { 113 | matchedSingle :: Key -> a -> b -> f (Maybe c) 114 | } 115 | 116 | -- | A tactic for dealing with keys present in both maps in 'merge'. 117 | -- 118 | -- A tactic of type @ SimpleWhenMatched a b c @ is an abstract representation 119 | -- of a function of type @ Key -> a -> b -> Maybe c @. 120 | type SimpleWhenMatched = WhenMatched Identity 121 | 122 | unionM :: WordMap a -> WordMap a -> WordMap a 123 | unionM = merge preserveMissing preserveMissing (WhenMatched (\_ a _ -> pure (Just a))) 124 | 125 | differenceM :: WordMap a -> WordMap b -> WordMap a 126 | differenceM = merge preserveMissing dropMissing (WhenMatched (\_ _ _ -> pure Nothing)) 127 | 128 | intersectionM :: WordMap a -> WordMap b -> WordMap a 129 | intersectionM = merge dropMissing dropMissing (WhenMatched (\_ a _ -> pure (Just a))) 130 | 131 | -- | Merge two maps. 132 | -- 133 | -- @merge@ takes two 'WhenMissing' tactics, a 'WhenMatched' 134 | -- tactic and two maps. It uses the tactics to merge the maps. 135 | -- Its behavior is best understood via its fundamental tactics, 136 | -- 'mapMaybeMissing' and 'zipWithMaybeMatched'. 137 | -- 138 | -- Consider 139 | -- 140 | -- @ 141 | -- merge (mapMaybeMissing g1) 142 | -- (mapMaybeMissing g2) 143 | -- (zipWithMaybeMatched f) 144 | -- m1 m2 145 | -- @ 146 | -- 147 | -- Take, for example, 148 | -- 149 | -- @ 150 | -- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')] 151 | -- m2 = [(1, "one"), (2, "two"), (4, "three")] 152 | -- @ 153 | -- 154 | -- @merge@ will first ''align'' these maps by key: 155 | -- 156 | -- @ 157 | -- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')] 158 | -- m2 = [(1, "one"), (2, "two"), (4, "three")] 159 | -- @ 160 | -- 161 | -- It will then pass the individual entries and pairs of entries 162 | -- to @g1@, @g2@, or @f@ as appropriate: 163 | -- 164 | -- @ 165 | -- maybes = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"] 166 | -- @ 167 | -- 168 | -- This produces a 'Maybe' for each key: 169 | -- 170 | -- @ 171 | -- keys = 0 1 2 3 4 172 | -- results = [Nothing, Just True, Just False, Nothing, Just True] 173 | -- @ 174 | -- 175 | -- Finally, the @Just@ results are collected into a map: 176 | -- 177 | -- @ 178 | -- return value = [(1, True), (2, False), (4, True)] 179 | -- @ 180 | -- 181 | -- The other tactics below are optimizations or simplifications of 182 | -- 'mapMaybeMissing' for special cases. Most importantly, 183 | -- 184 | -- * 'dropMissing' drops all the keys. 185 | -- * 'preserveMissing' leaves all the entries alone. 186 | -- 187 | -- When 'merge' is given three arguments, it is inlined at the call 188 | -- site. To prevent excessive inlining, you should typically use 'merge' 189 | -- to define your custom combining functions. 190 | -- 191 | -- 192 | -- Examples: 193 | -- 194 | -- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f) 195 | -- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f) 196 | -- prop> differenceWith f = merge preserveMissing dropMissing f 197 | -- prop> symmetricDifference = merge preserveMissing preserveMissing (zipWithMaybeMatched (\_ _ _ -> Nothing)) 198 | -- prop> mapEachPiece f g h = merge (mapMissing f) (mapMissing g) (zipWithMatched h) 199 | {-# INLINE merge #-} 200 | merge :: SimpleWhenMissing a c -> SimpleWhenMissing b c -> SimpleWhenMatched a b c -> WordMap a -> WordMap b -> WordMap c 201 | merge miss1 miss2 match = start where 202 | start (WordMap Empty) (WordMap Empty) = WordMap Empty 203 | start (WordMap Empty) !m2 = runIdentity (missingAll miss2 m2) 204 | start !m1 (WordMap Empty) = runIdentity (missingAll miss1 m1) 205 | start (WordMap (NonEmpty min1 minV1 root1)) (WordMap (NonEmpty min2 minV2 root2)) 206 | | min1 < min2 = case missingSingle miss1 min1 minV1 of 207 | Nothing -> WordMap (goL2 minV2 min1 root1 min2 root2) 208 | Just minV' -> WordMap (NonEmpty min1 minV' (goL2Keep minV2 min1 root1 min2 root2)) 209 | | min1 > min2 = case missingSingle miss2 min2 minV2 of 210 | Nothing -> WordMap (goL1 minV1 min1 root1 min2 root2) 211 | Just minV' -> WordMap (NonEmpty min2 minV' (goL1Keep minV1 min1 root1 min2 root2)) 212 | | otherwise = case runIdentity (matchedSingle match min1 minV1 minV2) of 213 | Nothing -> WordMap (goLFused min1 root1 root2) 214 | Just minV' -> WordMap (NonEmpty min1 minV' (goLFusedKeep min1 root1 root2)) 215 | 216 | -- Merge two left nodes and a minimum value for the first node into a new left node 217 | -- Precondition: min1 > min2 218 | -- goL1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c 219 | goL1Keep minV1 !min1 Tip !_ Tip = case missingSingle miss1 min1 minV1 of 220 | Nothing -> Tip 221 | Just minV' -> Bin min1 minV' Tip Tip 222 | goL1Keep minV1 !min1 Tip !min2 n2 = goInsertL1 min1 minV1 (xor min1 min2) min2 n2 223 | goL1Keep minV1 !min1 n1 !min2 Tip = case missingSingle miss1 min1 minV1 of 224 | Nothing -> missingLeft miss1 n1 225 | Just minV' -> insertMinL (xor min1 min2) min1 minV' (missingLeft miss1 n1) 226 | 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 227 | LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint 228 | | xor min1 min2 < xor min1 max2 -> binL2 max2 maxV2 (goL1Keep minV1 min1 n1 min2 l2) (missingRight miss2 r2) 229 | | max1 > max2 -> case missingSingle miss1 max1 maxV1 of 230 | Nothing -> case goR2 maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2 of 231 | Empty -> l' 232 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 233 | Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 (Bin min1 minV1 l1 r1) max2 r2) 234 | | max1 < max2 -> case missingSingle miss2 max2 maxV2 of 235 | Nothing -> case goR1 maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2 of 236 | Empty -> l' 237 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 238 | Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 (Bin min1 minV1 l1 r1) max2 r2) 239 | | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of 240 | Nothing -> case goRFused max1 (Bin min1 minV1 l1 r1) r2 of 241 | Empty -> l' 242 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 243 | Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 (Bin min1 minV1 l1 r1) r2) 244 | where 245 | {-# INLINE l' #-} 246 | l' = missingLeft miss2 l2 247 | EQ | max2 < min1 -> disjoint 248 | | max1 > max2 -> case missingSingle miss1 max1 maxV1 of 249 | Nothing -> case goR2 maxV2 max1 r1 max2 r2 of 250 | Empty -> l' 251 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 252 | Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) 253 | | max1 < max2 -> case missingSingle miss2 max2 maxV2 of 254 | Nothing -> case goR1 maxV1 max1 r1 max2 r2 of 255 | Empty -> l' 256 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 257 | Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) 258 | | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of 259 | Nothing -> case goRFused max1 r1 r2 of 260 | Empty -> l' 261 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 262 | Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) 263 | where 264 | {-# INLINE l' #-} 265 | l' = goL1Keep minV1 min1 l1 min2 l2 266 | GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint 267 | | otherwise -> binL1 max1 maxV1 (goL1Keep minV1 min1 l1 min2 n2) (missingRight miss1 r1) 268 | where 269 | disjoint = binL1 max1 maxV1 (missingLeft miss2 n2) (missingRight miss1 (Bin min1 minV1 l1 r1)) 270 | 271 | -- Merge two left nodes and a minimum value for the second node into a new left node 272 | -- Precondition: min2 > min1 273 | -- goL2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c 274 | goL2Keep minV2 !_ Tip !min2 Tip = case missingSingle miss2 min2 minV2 of 275 | Nothing -> Tip 276 | Just minV' -> Bin min2 minV' Tip Tip 277 | goL2Keep minV2 !min1 Tip !min2 n2 = case missingSingle miss2 min2 minV2 of 278 | Nothing -> missingLeft miss2 n2 279 | Just minV' -> insertMinL (xor min1 min2) min2 minV' (missingLeft miss2 n2) 280 | goL2Keep minV2 !min1 n1 !min2 Tip = goInsertL2 min2 minV2 (xor min1 min2) min1 n1 281 | 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 282 | GT | xor min1 max1 `ltMSB` xor min1 min2 -> disjoint 283 | | xor min1 min2 < xor min2 max1 -> binL1 max1 maxV1 (goL2Keep minV2 min1 l1 min2 n2) (missingRight miss1 r1) 284 | | max1 > max2 -> case missingSingle miss1 max1 maxV1 of 285 | Nothing -> case goR2 maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2) of 286 | Empty -> l' 287 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 288 | Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 (Bin min2 minV2 l2 r2)) 289 | | max1 < max2 -> case missingSingle miss2 max2 maxV2 of 290 | Nothing -> case goR1 maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2) of 291 | Empty -> l' 292 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 293 | Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 (Bin min2 minV2 l2 r2)) 294 | | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of 295 | Nothing -> case goRFused max1 r1 (Bin min2 minV2 l2 r2) of 296 | Empty -> l' 297 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 298 | Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 (Bin min2 minV2 l2 r2)) 299 | where 300 | {-# INLINE l' #-} 301 | l' = missingLeft miss1 l1 302 | EQ | max1 < min2 -> disjoint 303 | | max1 > max2 -> case missingSingle miss1 max1 maxV1 of 304 | Nothing -> case goR2 maxV2 max1 r1 max2 r2 of 305 | Empty -> l' 306 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 307 | Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) 308 | | max1 < max2 -> case missingSingle miss2 max2 maxV2 of 309 | Nothing -> case goR1 maxV1 max1 r1 max2 r2 of 310 | Empty -> l' 311 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 312 | Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) 313 | | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of 314 | Nothing -> case goRFused max1 r1 r2 of 315 | Empty -> l' 316 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 317 | Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) 318 | where 319 | {-# INLINE l' #-} 320 | l' = goL2Keep minV2 min1 l1 min2 l2 321 | LT | xor min2 max2 `ltMSB` xor min1 min2 -> disjoint 322 | | otherwise -> binL2 max2 maxV2 (goL2Keep minV2 min1 n1 min2 l2) (missingRight miss2 r2) 323 | where 324 | disjoint = binL2 max2 maxV2 (missingLeft miss1 n1) (missingRight miss2 (Bin min2 minV2 l2 r2)) 325 | 326 | -- goLFusedKeep !_ Tip Tip = Tip 327 | goLFusedKeep !_ Tip n2 = missingLeft miss2 n2 328 | goLFusedKeep !_ n1 Tip = missingLeft miss1 n1 329 | goLFusedKeep !min n1@(Bin max1 maxV1 l1 r1) n2@(Bin max2 maxV2 l2 r2) = case compareMSB (xor min max1) (xor min max2) of 330 | LT -> binL2 max2 maxV2 (goLFusedKeep min n1 l2) (missingRight miss2 r2) 331 | EQ | max1 > max2 -> case missingSingle miss1 max1 maxV1 of 332 | Nothing -> case goR2 maxV2 max1 r1 max2 r2 of 333 | Empty -> l' 334 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 335 | Just maxV' -> Bin max1 maxV' l' (goR2Keep maxV2 max1 r1 max2 r2) 336 | | max1 < max2 -> case missingSingle miss2 max2 maxV2 of 337 | Nothing -> case goR1 maxV1 max1 r1 max2 r2 of 338 | Empty -> l' 339 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 340 | Just maxV' -> Bin max2 maxV' l' (goR1Keep maxV1 max1 r1 max2 r2) 341 | | otherwise -> case runIdentity (matchedSingle match max1 maxV1 maxV2) of 342 | Nothing -> case goRFused max1 r1 r2 of 343 | Empty -> l' 344 | NonEmpty max' maxV' r' -> Bin max' maxV' l' r' 345 | Just maxV' -> Bin max1 maxV' l' (goRFusedKeep max1 r1 r2) 346 | where 347 | {-# INLINE l' #-} 348 | l' = goLFusedKeep min l1 l2 349 | GT -> binL1 max1 maxV1 (goLFusedKeep min l1 n2) (missingRight miss1 r1) 350 | 351 | -- Merge two right nodes and a maximum value for the first node into a new right node 352 | -- Precondition: max1 < max2 353 | -- goR1Keep :: a -> Key -> Node a -> Key -> Node b -> Node c 354 | goR1Keep maxV1 !max1 Tip !_ Tip = case missingSingle miss1 max1 maxV1 of 355 | Nothing -> Tip 356 | Just maxV' -> Bin max1 maxV' Tip Tip 357 | goR1Keep maxV1 !max1 Tip !max2 n2 = goInsertR1 max1 maxV1 (xor max1 max2) max2 n2 358 | goR1Keep maxV1 !max1 n1 !max2 Tip = case missingSingle miss1 max1 maxV1 of 359 | Nothing -> missingRight miss1 n1 360 | Just maxV' -> insertMaxR (xor max1 max2) max1 maxV' (missingRight miss1 n1) 361 | 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 362 | LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint 363 | | xor min2 max1 > xor max1 max2 -> binR2 min2 minV2 (missingLeft miss2 l2) (goR1Keep maxV1 max1 n1 max2 r2) 364 | | min1 < min2 -> case missingSingle miss1 min1 minV1 of 365 | Nothing -> case goL2 minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2 of 366 | Empty -> r' 367 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 368 | Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' 369 | | min1 > min2 -> case missingSingle miss2 min2 minV2 of 370 | Nothing -> case goL1 minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2 of 371 | Empty -> r' 372 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 373 | Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 (Bin max1 maxV1 l1 r1) min2 l2) r' 374 | | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of 375 | Nothing -> case goLFused min1 (Bin max1 maxV1 l1 r1) l2 of 376 | Empty -> r' 377 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 378 | Just minV' -> Bin min1 minV' (goLFusedKeep min1 (Bin max1 maxV1 l1 r1) l2) r' 379 | where 380 | {-# INLINE r' #-} 381 | r' = missingRight miss2 r2 382 | EQ | max1 < min2 -> disjoint 383 | | min1 < min2 -> case missingSingle miss1 min1 minV1 of 384 | Nothing -> case goL2 minV2 min1 l1 min2 l2 of 385 | Empty -> r' 386 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 387 | Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' 388 | | min1 > min2 -> case missingSingle miss2 min2 minV2 of 389 | Nothing -> case goL1 minV1 min1 l1 min2 l2 of 390 | Empty -> r' 391 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 392 | Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' 393 | | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of 394 | Nothing -> case goLFused min1 l1 l2 of 395 | Empty -> r' 396 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 397 | Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' 398 | where 399 | {-# INLINE r' #-} 400 | r' = goR1Keep maxV1 max1 r1 max2 r2 401 | GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint 402 | | otherwise -> binR1 min1 minV1 (missingLeft miss1 l1) (goR1Keep maxV1 max1 r1 max2 n2) 403 | where 404 | disjoint = binR1 min1 minV1 (missingLeft miss1 (Bin max1 maxV1 l1 r1)) (missingRight miss2 n2) 405 | 406 | -- Merge two left nodes and a minimum value for the second node into a new left node 407 | -- Precondition: max2 < max1 408 | -- goR2Keep :: b -> Key -> Node a -> Key -> Node b -> Node c 409 | goR2Keep maxV2 !_ Tip !max2 Tip = case missingSingle miss2 max2 maxV2 of 410 | Nothing -> Tip 411 | Just maxV' -> Bin max2 maxV' Tip Tip 412 | goR2Keep maxV2 !max1 Tip !max2 n2 = case missingSingle miss2 max2 maxV2 of 413 | Nothing -> missingRight miss2 n2 414 | Just maxV' -> insertMaxR (xor max1 max2) max2 maxV' (missingRight miss2 n2) 415 | goR2Keep maxV2 !max1 n1 !max2 Tip = goInsertR2 max2 maxV2 (xor max1 max2) max1 n1 416 | 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 417 | GT | xor min1 max1 `ltMSB` xor max1 max2 -> disjoint 418 | | xor min1 max2 > xor max2 max1 -> binR1 min1 minV1 (missingLeft miss1 l1) (goR2Keep maxV2 max1 r1 max2 n2) 419 | | min1 < min2 -> case missingSingle miss1 min1 minV1 of 420 | Nothing -> case goL2 minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2) of 421 | Empty -> r' 422 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 423 | Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' 424 | | min1 > min2 -> case missingSingle miss2 min2 minV2 of 425 | Nothing -> case goL1 minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2) of 426 | Empty -> r' 427 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 428 | Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 (Bin max2 maxV2 l2 r2)) r' 429 | | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of 430 | Nothing -> case goLFused min1 l1 (Bin max2 maxV2 l2 r2) of 431 | Empty -> r' 432 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 433 | Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 (Bin max2 maxV2 l2 r2)) r' 434 | where 435 | {-# INLINE r' #-} 436 | r' = missingRight miss1 r1 437 | EQ | max2 < min1 -> disjoint 438 | | min1 < min2 -> case missingSingle miss1 min1 minV1 of 439 | Nothing -> case goL2 minV2 min1 l1 min2 l2 of 440 | Empty -> r' 441 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 442 | Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' 443 | | min1 > min2 -> case missingSingle miss2 min2 minV2 of 444 | Nothing -> case goL1 minV1 min1 l1 min2 l2 of 445 | Empty -> r' 446 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 447 | Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' 448 | | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of 449 | Nothing -> case goLFused min1 l1 l2 of 450 | Empty -> r' 451 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 452 | Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' 453 | where 454 | {-# INLINE r' #-} 455 | r' = goR2Keep maxV2 max1 r1 max2 r2 456 | LT | xor min2 max2 `ltMSB` xor max1 max2 -> disjoint 457 | | otherwise -> binR2 min2 minV2 (missingLeft miss2 l2) (goR2Keep maxV2 max1 n1 max2 r2) 458 | where 459 | disjoint = binR2 min2 minV2 (missingLeft miss2 (Bin max2 maxV2 l2 r2)) (missingRight miss1 n1) 460 | 461 | -- goRFusedKeep !_ Tip Tip = Tip 462 | goRFusedKeep !_ Tip n2 = missingRight miss2 n2 463 | goRFusedKeep !_ n1 Tip = missingRight miss1 n1 464 | goRFusedKeep !max n1@(Bin min1 minV1 l1 r1) n2@(Bin min2 minV2 l2 r2) = case compareMSB (xor min1 max) (xor min2 max) of 465 | LT -> binR2 min2 minV2 (missingLeft miss2 l2) (goRFusedKeep max n1 r2) 466 | EQ | min1 < min2 -> case missingSingle miss1 min1 minV1 of 467 | Nothing -> case goL2 minV2 min1 l1 min2 l2 of 468 | Empty -> r' 469 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 470 | Just minV' -> Bin min1 minV' (goL2Keep minV2 min1 l1 min2 l2) r' 471 | | min1 > min2 -> case missingSingle miss2 min2 minV2 of 472 | Nothing -> case goL1 minV1 min1 l1 min2 l2 of 473 | Empty -> r' 474 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 475 | Just minV' -> Bin min2 minV' (goL1Keep minV1 min1 l1 min2 l2) r' 476 | | otherwise -> case runIdentity (matchedSingle match min1 minV1 minV2) of 477 | Nothing -> case goLFused min1 l1 l2 of 478 | Empty -> r' 479 | NonEmpty min' minV' l' -> Bin min' minV' l' r' 480 | Just minV' -> Bin min1 minV' (goLFusedKeep min1 l1 l2) r' 481 | where 482 | {-# INLINE r' #-} 483 | r' = goRFusedKeep max r1 r2 484 | GT -> binR1 min1 minV1 (missingLeft miss1 l1) (goRFusedKeep max r1 n2) 485 | 486 | goL1 minV1 !min1 !n1 !min2 !n2 = nodeToMapL (goL1Keep minV1 min1 n1 min2 n2) 487 | goL2 minV2 !min1 !n1 !min2 !n2 = nodeToMapL (goL2Keep minV2 min1 n1 min2 n2) 488 | goLFused !min !n1 !n2 = nodeToMapL (goLFusedKeep min n1 n2) 489 | goR1 maxV1 !max1 !n1 !max2 !n2 = nodeToMapR (goR1Keep maxV1 max1 n1 max2 n2) 490 | goR2 maxV2 !max1 !n1 !max2 !n2 = nodeToMapR (goR2Keep maxV2 max1 n1 max2 n2) 491 | goRFused !max !n1 !n2 = nodeToMapR (goRFusedKeep max n1 n2) 492 | 493 | goInsertL1 !k v !_ _ Tip = case missingSingle miss1 k v of 494 | Nothing -> Tip 495 | Just v' -> Bin k v' Tip Tip 496 | goInsertL1 !k v !xorCache min (Bin max maxV l r) 497 | | k < max = if xorCache < xorCacheMax 498 | then binL2 max maxV (goInsertL1 k v xorCache min l) (missingRight miss2 r) 499 | else binL2 max maxV (missingLeft miss2 l) (goInsertR1 k v xorCacheMax max r) 500 | | k > max = case missingSingle miss1 k v of 501 | Nothing -> missingLeft miss2 (Bin max maxV l r) 502 | Just v' -> if xor min max < xorCacheMax 503 | then Bin k v' (missingLeft miss2 (Bin max maxV l r)) Tip 504 | else Bin k v' (missingLeft miss2 l) (missingRight miss2 (insertMaxR xorCacheMax max maxV r)) 505 | | otherwise = case runIdentity (matchedSingle match max v maxV) of 506 | Nothing -> extractBinL (missingLeft miss2 l) (missingRight miss2 r) -- TODO: do extractBin first? 507 | Just maxV' -> Bin max maxV' (missingLeft miss2 l) (missingRight miss2 r) 508 | where xorCacheMax = xor k max 509 | 510 | goInsertL2 !k v !_ _ Tip = case missingSingle miss2 k v of 511 | Nothing -> Tip 512 | Just v' -> Bin k v' Tip Tip 513 | goInsertL2 !k v !xorCache min (Bin max maxV l r) 514 | | k < max = if xorCache < xorCacheMax 515 | then binL1 max maxV (goInsertL2 k v xorCache min l) (missingRight miss1 r) 516 | else binL1 max maxV (missingLeft miss1 l) (goInsertR2 k v xorCacheMax max r) 517 | | k > max = case missingSingle miss2 k v of 518 | Nothing -> missingLeft miss1 (Bin max maxV l r) 519 | Just v' -> if xor min max < xorCacheMax 520 | then Bin k v' (missingLeft miss1 (Bin max maxV l r)) Tip 521 | else Bin k v' (missingLeft miss1 l) (missingRight miss1 (insertMaxR xorCacheMax max maxV r)) 522 | | otherwise = case runIdentity (matchedSingle match max maxV v) of 523 | Nothing -> extractBinL (missingLeft miss1 l) (missingRight miss1 r) -- TODO: do extractBin first? 524 | Just maxV' -> Bin max maxV' (missingLeft miss1 l) (missingRight miss1 r) 525 | where xorCacheMax = xor k max 526 | 527 | goInsertR1 k v !_ _ Tip = case missingSingle miss1 k v of 528 | Nothing -> Tip 529 | Just v' -> Bin k v' Tip Tip 530 | goInsertR1 k v !xorCache max (Bin min minV l r) 531 | | k > min = if xorCache < xorCacheMin 532 | then binR2 min minV (missingLeft miss2 l) (goInsertR1 k v xorCache max r) 533 | else binR2 min minV (goInsertL1 k v xorCacheMin min l) (missingRight miss2 r) 534 | | k < min = case missingSingle miss1 k v of 535 | Nothing -> missingRight miss2 (Bin min minV l r) 536 | Just v' -> if xor min max < xorCacheMin 537 | then Bin k v' Tip (missingRight miss2 (Bin min minV l r)) 538 | else Bin k v' (missingLeft miss2 (insertMinL xorCacheMin min minV l)) (missingRight miss2 r) 539 | | otherwise = case runIdentity (matchedSingle match min v minV) of 540 | Nothing -> extractBinR (missingLeft miss2 l) (missingRight miss2 r) -- TODO: do extractBin first? 541 | Just minV' -> Bin min minV' (missingLeft miss2 l) (missingRight miss2 r) 542 | where xorCacheMin = xor k min 543 | 544 | goInsertR2 !k v !_ _ Tip = case missingSingle miss2 k v of 545 | Nothing -> Tip 546 | Just v' -> Bin k v' Tip Tip 547 | goInsertR2 !k v !xorCache max (Bin min minV l r) 548 | | k > min = if xorCache < xorCacheMin 549 | then binR1 min minV (missingLeft miss1 l) (goInsertR2 k v xorCache max r) 550 | else binR1 min minV (goInsertL2 k v xorCacheMin min l) (missingRight miss1 r) 551 | | k < min = case missingSingle miss2 k v of 552 | Nothing -> missingRight miss1 (Bin min minV l r) 553 | Just v' -> if xor min max < xorCacheMin 554 | then Bin k v' Tip (missingRight miss1 (Bin min minV l r)) 555 | else Bin k v' (missingLeft miss1 (insertMinL xorCacheMin min minV l)) (missingRight miss1 r) 556 | | otherwise = case runIdentity (matchedSingle match min minV v) of 557 | Nothing -> extractBinR (missingLeft miss1 l) (missingRight miss1 r) -- TODO: do extractBin first? 558 | Just minV' -> Bin min minV' (missingLeft miss1 l) (missingRight miss1 r) 559 | where xorCacheMin = xor k min 560 | 561 | {-# INLINE binL1 #-} 562 | binL1 k1 v1 l r = case missingSingle miss1 k1 v1 of 563 | Nothing -> extractBinL l r 564 | Just v' -> Bin k1 v' l r 565 | 566 | {-# INLINE binL2 #-} 567 | binL2 k2 v2 l r = case missingSingle miss2 k2 v2 of 568 | Nothing -> extractBinL l r 569 | Just v' -> Bin k2 v' l r 570 | 571 | {-# INLINE binR1 #-} 572 | binR1 k1 v1 l r = case missingSingle miss1 k1 v1 of 573 | Nothing -> extractBinR l r 574 | Just v' -> Bin k1 v' l r 575 | 576 | {-# INLINE binR2 #-} 577 | binR2 k2 v2 l r = case missingSingle miss2 k2 v2 of 578 | Nothing -> extractBinR l r 579 | Just v' -> Bin k2 v' l r 580 | -------------------------------------------------------------------------------- /src/Data/WordMap/Merge/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, ScopedTypeVariables #-} 2 | 3 | module Data.WordMap.Merge.Lazy ( 4 | -- ** Simple merge tactic types 5 | WhenMissing 6 | , WhenMatched 7 | 8 | -- ** General combining function 9 | , merge 10 | 11 | -- ** @WhenMatched@ tactics 12 | , zipWithMaybeMatched 13 | , zipWithMatched 14 | 15 | -- *** @WhenMissing@ tactics 16 | , dropMissing 17 | , preserveMissing 18 | , mapMissing 19 | , mapMaybeMissing 20 | , filterMissing 21 | 22 | , unionWithM 23 | , intersectionWithM 24 | ) where 25 | 26 | import Data.WordMap.Base 27 | import Data.WordMap.Merge.Base 28 | 29 | import Prelude hiding (min, max) 30 | 31 | -- | Map over the entries whose keys are missing from the other map. 32 | -- 33 | -- @ 34 | -- mapMissing :: (Key -> a -> b) -> SimpleWhenMissing a b 35 | -- @ 36 | -- 37 | -- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) 38 | -- 39 | -- but @mapMissing@ is somewhat faster. 40 | mapMissing :: forall f a b. Applicative f => (Key -> a -> b) -> WhenMissing f a b 41 | mapMissing f = WhenMissing (\k v -> Just (f k v)) go go (pure . start) where 42 | start (WordMap Empty) = WordMap Empty 43 | start (WordMap (NonEmpty min minV root)) = WordMap (NonEmpty min (f min minV) (go root)) 44 | 45 | go :: Node t a -> Node t b 46 | go Tip = Tip 47 | go (Bin k v l r) = Bin k (f k v) (go l) (go r) 48 | 49 | -- | Map over the entries whose keys are missing from the other map, 50 | -- optionally removing some. This is the most powerful 'SimpleWhenMissing' 51 | -- tactic, but others are usually more efficient. 52 | -- 53 | -- @ 54 | -- mapMaybeMissing :: (Key -> a -> Maybe b) -> SimpleWhenMissing a b 55 | -- @ 56 | -- 57 | -- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x)) 58 | -- 59 | -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. 60 | mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b 61 | mapMaybeMissing f = WhenMissing f goLKeep goRKeep (pure . start) where 62 | start (WordMap Empty) = WordMap Empty 63 | start (WordMap (NonEmpty min minV root)) = case f min minV of 64 | Just minV' -> WordMap (NonEmpty min minV' (goLKeep root)) 65 | Nothing -> WordMap (goL root) 66 | 67 | goLKeep Tip = Tip 68 | goLKeep (Bin max maxV l r) = case f max maxV of 69 | Just maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) 70 | Nothing -> case goR r of 71 | Empty -> goLKeep l 72 | NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' 73 | 74 | goRKeep Tip = Tip 75 | goRKeep (Bin min minV l r) = case f min minV of 76 | Just minV' -> Bin min minV' (goLKeep l) (goRKeep r) 77 | Nothing -> case goL l of 78 | Empty -> goRKeep r 79 | NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) 80 | 81 | goL Tip = Empty 82 | goL (Bin max maxV l r) = case f max maxV of 83 | Just maxV' -> case goL l of 84 | Empty -> case goRKeep r of 85 | Tip -> NonEmpty max maxV' Tip 86 | Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) 87 | NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goRKeep r)) 88 | Nothing -> binL (goL l) (goR r) 89 | 90 | goR Tip = Empty 91 | goR (Bin min minV l r) = case f min minV of 92 | Just minV' -> case goR r of 93 | Empty -> case goLKeep l of 94 | Tip -> NonEmpty min minV' Tip 95 | Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) 96 | NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goLKeep l) r') 97 | Nothing -> binR (goL l) (goR r) 98 | 99 | -- | When a key is found in both maps, apply a function to the 100 | -- key and values and maybe use the result in the merged map. 101 | -- 102 | -- @ 103 | -- zipWithMaybeMatched :: (Key -> a -> b -> Maybe c) 104 | -- -> SimpleWhenMatched a b c 105 | -- @ 106 | {-# INLINE zipWithMaybeMatched #-} 107 | zipWithMaybeMatched :: Applicative f => (Key -> a -> b -> Maybe c) -> WhenMatched f a b c 108 | zipWithMaybeMatched f = WhenMatched (\k a b -> pure (f k a b)) 109 | 110 | -- | When a key is found in both maps, apply a function to the 111 | -- key and values and use the result in the merged map. 112 | -- 113 | -- @ 114 | -- zipWithMatched :: (Key -> a -> b -> c) 115 | -- -> SimpleWhenMatched a b c 116 | -- @ 117 | {-# INLINE zipWithMatched #-} 118 | zipWithMatched :: Applicative f => (Key -> a -> b -> c) -> WhenMatched f a b c 119 | zipWithMatched f = zipWithMaybeMatched (\k a b -> Just (f k a b)) 120 | 121 | unionWithM :: (Key -> a -> a -> a) -> WordMap a -> WordMap a -> WordMap a 122 | unionWithM f = merge preserveMissing preserveMissing (zipWithMatched f) 123 | 124 | intersectionWithM :: (Key -> a -> b -> c) -> WordMap a -> WordMap b -> WordMap c 125 | intersectionWithM f = merge dropMissing dropMissing (zipWithMatched f) 126 | -------------------------------------------------------------------------------- /src/Data/WordMap/Merge/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, ScopedTypeVariables #-} 2 | 3 | module Data.WordMap.Merge.Strict ( 4 | -- ** Simple merge tactic types 5 | WhenMissing 6 | , WhenMatched 7 | 8 | -- ** General combining function 9 | , merge 10 | 11 | -- ** @WhenMatched@ tactics 12 | , zipWithMaybeMatched 13 | , zipWithMatched 14 | 15 | -- *** @WhenMissing@ tactics 16 | , dropMissing 17 | , preserveMissing 18 | , mapMissing 19 | , mapMaybeMissing 20 | , filterMissing 21 | ) where 22 | 23 | import Data.WordMap.Base 24 | import Data.WordMap.Merge.Base 25 | 26 | import Prelude hiding (min, max) 27 | 28 | (#!), (#) :: (a -> b) -> a -> b 29 | (#!) = ($!) 30 | (#) = ($) 31 | 32 | -- | Map over the entries whose keys are missing from the other map. 33 | -- 34 | -- @ 35 | -- mapMissing :: (Key -> a -> b) -> SimpleWhenMissing a b 36 | -- @ 37 | -- 38 | -- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x) 39 | -- 40 | -- but @mapMissing@ is somewhat faster. 41 | mapMissing :: forall f a b. Applicative f => (Key -> a -> b) -> WhenMissing f a b 42 | mapMissing f = WhenMissing (\k v -> Just $! f k v) go go (pure . start) where 43 | start (WordMap Empty) = WordMap Empty 44 | start (WordMap (NonEmpty min minV root)) = WordMap (NonEmpty min #! f min minV # go root) 45 | 46 | go :: Node t a -> Node t b 47 | go Tip = Tip 48 | go (Bin k v l r) = Bin k #! f k v # go l # go r 49 | 50 | -- | Map over the entries whose keys are missing from the other map, 51 | -- optionally removing some. This is the most powerful 'SimpleWhenMissing' 52 | -- tactic, but others are usually more efficient. 53 | -- 54 | -- @ 55 | -- mapMaybeMissing :: (Key -> a -> Maybe b) -> SimpleWhenMissing a b 56 | -- @ 57 | -- 58 | -- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x)) 59 | -- 60 | -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations. 61 | mapMaybeMissing :: Applicative f => (Key -> a -> Maybe b) -> WhenMissing f a b 62 | mapMaybeMissing f = WhenMissing f goLKeep goRKeep (pure . start) where 63 | start (WordMap Empty) = WordMap Empty 64 | start (WordMap (NonEmpty min minV root)) = case f min minV of 65 | Just !minV' -> WordMap (NonEmpty min minV' (goLKeep root)) 66 | Nothing -> WordMap (goL root) 67 | 68 | goLKeep Tip = Tip 69 | goLKeep (Bin max maxV l r) = case f max maxV of 70 | Just !maxV' -> Bin max maxV' (goLKeep l) (goRKeep r) 71 | Nothing -> case goR r of 72 | Empty -> goLKeep l 73 | NonEmpty max' maxV' r' -> Bin max' maxV' (goLKeep l) r' 74 | 75 | goRKeep Tip = Tip 76 | goRKeep (Bin min minV l r) = case f min minV of 77 | Just !minV' -> Bin min minV' (goLKeep l) (goRKeep r) 78 | Nothing -> case goL l of 79 | Empty -> goRKeep r 80 | NonEmpty min' minV' l' -> Bin min' minV' l' (goRKeep r) 81 | 82 | goL Tip = Empty 83 | goL (Bin max maxV l r) = case f max maxV of 84 | Just !maxV' -> case goL l of 85 | Empty -> case goRKeep r of 86 | Tip -> NonEmpty max maxV' Tip 87 | Bin minI minVI lI rI -> NonEmpty minI minVI (Bin max maxV' lI rI) 88 | NonEmpty min minV l' -> NonEmpty min minV (Bin max maxV' l' (goRKeep r)) 89 | Nothing -> binL (goL l) (goR r) 90 | 91 | goR Tip = Empty 92 | goR (Bin min minV l r) = case f min minV of 93 | Just !minV' -> case goR r of 94 | Empty -> case goLKeep l of 95 | Tip -> NonEmpty min minV' Tip 96 | Bin maxI maxVI lI rI -> NonEmpty maxI maxVI (Bin min minV' lI rI) 97 | NonEmpty max maxV r' -> NonEmpty max maxV (Bin min minV' (goLKeep l) r') 98 | Nothing -> binR (goL l) (goR r) 99 | 100 | 101 | -- | When a key is found in both maps, apply a function to the 102 | -- key and values and maybe use the result in the merged map. 103 | -- 104 | -- @ 105 | -- zipWithMaybeMatched :: (Key -> a -> b -> Maybe c) 106 | -- -> SimpleWhenMatched a b c 107 | -- @ 108 | {-# INLINE zipWithMaybeMatched #-} 109 | zipWithMaybeMatched :: Applicative f => (Key -> a -> b -> Maybe c) -> WhenMatched f a b c 110 | zipWithMaybeMatched f = WhenMatched (\k a b -> case f k a b of 111 | Nothing -> pure Nothing 112 | Just !c -> pure (Just c)) 113 | 114 | -- | When a key is found in both maps, apply a function to the 115 | -- key and values and use the result in the merged map. 116 | -- 117 | -- @ 118 | -- zipWithMatched :: (Key -> a -> b -> c) 119 | -- -> SimpleWhenMatched a b c 120 | -- @ 121 | {-# INLINE zipWithMatched #-} 122 | zipWithMatched :: Applicative f => (Key -> a -> b -> c) -> WhenMatched f a b c 123 | zipWithMatched f = zipWithMaybeMatched (\k a b -> Just $! f k a b) 124 | -------------------------------------------------------------------------------- /src/Data/WordSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- TODO: Add some comments describing how this implementation works. 4 | 5 | -- | A reimplementation of Data.IntMap that seems to be 1.4-4x faster. 6 | 7 | module Data.WordSet ( 8 | -- * Map type 9 | WordSet, Key 10 | 11 | -- * Operators 12 | , (\\) 13 | 14 | -- * Query 15 | , null 16 | , size 17 | , member 18 | , notMember 19 | {- , lookupLT 20 | , lookupGT 21 | , lookupLE 22 | , lookupGE-} 23 | 24 | -- * Construction 25 | , empty 26 | , singleton 27 | , insert 28 | , delete 29 | 30 | -- * Combine 31 | , union 32 | , unions 33 | , difference 34 | , intersection 35 | 36 | -- * Filter 37 | , filter 38 | , partition 39 | 40 | -- * Map 41 | , map 42 | 43 | -- * Folds 44 | , foldr 45 | , foldl 46 | 47 | -- ** Strict folds 48 | , foldr' 49 | , foldl' 50 | 51 | -- * Min\/Max 52 | , findMin 53 | , findMax 54 | , deleteMin 55 | , deleteMax 56 | 57 | -- * Conversion 58 | -- ** List 59 | , elems 60 | , toList 61 | , fromList 62 | -- ** Ordered list 63 | , toAscList 64 | , toDescList 65 | , fromAscList 66 | , fromDistinctAscList 67 | 68 | -- * Debugging 69 | {-, showTree 70 | , valid-} 71 | ) where 72 | 73 | import Data.WordSet.Internal 74 | 75 | import Prelude hiding (foldr, foldl, null, map, filter) 76 | -------------------------------------------------------------------------------- /src/Data/WordSet/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- TODO: Add some comments describing how this implementation works. 4 | 5 | -- | A reimplementation of Data.WordMap that seems to be 1.4-4x faster. 6 | 7 | module Data.WordSet.Internal where 8 | 9 | import Control.DeepSeq 10 | 11 | import qualified Data.List as List 12 | 13 | import Data.Word (Word) 14 | import Data.Bits 15 | import Data.Bits.Extras (trailingZeros, leadingZeros) 16 | 17 | import Prelude hiding (foldr, foldl, null, map, filter, min, max) 18 | 19 | type Key = Word 20 | type BitMap = Word 21 | 22 | data WordSet = NonEmpty {-# UNPACK #-} !Key !Node | Empty deriving (Eq) 23 | data Node = Bin {-# UNPACK #-} !Key !Node !Node | BM {-# UNPACK #-} !Key {-# UNPACK #-} !BitMap | Tip deriving (Eq, Show) 24 | 25 | instance Show WordSet where 26 | show m = "fromList " ++ show (toList m) 27 | 28 | -- instance NFData WordSet 29 | 30 | -- | /O(n+m)/. See 'difference'. 31 | (\\) :: WordSet -> WordSet -> WordSet 32 | (\\) = difference 33 | 34 | -- | /O(1)/. Is the map empty? 35 | null :: WordSet -> Bool 36 | null Empty = True 37 | null _ = False 38 | 39 | -- | /O(n)/. Number of elements in the map. 40 | size :: WordSet -> Int 41 | size Empty = 0 42 | size (NonEmpty _ node) = sizeNode node where 43 | sizeNode Tip = 1 44 | sizeNode (BM _ bm) = fromIntegral $ popCount bm 45 | sizeNode (Bin _ l r) = sizeNode l + sizeNode r 46 | 47 | -- | /O(min(n,W))/. Is the key a member of the map? 48 | member :: Key -> WordSet -> Bool 49 | member k = k `seq` start 50 | where 51 | start Empty = False 52 | start (NonEmpty min node) 53 | | k < min = False 54 | | k == min = True 55 | | otherwise = goL (xor min k) node 56 | 57 | goL !_ Tip = False 58 | goL !xorCache (BM _ bm) = xorCache <= suffixMask && (bm .&. getSuf k /= 0) 59 | goL !xorCache (Bin max l r) 60 | | k < max = if xorCache < xorCacheMax 61 | then goL xorCache l 62 | else goR xorCacheMax r 63 | | otherwise = k == max 64 | where xorCacheMax = xor k max 65 | 66 | goR !_ Tip = False 67 | goR !xorCache (BM _ bm) = xorCache <= suffixMask && (bm .&. getSuf k /= 0) 68 | goR !xorCache (Bin min l r) 69 | | k > min = if xorCache < xorCacheMin 70 | then goR xorCache r 71 | else goL xorCacheMin l 72 | | otherwise = k == min 73 | where xorCacheMin = xor min k 74 | 75 | -- | /O(min(n,W))/. Is the key not a member of the map? 76 | notMember :: Key -> WordSet -> Bool 77 | notMember k = k `seq` start 78 | where 79 | start Empty = True 80 | start (NonEmpty min node) 81 | | k < min = True 82 | | k == min = False 83 | | otherwise = goL (xor min k) node 84 | 85 | goL !_ Tip = True 86 | goL !xorCache (BM _ bm) = xorCache <= suffixMask && (bm .&. getSuf k == 0) 87 | goL !xorCache (Bin max l r) 88 | | k < max = if xorCache < xorCacheMax 89 | then goL xorCache l 90 | else goR xorCacheMax r 91 | | otherwise = k == max 92 | where xorCacheMax = xor k max 93 | 94 | goR !_ Tip = True 95 | goR !xorCache (BM _ bm) = xorCache <= suffixMask && (bm .&. getSuf k == 0) 96 | goR !xorCache (Bin min l r) 97 | | k > min = if xorCache < xorCacheMin 98 | then goR xorCache r 99 | else goL xorCacheMin l 100 | | otherwise = k == min 101 | where xorCacheMin = xor min k 102 | {- 103 | -- | /O(log n)/. Find largest element smaller than the given one. 104 | -- 105 | -- > lookupLT 3 (fromList [3, 5]) == Nothing 106 | -- > lookupLT 5 (fromList [3, 5]) == Just 3 107 | lookupLT :: Key -> WordSet -> Maybe Key 108 | lookupLT k = k `seq` start 109 | where 110 | start Empty = Nothing 111 | start (NonEmpty min node) 112 | | min >= k = Nothing 113 | | otherwise = Just (goL (xor min k) min node) 114 | 115 | goL !xorCache min Tip = min 116 | goL !xorCache min (Bin max l r) 117 | | max < k = max 118 | | xorCache < xorCacheMax = goL xorCache min l 119 | | otherwise = goR xorCacheMax max r min l 120 | where xorCacheMax = xor k max 121 | 122 | goR !xorCache max Tip fMin fallback = getMax fMin fallback 123 | goR !xorCache max (Bin min l r) fMin fallback 124 | | min >= k = getMax fMin fallback 125 | | xorCache < xorCacheMin = goR xorCache max r min l 126 | | otherwise = goL xorCacheMin min l 127 | where xorCacheMin = xor min k 128 | 129 | getMax min Tip = min 130 | getMax min (Bin max _ _) = max 131 | 132 | -- | /O(log n)/. Find largest element smaller or equal to the given one. 133 | -- 134 | -- > lookupLE 2 (fromList [3, 5]) == Nothing 135 | -- > lookupLE 4 (fromList [3, 5]) == Just 3 136 | -- > lookupLE 5 (fromList [3, 5]) == Just 5 137 | lookupLE :: Key -> WordSet -> Maybe Key 138 | lookupLE k = k `seq` start 139 | where 140 | start Empty = Nothing 141 | start (NonEmpty min node) 142 | | min > k = Nothing 143 | | otherwise = Just (goL (xor min k) min node) 144 | 145 | goL !xorCache min Tip = min 146 | goL !xorCache min (Bin max l r) 147 | | max <= k = max 148 | | xorCache < xorCacheMax = goL xorCache min l 149 | | otherwise = goR xorCacheMax max r min l 150 | where xorCacheMax = xor k max 151 | 152 | goR !xorCache max Tip fMin fallback = getMax fMin fallback 153 | goR !xorCache max (Bin min l r) fMin fallback 154 | | min > k = getMax fMin fallback 155 | | xorCache < xorCacheMin = goR xorCache max r min l 156 | | otherwise = goL xorCacheMin min l 157 | where xorCacheMin = xor min k 158 | 159 | getMax min Tip = min 160 | getMax min (Bin max _ _) = max 161 | 162 | -- | /O(log n)/. Find smallest element greater than the given one. 163 | -- 164 | -- > lookupGT 4 (fromList [3, 5]) == Just 5 165 | -- > lookupGT 5 (fromList [3, 5]) == Nothing 166 | lookupGT :: Key -> WordSet -> Maybe Key 167 | lookupGT k = k `seq` start 168 | where 169 | start Empty = Nothing 170 | start (NonEmpty min Tip) 171 | | min > k = Just min 172 | | otherwise = Nothing 173 | start (NonEmpty min (Bin max l r)) 174 | | min > k = Just min 175 | | max > k = Just (goR (xor k max) max (Bin min l r)) 176 | | otherwise = Nothing 177 | 178 | goL !xorCache min Tip fMax fallback = getMin fMax fallback 179 | goL !xorCache min (Bin max l r) fMax fallback 180 | | max <= k = getMin fMax fallback 181 | | xorCache < xorCacheMax = goL xorCache min l fMax fallback 182 | | otherwise = goR xorCacheMax max r 183 | where xorCacheMax = xor k max 184 | 185 | goR !xorCache max Tip = max 186 | goR !xorCache max (Bin min l r) 187 | | min > k = min 188 | | xorCache < xorCacheMin = goR xorCache max r 189 | | otherwise = goL xorCacheMin min l max r 190 | where xorCacheMin = xor min k 191 | 192 | getMin max Tip = max 193 | getMin max (Bin min _ _) = min 194 | 195 | -- | /O(log n)/. Find smallest element greater or equal to the given one. 196 | -- 197 | -- > lookupGE 3 (fromList [3, 5]) == Just 3 198 | -- > lookupGE 4 (fromList [3, 5]) == Just 5 199 | -- > lookupGE 6 (fromList [3, 5]) == Nothing 200 | lookupGE :: Key -> WordSet -> Maybe Key 201 | lookupGE k = k `seq` start 202 | where 203 | start Empty = Nothing 204 | start (NonEmpty min Tip) 205 | | min >= k = Just min 206 | | otherwise = Nothing 207 | start (NonEmpty min (Bin max l r)) 208 | | min >= k = Just min 209 | | max >= k = Just (goR (xor k max) max (Bin min l r)) 210 | | otherwise = Nothing 211 | 212 | goL !xorCache min Tip fMax fallback = getMin fMax fallback 213 | goL !xorCache min (Bin max l r) fMax fallback 214 | | max < k = getMin fMax fallback 215 | | xorCache < xorCacheMax = goL xorCache min l fMax fallback 216 | | otherwise = goR xorCacheMax max r 217 | where xorCacheMax = xor k max 218 | 219 | goR !xorCache max Tip = max 220 | goR !xorCache max (Bin min l r) 221 | | min >= k = min 222 | | xorCache < xorCacheMin = goR xorCache max r 223 | | otherwise = goL xorCacheMin min l max r 224 | where xorCacheMin = xor min k 225 | 226 | getMin max Tip = max 227 | getMin max (Bin min _ _) = min 228 | -} 229 | -- | /O(1)/. The empty map. 230 | empty :: WordSet 231 | empty = Empty 232 | 233 | -- | /O(1)/. A map of one element. 234 | singleton :: Key -> WordSet 235 | singleton k = NonEmpty k Tip 236 | 237 | -- | /O(min(n,W))/. Insert a new key\/value pair in the map. 238 | -- If the key is already present in the map, the associated value 239 | -- is replaced with the supplied value. 240 | insert :: Key -> WordSet -> WordSet 241 | insert k = k `seq` start 242 | where 243 | start Empty = NonEmpty k Tip 244 | start n@(NonEmpty min root) 245 | | k > min = NonEmpty min (goL (xor min k) min root) 246 | | k < min = NonEmpty k (endL (xor min k) min root) 247 | | otherwise = n 248 | 249 | goL !xorCache min Tip 250 | | xorCache <= suffixMask = BM k (getSuf min .|. getSuf k) 251 | | otherwise = Bin k Tip Tip 252 | goL !xorCache _ n@(BM max bm) 253 | | k <= max = BM max (bm .|. getSuf k) 254 | | xorCache <= suffixMask = BM k (bm .|. getSuf k) 255 | | otherwise = Bin k n Tip 256 | goL !xorCache min n@(Bin max l r) 257 | | k < max = if xorCache < xorCacheMax 258 | then Bin max (goL xorCache min l) r 259 | else Bin max l (goR xorCacheMax max r) 260 | | k > max = if xor min max < xorCacheMax 261 | then Bin k (Bin max l r) Tip 262 | else Bin k l (endR xorCacheMax max r) 263 | | otherwise = n 264 | where xorCacheMax = xor k max 265 | 266 | goR !xorCache max Tip 267 | | xorCache <= suffixMask = BM k (getSuf k .|. getSuf max) 268 | | otherwise = Bin k Tip Tip 269 | goR !xorCache _ n@(BM min bm) 270 | | k >= min = BM min (bm .|. getSuf k) 271 | | xorCache <= suffixMask = BM k (bm .|. getSuf k) 272 | | otherwise = Bin k Tip n 273 | goR !xorCache max n@(Bin min l r) 274 | | k > min = if xorCache < xorCacheMin 275 | then Bin min l (goR xorCache max r) 276 | else Bin min (goL xorCacheMin min l) r 277 | | k < min = if xor min max < xorCacheMin 278 | then Bin k Tip (Bin min l r) 279 | else Bin k (endL xorCacheMin min l) r 280 | | otherwise = n 281 | where xorCacheMin = xor min k 282 | 283 | endL !xorCache min = finishL 284 | where 285 | finishL Tip 286 | | xorCache <= suffixMask = BM min (getSuf k .|. getSuf min) 287 | | otherwise = Bin min Tip Tip 288 | finishL (BM max bm) 289 | | xorCache <= suffixMask = BM max (bm .|. getSuf k) 290 | | otherwise = Bin max Tip (BM min bm) 291 | finishL (Bin max l r) 292 | | xor min max < xorCache = Bin max Tip (Bin min l r) 293 | | otherwise = Bin max (finishL l) r 294 | 295 | endR !xorCache max = finishR 296 | where 297 | finishR Tip 298 | | xorCache <= suffixMask = BM max (getSuf max .|. getSuf k) 299 | | otherwise = Bin max Tip Tip 300 | finishR (BM min bm) 301 | | xorCache <= suffixMask = BM min (bm .|. getSuf k) 302 | | otherwise = Bin min (BM max bm) Tip 303 | finishR (Bin min l r) 304 | | xor min max < xorCache = Bin min (Bin max l r) Tip 305 | | otherwise = Bin min l (finishR r) 306 | 307 | -- | /O(min(n,W))/. Delete a key and its value from the map. 308 | -- When the key is not a member of the map, the original map is returned. 309 | delete :: Key -> WordSet -> WordSet 310 | delete k = k `seq` start 311 | where 312 | start Empty = Empty 313 | start m@(NonEmpty min Tip) 314 | | k == min = Empty 315 | | otherwise = m 316 | start m@(NonEmpty min (BM max bm)) 317 | | k < min || k > max = m 318 | | k == min = if bm' == getSuf max 319 | then NonEmpty max Tip 320 | else NonEmpty (prefixOf k .|. getMinBM bm') (BM max bm') 321 | | k == max = if bm' == getSuf min 322 | then NonEmpty min Tip 323 | else NonEmpty min (BM (prefixOf k .|. getMaxBM bm') bm') 324 | | otherwise = NonEmpty min (BM max bm') 325 | where 326 | bm' = bm .&. complement (getSuf k) 327 | start m@(NonEmpty min root@(Bin max l r)) 328 | | k < min = m 329 | | k == min = let DR min' root' = goDeleteMin min max l r in NonEmpty min' root' 330 | | otherwise = NonEmpty min (goL (xor min k) min root) 331 | 332 | goL !_ _ Tip = Tip 333 | goL !xorCache min n@(BM max bm) 334 | | k < max = BM max bm' 335 | | k == max = if bm' == getSuf min 336 | then Tip 337 | else BM (prefixOf max .|. getMaxBM bm') bm' 338 | | otherwise = n 339 | where 340 | bm' = bm .&. complement (getSuf k) 341 | goL !xorCache min n@(Bin max l r) 342 | | k < max = if xorCache < xorCacheMax 343 | then Bin max (goL xorCache min l) r 344 | else Bin max l (goR xorCacheMax max r) 345 | | k > max = n 346 | | otherwise = case r of 347 | Tip -> l 348 | BM minI bm | bm' == getSuf minI -> Bin minI l Tip 349 | | otherwise -> Bin (prefixOf max .|. getMaxBM bm') l (BM minI bm') 350 | where 351 | bm' = bm .&. complement (getSuf max) 352 | Bin minI lI rI -> let DR max' r' = goDeleteMax max minI lI rI 353 | in Bin max' l r' 354 | where xorCacheMax = xor k max 355 | 356 | goR !_ _ Tip = Tip 357 | goR !xorCache max n@(BM min bm) 358 | | k > min = BM min bm' 359 | | k == min = if bm' == getSuf max 360 | then Tip 361 | else BM (prefixOf min .|. getMinBM bm') bm' 362 | | otherwise = n 363 | where 364 | bm' = bm .&. complement (getSuf k) 365 | goR !xorCache max n@(Bin min l r) 366 | | k > min = if xorCache < xorCacheMin 367 | then Bin min l (goR xorCache max r) 368 | else Bin min (goL xorCacheMin min l) r 369 | | k < min = n 370 | | otherwise = case l of 371 | Tip -> r 372 | BM maxI bm | bm' == getSuf maxI -> Bin maxI Tip r 373 | | otherwise -> Bin (prefixOf min .|. getMinBM bm') (BM maxI bm') r 374 | where 375 | bm' = bm .&. complement (getSuf min) 376 | Bin maxI lI rI -> let DR min' l' = goDeleteMin min maxI lI rI 377 | in Bin min' l' r 378 | where xorCacheMin = xor min k 379 | 380 | goDeleteMin min max l r = case l of 381 | Tip -> case r of 382 | Tip -> DR max Tip 383 | BM minI bm -> DR minI (BM max bm) 384 | Bin minI lI rI -> DR minI (Bin max lI rI) 385 | BM maxI bm | bm' == getSuf maxI -> DR maxI (Bin max Tip r) 386 | | otherwise -> DR (prefixOf min .|. getMinBM bm') (Bin max (BM maxI bm') r) 387 | where 388 | bm' = bm .&. complement (getSuf min) 389 | Bin maxI lI rI -> let DR min' l' = goDeleteMin min maxI lI rI 390 | in DR min' (Bin max l' r) 391 | 392 | goDeleteMax max min l r = case r of 393 | Tip -> case l of 394 | Tip -> DR min Tip 395 | BM maxI bm -> DR maxI (BM min bm) 396 | Bin maxI lI rI -> DR maxI (Bin min lI rI) 397 | BM minI bm | bm' == getSuf minI -> DR minI (Bin min l Tip) 398 | | otherwise -> DR (prefixOf max .|. getMaxBM bm') (Bin min l (BM minI bm')) 399 | where 400 | bm' = bm .&. complement (getSuf max) 401 | Bin minI lI rI -> let DR max' r' = goDeleteMax max minI lI rI 402 | in DR max' (Bin min l r') 403 | 404 | -- TODO: Does a strict pair work? My guess is not, as GHC was already 405 | -- unboxing the tuple, but it would be simpler to use one of those. 406 | -- | Without this specialized type (I was just using a tuple), GHC's 407 | -- CPR correctly unboxed the tuple, but it couldn't unbox the returned 408 | -- Key, leading to lots of inefficiency (3x slower than stock Data.WordMap) 409 | data DeleteResult a = DR {-# UNPACK #-} !Key !a 410 | 411 | -- TODO: Optimize 412 | -- | /O(n+m)/. The union of two sets. 413 | union :: WordSet -> WordSet -> WordSet 414 | union l r = foldr' insert r l 415 | 416 | -- | The union of a list of sets. 417 | unions :: [WordSet] -> WordSet 418 | unions = List.foldl' union empty 419 | 420 | -- | /O(n+m)/. Difference between two sets. 421 | difference :: WordSet -> WordSet -> WordSet 422 | difference = foldr' delete 423 | 424 | -- | /O(n+m)/. The intersection of two sets. 425 | intersection :: WordSet -> WordSet -> WordSet 426 | intersection l = filter (`member` l) 427 | 428 | map :: (Key -> Key) -> WordSet -> WordSet 429 | map f = fromList . List.map f . toList 430 | 431 | -- | /O(n)/. Fold the elements in the set using the given right-associative 432 | -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@. 433 | -- 434 | -- For example, 435 | -- 436 | -- > toAscList set = foldr (:) [] set 437 | foldr :: (Key -> b -> b) -> b -> WordSet -> b 438 | foldr f z = start 439 | where 440 | start Empty = z 441 | start (NonEmpty min root) = f min $ goL min root z 442 | 443 | goL _ Tip acc = acc 444 | goL min (BM _ bm) acc = goBM (prefixOf min) (bm .&. complement (getSuf min)) acc 445 | goL min (Bin max l r) acc = goL min l $ goR max r $ f max acc 446 | 447 | goR _ Tip acc = acc 448 | goR max (BM _ bm) acc = goBM (prefixOf max) (bm .&. complement (getSuf max)) acc 449 | goR max (Bin min l r) acc = f min $ goL min l $ goR max r acc 450 | 451 | goBM pre = pre `seq` loop 452 | where 453 | loop 0 acc = acc 454 | loop bm acc = let min = pre .|. getMinBM bm 455 | bm' = bm .&. complement (getSuf min) 456 | in f min (loop bm' acc) 457 | 458 | -- | /O(n)/. Fold the elements in the set using the given left-associative 459 | -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@. 460 | -- 461 | -- For example, 462 | -- 463 | -- > toDescList set = foldl (flip (:)) [] set 464 | foldl :: (a -> Key -> a) -> a -> WordSet -> a 465 | foldl f z = start 466 | where 467 | start Empty = z 468 | start (NonEmpty min root) = goL min (f z min) root 469 | 470 | goL _ acc Tip = acc 471 | goL min acc (BM _ bm) = goBM (prefixOf min) acc (bm .&. complement (getSuf min)) 472 | goL min acc (Bin max l r) = f (goR max (goL min acc l) r) max 473 | 474 | goR _ acc Tip = acc 475 | goR max acc (BM _ bm) = goBM (prefixOf max) acc (bm .&. complement (getSuf max)) 476 | goR max acc (Bin min l r) = goR max (goL min (f acc min) l) r 477 | 478 | goBM pre = pre `seq` loop 479 | where 480 | loop acc 0 = acc 481 | loop acc bm = let min = pre .|. getMinBM bm 482 | bm' = bm .&. complement (getSuf min) 483 | in loop (f acc min) bm' 484 | 485 | -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is 486 | -- evaluated before using the result in the next application. This 487 | -- function is strict in the starting value. 488 | foldr' :: (Key -> b -> b) -> b -> WordSet -> b 489 | foldr' f z = start 490 | where 491 | start Empty = z 492 | start (NonEmpty min root) = f min $! goL min root z 493 | 494 | goL _ Tip acc = acc 495 | goL min (BM _ bm) acc = goBM (prefixOf min) (bm .&. complement (getSuf min)) $! acc 496 | goL min (Bin max l r) acc = goL min l $! goR max r $! f max $! acc 497 | 498 | goR _ Tip acc = acc 499 | goR max (BM _ bm) acc = goBM (prefixOf max) (bm .&. complement (getSuf max)) $! acc 500 | goR max (Bin min l r) acc = f min $! goL min l $! goR max r acc 501 | 502 | goBM pre = pre `seq` loop 503 | where 504 | loop 0 acc = acc 505 | loop bm acc = let min = pre .|. getMinBM bm 506 | bm' = bm .&. complement (getSuf min) 507 | in f min $! loop bm' $! acc 508 | 509 | -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is 510 | -- evaluated before using the result in the next application. This 511 | -- function is strict in the starting value. 512 | foldl' :: (a -> Key -> a) -> a -> WordSet -> a 513 | foldl' f z = start 514 | where 515 | start Empty = z 516 | start (NonEmpty min root) = s (goL min) (f z min) root 517 | 518 | goL _ acc Tip = acc 519 | goL min acc (BM _ bm) = s (goBM (prefixOf min)) acc (bm .&. complement (getSuf min)) 520 | goL min acc (Bin max l r) = s f (s (goR max) (s (goL min) acc l) r) max 521 | 522 | goR _ acc Tip = acc 523 | goR max acc (BM _ bm) = goBM (prefixOf max) acc (bm .&. complement (getSuf max)) 524 | goR max acc (Bin min l r) = s (goR max) (s (goL min) (s f acc min) l) r 525 | 526 | goBM pre = pre `seq` loop 527 | where 528 | loop acc 0 = acc 529 | loop acc bm = let min = pre .|. getMinBM bm 530 | bm' = bm .&. complement (getSuf min) 531 | in s loop (s f acc min) bm' 532 | 533 | s = ($!) 534 | 535 | -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. 536 | fromList :: [Key] -> WordSet 537 | fromList = List.foldr insert empty 538 | 539 | -- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order. 540 | elems :: WordSet -> [Key] 541 | elems = toAscList 542 | 543 | -- | /O(n)/. Convert the set to a list of elements. 544 | toList :: WordSet -> [Key] 545 | toList = toAscList 546 | 547 | -- | /O(n)/. Convert the set to an ascending list of elements. 548 | toAscList :: WordSet -> [Key] 549 | toAscList = foldr (:) [] 550 | 551 | -- | /O(n)/. Convert the set to a descending list of elements. 552 | toDescList :: WordSet -> [Key] 553 | toDescList = foldl (flip (:)) [] 554 | 555 | -- | /O(n)/. Build a set from an ascending list of elements. 556 | -- /The precondition (input list is ascending) is not checked./ 557 | fromAscList :: [Key] -> WordSet 558 | fromAscList = fromList 559 | 560 | -- | /O(n)/. Build a set from an ascending list of distinct elements. 561 | -- /The precondition (input list is strictly ascending) is not checked./ 562 | fromDistinctAscList :: [Key] -> WordSet 563 | fromDistinctAscList = fromList 564 | 565 | -- TODO: Optimize 566 | -- | /O(n)/. Filter all elements that satisfy some predicate. 567 | filter :: (Key -> Bool) -> WordSet -> WordSet 568 | filter p = fromDistinctAscList . List.filter p . toAscList 569 | 570 | -- TODO: Optimize 571 | -- | /O(n)/. partition the set according to some predicate. 572 | partition :: (Key -> Bool) -> WordSet -> (WordSet, WordSet) 573 | partition p s = let (t, f) = List.partition p (toAscList s) 574 | in (fromDistinctAscList t, fromDistinctAscList f) 575 | 576 | -- | /O(1)/. The minimal element of the set. 577 | findMin :: WordSet -> Word 578 | findMin Empty = error "findMin: empty set has no minimal element" 579 | findMin (NonEmpty min _) = min 580 | 581 | -- | /O(1)/. The maximal element of a set. 582 | findMax :: WordSet -> Word 583 | findMax Empty = error "findMax: empty set has no maximal element" 584 | findMax (NonEmpty min Tip) = min 585 | findMax (NonEmpty _ (BM max _)) = max 586 | findMax (NonEmpty _ (Bin max _ _)) = max 587 | 588 | deleteMin :: WordSet -> WordSet 589 | deleteMin Empty = Empty 590 | deleteMin m = delete (findMin m) m 591 | 592 | deleteMax :: WordSet -> WordSet 593 | deleteMax Empty = Empty 594 | deleteMax m = delete (findMin m) m 595 | 596 | ---------------------------- 597 | {- 598 | -- | Show the tree that implements the map. 599 | showTree :: WordSet -> String 600 | showTree = unlines . aux where 601 | aux Empty = [] 602 | aux (NonEmpty min node) = show min : auxNode False node 603 | auxNode _ Tip = ["+-."] 604 | auxNode _ (BM pre bm) = ["+-" ++ show pre ++ " " ++ show bm] 605 | auxNode lined (Bin bound l r) = ["+--" ++ show bound, prefix : " |"] ++ fmap indent (auxNode True l) ++ [prefix : " |"] ++ fmap indent (auxNode False r) 606 | where 607 | prefix = if lined then '|' else ' ' 608 | indent r = prefix : " " ++ r 609 | 610 | valid :: WordSet -> Bool 611 | valid Empty = True 612 | valid (NonEmpty min root) = allKeys (> min) root && goL min root 613 | where 614 | goL min Tip = True 615 | goL min (Bin max l r) = 616 | allKeys (< max) l 617 | && allKeys (< max) r 618 | && allKeys (\k -> xor min k < xor k max) l 619 | && allKeys (\k -> xor min k > xor k max) r 620 | && goL min l 621 | && goR max r 622 | 623 | goR max Tip = True 624 | goR max (Bin min l r) = 625 | allKeys (> min) l 626 | && allKeys (> min) r 627 | && allKeys (\k -> xor min k < xor k max) l 628 | && allKeys (\k -> xor min k > xor k max) r 629 | && goL min l 630 | && goR max r 631 | 632 | allKeys p Tip = True 633 | allKeys p (Bin b l r) = p b && allKeys p l && allKeys p r 634 | -} 635 | -------------------------- 636 | 637 | getMinBM, getMaxBM :: BitMap -> Word 638 | getMinBM bm = fromIntegral (trailingZeros bm) 639 | getMaxBM bm = fromIntegral (bitSize bm) - 1 - fromIntegral (leadingZeros bm) 640 | 641 | prefixMask, suffixMask :: Word 642 | prefixMask = complement suffixMask 643 | suffixMask = fromIntegral (bitSize (undefined :: Word)) - 1 644 | 645 | prefixOf, suffixOf :: Word -> Word 646 | prefixOf = (.&. prefixMask) 647 | suffixOf = (.&. suffixMask) 648 | 649 | getSuf :: Word -> Word 650 | getSuf k = 1 `unsafeShiftL` fromIntegral (suffixOf k) 651 | -------------------------------------------------------------------------------- /tests/WordMap.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty 2 | import Test.Tasty.QuickCheck 3 | import Test.QuickCheck.Function 4 | import Test.Tasty.HUnit 5 | 6 | import Data.Word 7 | import Data.WordMap 8 | 9 | import Prelude hiding (lookup, null, filter, foldr, foldl, map) 10 | 11 | instance Function Word where 12 | function = functionMap (fromIntegral :: Word -> Int) fromIntegral 13 | 14 | instance Arbitrary a => Arbitrary (WordMap a) where 15 | arbitrary = fmap fromList arbitrary 16 | 17 | main :: IO () 18 | main = defaultMain $ testGroup "Tests" [properties, unitTests] 19 | 20 | properties :: TestTree 21 | properties = testGroup "Properties" 22 | [ testProperty "fromList/toList" $ \m -> (m :: WordMap Int) == fromList (toList m) 23 | , testProperty "lookup/insert" $ \k v m -> lookup k (insert k v (m :: WordMap Int)) == Just v 24 | , testProperty "lookup/delete" $ \k m -> lookup k (delete k (m :: WordMap Int)) == Nothing 25 | , testProperty "lookup/alter" $ \(Fun _ f) k m -> lookup k (alter f k (m :: WordMap Int)) == f (lookup k m) 26 | , testProperty "insertLookupWithKey spec" $ \(Fun _ f) k v m -> insertLookupWithKey (curry3 f) k v (m :: WordMap Int) == (lookup k m, insertWithKey (curry3 f) k v m) 27 | , testProperty "updateLookupWithKey spec" $ \(Fun _ f) k m -> updateLookupWithKey (curry f) k (m :: WordMap Int) == (lookup k m, updateWithKey (curry f) k m) 28 | , testGroup "Union" 29 | [ testProperty "Associativity" $ \m1 m2 m3 -> union (union m1 m2) (m3 :: WordMap Int) == union m1 (union m2 m3) 30 | , testProperty "Commutativity" $ \(Fun _ f) m1 m2 -> unionWithKey (curry3 f) (m1 :: WordMap Int) m2 == unionWithKey (\k v1 v2 -> curry3 f k v2 v1) m2 m1 31 | ] 32 | , testGroup "Intersection" 33 | [ testProperty "Associativity" $ \m1 m2 m3 -> intersection (intersection (m1 :: WordMap Int) (m2 :: WordMap Int)) (m3 :: WordMap Int) == intersection m1 (intersection m2 m3) 34 | , testProperty "Commutativity" $ \(Fun _ f) m1 m2 -> intersectionWithKey (curry3 f) (m1 :: WordMap Int) (m2 :: WordMap Int) == intersectionWithKey (\k v1 v2 -> curry3 f k v2 v1 :: Int) m2 m1 35 | , testProperty "Specification" $ \(Fun _ f) m1 m2 -> intersectionWithKey (curry3 f) (m1 :: WordMap Int) (m2 :: WordMap Int) == (mapMaybeWithKey (\k v -> fmap (curry3 f k v) (lookup k m2)) m1 :: WordMap Int) 36 | ] 37 | , testGroup "Split" 38 | [ testProperty "Specification" $ \k m -> splitLookup k (m :: WordMap Int) == (filterWithKey (\k' _ -> k' < k) m, lookup k m, filterWithKey (\k' _ -> k' > k) m) 39 | ] 40 | , testGroup "Partition" 41 | [ testProperty "Specification" $ \(Fun _ f) m -> partitionWithKey (curry f) (m :: WordMap Int) == (filterWithKey (curry f) m, filterWithKey (curry (not . f)) m) 42 | ] 43 | ] 44 | 45 | unitTests :: TestTree 46 | unitTests = testGroup "Unit Tests" 47 | [ testGroup "Operators" 48 | [ testCase "(!)" $ fromList [(5,'a'), (3,'b')] ! 5 @?= 'a' 49 | ] 50 | , testGroup "Query" 51 | [ testGroup "null" 52 | [ testCase "empty" $ null empty @?= True 53 | , testCase "singleton" $ null (singleton 1 'a') @?= False 54 | ] 55 | , testGroup "size" 56 | [ testCase "empty" $ size empty @?= 0 57 | , testCase "singleton" $ size (singleton 1 'a') @?= 1 58 | , testCase "many" $ size (fromList [(1,'a'), (2,'c'), (3,'b')]) @?= 3 59 | ] 60 | , testGroup "member" 61 | [ testCase "present" $ member 5 (fromList [(5,'a'), (3,'b')]) @?= True 62 | , testCase "absent" $ member 1 (fromList [(5,'a'), (3,'b')]) @?= False 63 | ] 64 | , testGroup "findWithDefault" 65 | [ testCase "absent" $ findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) @?= 'x' 66 | , testCase "present" $ findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) @?= 'a' 67 | ] 68 | , testGroup "lookupLT" 69 | [ testCase "Nothing (equal)" $ lookupLT 3 (fromList [(3,'a'), (5,'b')]) @?= Nothing 70 | , testCase "Just" $ lookupLT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a') 71 | ] 72 | , testGroup "lookupGT" 73 | [ testCase "Just" $ lookupGT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b') 74 | , testCase "Nothing (equal)" $ lookupGT 5 (fromList [(3,'a'), (5,'b')]) @?= Nothing 75 | ] 76 | , testGroup "lookupLE" 77 | [ testCase "Nothing" $ lookupLE 2 (fromList [(3,'a'), (5,'b')]) @?= Nothing 78 | , testCase "Just (not equal)" $ lookupLE 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a') 79 | , testCase "Just (equal)" $ lookupLE 5 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b') 80 | ] 81 | , testGroup "lookupGE" 82 | [ testCase "Just (equal)" $ lookupGE 3 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a') 83 | , testCase "Just (not equal)" $ lookupGE 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b') 84 | , testCase "Nothing" $ lookupGE 6 (fromList [(3,'a'), (5,'b')]) @?= Nothing 85 | ] 86 | ] 87 | , testGroup "Construction" 88 | [ testGroup "empty" 89 | [ testCase "fromList" $ empty @?= fromList ([] :: [(Word, Char)]) 90 | , testCase "size" $ size empty @?= 0 91 | ] 92 | , testGroup "singleton" 93 | [ testCase "fromList" $ singleton 1 'a' @?= fromList [(1, 'a')] 94 | , testCase "size" $ size (singleton 1 'a') @?= 1 95 | ] 96 | , testGroup "Insertion" 97 | [ testGroup "insert" 98 | [ testCase "override" $ insert 5 'x' (fromList [(5,'a'), (3,'b')]) @?= fromList [(3, 'b'), (5, 'x')] 99 | , testCase "insert (full)" $ insert 7 'x' (fromList [(5,'a'), (3,'b')]) @?= fromList [(3, 'b'), (5, 'a'), (7, 'x')] 100 | , testCase "insert (empty)" $ insert 5 'x' empty @?= singleton 5 'x' 101 | ] 102 | , testGroup "insertWith" 103 | [ testCase "override" $ insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "xxxa")] 104 | , testCase "insert (full)" $ insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "xxx")] 105 | , testCase "insert (empty)" $ insertWith (++) 5 "xxx" empty @?= singleton 5 "xxx" 106 | ] 107 | , let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 108 | in testGroup "insertWithKey" 109 | [ testCase "override" $ insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:xxx|a")] 110 | , testCase "insert (full)" $ insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "xxx")] 111 | , testCase "insert (empty)" $ insertWithKey f 5 "xxx" empty @?= singleton 5 "xxx" 112 | ] 113 | , let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 114 | in testGroup "insertLookupWithKey" 115 | [ testCase "override" $ insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:xxx|a")]) 116 | , testCase "insert (full)" $ insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")]) 117 | , testCase "insert (empty)" $ insertLookupWithKey f 5 "xxx" empty @?= (Nothing, singleton 5 "xxx") 118 | ] 119 | ] 120 | , testGroup "Delete/Update" 121 | [ testGroup "delete" 122 | [ testCase "present" $ delete 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" 123 | , testCase "absent (full)" $ delete 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 124 | , testCase "absent (empty)" $ delete 5 empty @?= (empty :: WordMap Char) 125 | ] 126 | , testGroup "adjust" 127 | [ testCase "present" $ adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "new a")] 128 | , testCase "absent (full)" $ adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 129 | , testCase "absent (empty)" $ adjust ("new " ++) 7 empty @?= empty 130 | ] 131 | , let f key x = (show key) ++ ":new " ++ x 132 | in testGroup "adjustWithKey" 133 | [ testCase "present" $ adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:new a")] 134 | , testCase "absent (full)" $ adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 135 | , testCase "absent (empty)" $ adjustWithKey f 7 empty @?= empty 136 | ] 137 | , let f x = if x == "a" then Just "new a" else Nothing 138 | in testGroup "update" 139 | [ testCase "present (adjust)" $ update f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "new a")] 140 | , testCase "absent" $ update f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 141 | , testCase "present (delete)" $ update f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 142 | ] 143 | , let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 144 | in testGroup "updateWithKey" 145 | [ testCase "present (adjust)" $ updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "5:new a")] 146 | , testCase "absent" $ updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")] 147 | , testCase "present (delete)" $ updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 148 | ] 149 | , let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing 150 | in testGroup "updateLookupWithKey" 151 | [ testCase "present (adjust)" $ updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:new a")]) 152 | , testCase "absent" $ updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= (Nothing, fromList [(3, "b"), (5, "a")]) 153 | , testCase "present (delete)" $ updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= (Just "b", singleton 5 "a") 154 | ] 155 | ] 156 | ] 157 | , testGroup "Combine" 158 | [ testGroup "Union" 159 | [ testCase "union" $ union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")] 160 | , testCase "unionWith" $ unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "aA"), (7, "C")] 161 | , let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value 162 | in testCase "unionWithKey" $ unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "5:a|A"), (7, "C")] 163 | , testGroup "unions" 164 | [ testCase "lower->upper" $ unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] @?= fromList [(3, "b"), (5, "a"), (7, "C")] 165 | , testCase "upper->lower" $ unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])] @?= fromList [(3, "B3"), (5, "A3"), (7, "C")] 166 | ] 167 | , testCase "unionsWith" $ unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])] @?= fromList [(3, "bB3"), (5, "aAA3"), (7, "C")] 168 | ] 169 | , testGroup "Difference" 170 | [ testCase "difference" $ difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 3 "b" 171 | , let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing 172 | in testCase "differenceWith" $ differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")]) @?= singleton 3 "b:B" 173 | , let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing 174 | in testCase "differenceWithKey" $ differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")]) @?= singleton 3 "3:b|B" 175 | ] 176 | , testGroup "Intersection" 177 | [ testCase "intersection" $ intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a" 178 | , testCase "intersectionWith" $ intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA" 179 | , let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar 180 | in testCase "intersectionWithKey" $ intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "5:a|A" 181 | ] 182 | ] 183 | , testGroup "Traversal" 184 | [ testGroup "Map" 185 | [ testCase "map" $ map (++ "x") (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "bx"), (5, "ax")] 186 | , let f key x = (show key) ++ ":" ++ x 187 | in testCase "mapWithKey" $ mapWithKey f (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "3:b"), (5, "5:a")] 188 | , testGroup "traverseWithKey" 189 | [ testCase "present" $ traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) @?= Just (fromList [(1, 'b'), (5, 'f')]) 190 | , testCase "absent" $ traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) @?= Nothing 191 | ] 192 | , let f a b = (a ++ b, b ++ "X") 193 | in testCase "mapAccum" $ mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) @?= ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) 194 | , let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") 195 | in testCase "mapAccumWithKey" $ mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) 196 | -- NOTE: This isn't in the docs 197 | , let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") 198 | in testCase "mapAccumRWithKey" $ mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 5-a 3-b", fromList [(3, "bX"), (5, "aX")]) 199 | , testGroup "mapKeys" 200 | [ testCase "simple" $ mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) @?= fromList [(4, "b"), (6, "a")] 201 | , testCase "collapse1" $ mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "c" 202 | , testCase "collapse3" $ mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "c" 203 | ] 204 | , testGroup "mapKeysWith" 205 | [ testCase "collapse1" $ mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 1 "cdab" 206 | , testCase "collapse3" $ mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) @?= singleton 3 "cdab" 207 | ] 208 | , testCase "mapKeysMonotonic" $ mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) @?= fromList [(6, "b"), (10, "a")] 209 | ] 210 | ] 211 | , testGroup "Folds" 212 | [ let f a len = len + (length a) 213 | in testCase "foldr" $ foldr f 0 (fromList [(5,"a"), (3,"bbb")]) @?= 4 214 | , let f len a = len + (length a) 215 | in testCase "foldl" $ foldl f 0 (fromList [(5,"a"), (3,"bbb")]) @?= 4 216 | , let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" 217 | in testCase "foldrWithKey" $ foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) @?= "Map: (5:a)(3:b)" 218 | , let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" 219 | in testCase "foldlWithKey" $ foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) @?= "Map: (3:b)(5:a)" 220 | -- FIXME: foldMapWithKey 221 | , testGroup "Strict folds" -- NOTE: These aren't in the docs 222 | [ let f a len = len + (length a) 223 | in testCase "foldr'" $ foldr' f 0 (fromList [(5,"a"), (3,"bbb")]) @?= 4 224 | , let f len a = len + (length a) 225 | in testCase "foldl'" $ foldl' f 0 (fromList [(5,"a"), (3,"bbb")]) @?= 4 226 | , let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" 227 | in testCase "foldrWithKey'" $ foldrWithKey' f "Map: " (fromList [(5,"a"), (3,"b")]) @?= "Map: (5:a)(3:b)" 228 | , let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" 229 | in testCase "foldlWithKey'" $ foldlWithKey' f "Map: " (fromList [(5,"a"), (3,"b")]) @?= "Map: (3:b)(5:a)" 230 | ] 231 | ] 232 | , testGroup "Conversion" 233 | [ testGroup "elems" 234 | [ testCase "full" $ elems (fromList [(5,"a"), (3,"b")]) @?= ["b","a"] 235 | , testCase "empty" $ elems empty @?= ([] :: [Char]) 236 | ] 237 | , testGroup "keys" 238 | [ testCase "full" $ keys (fromList [(5,"a"), (3,"b")]) @?= [3,5] 239 | , testCase "empty" $ keys empty @?= ([] :: [Word]) 240 | ] 241 | , testGroup "assocs" 242 | [ testCase "full" $ assocs (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")] 243 | , testCase "empty" $ assocs empty @?= ([] :: [(Word, Char)]) 244 | ] 245 | -- TODO: keysSet (unimplemented) 246 | -- TODO: fromSet (unimplemented) 247 | , testGroup "Lists" 248 | [ testGroup "toList" 249 | [ testCase "full" $ toList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")] 250 | , testCase "empty" $ toList empty @?= ([] :: [(Word, Char)]) 251 | ] 252 | , testGroup "fromList" 253 | [ testCase "empty" $ fromList ([] :: [(Word, Char)]) @?= empty 254 | , testCase "combine1" $ fromList [(5,"a"), (3,"b"), (5, "c")] @?= fromList [(5,"c"), (3,"b")] 255 | , testCase "combine2" $ fromList [(5,"c"), (3,"b"), (5, "a")] @?= fromList [(5,"a"), (3,"b")] 256 | ] 257 | , testGroup "fromListWith" 258 | [ testCase "full" $ fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] @?= fromList [(3, "ab"), (5, "cba")] 259 | , testCase "empty" $ fromListWith (++) ([] :: [(Word, String)]) @?= empty 260 | ] 261 | , let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 262 | in testGroup "fromListWithKey" 263 | [ testCase "full" $ fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] @?= fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] 264 | , testCase "empty" $ fromListWithKey f ([] :: [(Word, String)]) @?= empty 265 | ] 266 | ] 267 | , testGroup "Ordered lists" 268 | [ testCase "toAscList" $ toAscList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")] 269 | , testCase "toDescList" $ toDescList (fromList [(5,"a"), (3,"b")]) @?= [(5,"a"), (3,"b")] 270 | , testGroup "fromAscList" 271 | [ testCase "simple" $ fromAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")] 272 | , testCase "combine" $ fromAscList [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "b")] 273 | ] 274 | , testCase "fromAscListWith" $ fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "ba")] 275 | , let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value 276 | in testCase "fromAscListWithKey" $ fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "5:b|a")] 277 | , testCase "fromDistinctAscList" $ fromDistinctAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")] 278 | ] 279 | ] 280 | , testGroup "Filter" 281 | [ testGroup "filter" 282 | [ testCase "some" $ filter (> "a") (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" 283 | , testCase "none1" $ filter (> "x") (fromList [(5,"a"), (3,"b")]) @?= empty 284 | , testCase "none2" $ filter (< "a") (fromList [(5,"a"), (3,"b")]) @?= empty 285 | ] 286 | , testCase "filterWithKey" $ filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 287 | , testGroup "partition" 288 | [ testCase "split" $ partition (> "a") (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a") 289 | , testCase "allL" $ partition (< "x") (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty) 290 | , testCase "allR" $ partition (> "x") (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")]) 291 | ] 292 | , testGroup "partitionWithKey" 293 | [ testCase "split" $ partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) @?= (singleton 5 "a", singleton 3 "b") 294 | , testCase "allL" $ partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3, "b"), (5, "a")], empty) 295 | , testCase "allR" $ partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3, "b"), (5, "a")]) 296 | ] 297 | , let f x = if x == "a" then Just "new a" else Nothing 298 | in testCase "mapMaybe" $ mapMaybe f (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "new a" 299 | , let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing 300 | in testCase "mapMaybeWithKey" $ mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "key : 3" 301 | , let f a = if a < "c" then Left a else Right a 302 | in testGroup "mapEither" 303 | [ testCase "split" $ mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @?= (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")]) 304 | , testCase "allR" $ mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @?= (empty :: WordMap String, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) 305 | ] 306 | , let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) 307 | in testGroup "mapEitherWithKey" 308 | [ testCase "split" $ mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @?= (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")]) 309 | , testCase "allR" $ mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")]) @?= (empty :: WordMap String, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")]) 310 | ] 311 | , testGroup "split" 312 | [ testCase "allR" $ split 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, fromList [(3,"b"), (5,"a")]) 313 | , testCase "allR (del)" $ split 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, singleton 5 "a") 314 | , testCase "split" $ split 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", singleton 5 "a") 315 | , testCase "allL (del)" $ split 5 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", empty) 316 | , testCase "allL" $ split 6 (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3,"b"), (5,"a")], empty) 317 | ] 318 | , testGroup "splitLookup" 319 | [ testCase "allR" $ splitLookup 2 (fromList [(5,"a"), (3,"b")]) @?= (empty, Nothing, fromList [(3,"b"), (5,"a")]) 320 | , testCase "allR (del)" $ splitLookup 3 (fromList [(5,"a"), (3,"b")]) @?= (empty, Just "b", singleton 5 "a") 321 | , testCase "split" $ splitLookup 4 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", Nothing, singleton 5 "a") 322 | , testCase "allL (del)" $ splitLookup 5 (fromList [(5,"a"), (3,"b")]) @?= (singleton 3 "b", Just "a", empty) 323 | , testCase "allL" $ splitLookup 6 (fromList [(5,"a"), (3,"b")]) @?= (fromList [(3,"b"), (5,"a")], Nothing, empty) 324 | ] 325 | ] 326 | , testGroup "Submap" 327 | [ testGroup "isSubmapOf" -- NOTE: These are not in the docs 328 | [ testCase "true1" $ isSubmapOf (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True 329 | , testCase "true3" $ isSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= True 330 | , testCase "false1" $ isSubmapOf (fromList [(1,2)]) (fromList [(1,1),(2,2)]) @?= False 331 | , testCase "false3" $ isSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False 332 | ] 333 | , testGroup "isSubmapOfBy" 334 | [ testCase "true1" $ isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True 335 | , testCase "true2" $ isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True 336 | , testCase "true3" $ isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= True 337 | , testCase "false1" $ isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)]) @?= False 338 | , testCase "false2" $ isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= False 339 | , testCase "false3" $ isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False 340 | ] 341 | , testGroup "isProperSubmapOf" -- NOTE: These are not in the docs 342 | [ testCase "true1" $ isProperSubmapOf (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True 343 | , testCase "false1" $ isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False 344 | , testCase "false2" $ isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False 345 | ] 346 | , testGroup "isProperSubmapOfBy" 347 | [ testCase "true1" $ isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True 348 | , testCase "true2" $ isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True 349 | , testCase "false1" $ isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False 350 | , testCase "false2" $ isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False 351 | , testCase "false3" $ isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= False 352 | ] 353 | ] 354 | , testGroup "MinMax" 355 | -- FIXME: findMin 356 | -- FIXME: findMax 357 | -- FIXME: deleteMin 358 | -- FIXME: deleteMax 359 | -- FIXME: deleteFindMin 360 | -- FIXME: deleteFindMax 361 | [ testGroup "updateMin" 362 | [ testCase "adjust" $ updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "Xb"), (5, "a")] 363 | , testCase "delete" $ updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 364 | ] 365 | , testGroup "updateMax" 366 | [ testCase "adjust" $ updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "Xa")] 367 | , testCase "delete" $ updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" 368 | ] 369 | , testGroup "updateMinWithKey" 370 | [ testCase "adjust" $ updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3,"3:b"), (5,"a")] 371 | , testCase "delete" $ updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a" 372 | ] 373 | , testGroup "updateMaxWithKey" 374 | [ testCase "adjust" $ updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) @?= fromList [(3,"b"), (5,"5:a")] 375 | , testCase "delete" $ updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b" 376 | ] 377 | -- FIXME: minView 378 | -- FIXME: maxView 379 | , testGroup "minViewWithKey" 380 | [ testCase "full" $ minViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((3,"b"), singleton 5 "a") 381 | , testCase "empty" $ minViewWithKey (empty :: WordMap String) @?= Nothing 382 | ] 383 | , testGroup "mapViewWithKey" 384 | [ testCase "full" $ maxViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((5,"a"), singleton 3 "b") 385 | , testCase "empty" $ maxViewWithKey (empty :: WordMap String) @?= Nothing 386 | ] 387 | ] 388 | ] 389 | 390 | --------------------------- 391 | 392 | curry3 f a b c = f (a, b, c) 393 | --------------------------------------------------------------------------------