├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .hgignore ├── .stylish-haskell.yaml ├── CHANGES.md ├── CONTRIBUTING.md ├── Data ├── HashMap │ ├── Internal.hs │ ├── Internal │ │ ├── Array.hs │ │ ├── Debug.hs │ │ ├── List.hs │ │ └── Strict.hs │ ├── Lazy.hs │ └── Strict.hs ├── HashSet.hs └── HashSet │ └── Internal.hs ├── LICENSE ├── README.md ├── Setup.hs ├── benchmarks ├── Benchmarks.hs └── Util │ ├── ByteString.hs │ ├── Int.hs │ └── String.hs ├── cabal.haskell-ci ├── docs └── developer-guide.md ├── tests ├── Main.hs ├── Properties.hs ├── Properties │ ├── HashMapLazy.hs │ ├── HashMapStrict.hs │ ├── HashSet.hs │ └── List.hs ├── Regressions.hs ├── Strictness.hs └── Util │ └── Key.hs ├── unordered-containers.cabal └── utils └── Stats.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'unordered-containers.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250506 12 | # 13 | # REGENDATA ("0.19.20250506",["github","unordered-containers.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-24.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.2 36 | compilerKind: ghc 37 | compilerVersion: 9.12.2 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.2 41 | compilerKind: ghc 42 | compilerVersion: 9.10.2 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.4 46 | compilerKind: ghc 47 | compilerVersion: 9.8.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.7 51 | compilerKind: ghc 52 | compilerVersion: 9.6.7 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.7 71 | compilerKind: ghc 72 | compilerVersion: 8.10.7 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.8.4 76 | compilerKind: ghc 77 | compilerVersion: 8.8.4 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.6.5 81 | compilerKind: ghc 82 | compilerVersion: 8.6.5 83 | setup-method: ghcup 84 | allow-failure: false 85 | - compiler: ghc-8.4.4 86 | compilerKind: ghc 87 | compilerVersion: 8.4.4 88 | setup-method: ghcup 89 | allow-failure: false 90 | - compiler: ghc-8.2.2 91 | compilerKind: ghc 92 | compilerVersion: 8.2.2 93 | setup-method: ghcup 94 | allow-failure: false 95 | fail-fast: false 96 | steps: 97 | - name: apt-get install 98 | run: | 99 | apt-get update 100 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 101 | - name: Install GHCup 102 | run: | 103 | mkdir -p "$HOME/.ghcup/bin" 104 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 105 | chmod a+x "$HOME/.ghcup/bin/ghcup" 106 | - name: Install cabal-install 107 | run: | 108 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 109 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 110 | - name: Install GHC (GHCup) 111 | if: matrix.setup-method == 'ghcup' 112 | run: | 113 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 114 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 115 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 116 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 117 | echo "HC=$HC" >> "$GITHUB_ENV" 118 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 119 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 120 | env: 121 | HCKIND: ${{ matrix.compilerKind }} 122 | HCNAME: ${{ matrix.compiler }} 123 | HCVER: ${{ matrix.compilerVersion }} 124 | - name: Set PATH and environment variables 125 | run: | 126 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 127 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 128 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 129 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 130 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 131 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 132 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 133 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 134 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 135 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 136 | env: 137 | HCKIND: ${{ matrix.compilerKind }} 138 | HCNAME: ${{ matrix.compiler }} 139 | HCVER: ${{ matrix.compilerVersion }} 140 | - name: env 141 | run: | 142 | env 143 | - name: write cabal config 144 | run: | 145 | mkdir -p $CABAL_DIR 146 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 179 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 180 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 181 | rm -f cabal-plan.xz 182 | chmod a+x $HOME/.cabal/bin/cabal-plan 183 | cabal-plan --version 184 | - name: checkout 185 | uses: actions/checkout@v4 186 | with: 187 | path: source 188 | - name: initial cabal.project for sdist 189 | run: | 190 | touch cabal.project 191 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 192 | cat cabal.project 193 | - name: sdist 194 | run: | 195 | mkdir -p sdist 196 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 197 | - name: unpack 198 | run: | 199 | mkdir -p unpacked 200 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 201 | - name: generate cabal.project 202 | run: | 203 | PKGDIR_unordered_containers="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/unordered-containers-[0-9.]*')" 204 | echo "PKGDIR_unordered_containers=${PKGDIR_unordered_containers}" >> "$GITHUB_ENV" 205 | rm -f cabal.project cabal.project.local 206 | touch cabal.project 207 | touch cabal.project.local 208 | echo "packages: ${PKGDIR_unordered_containers}" >> cabal.project 209 | echo "package unordered-containers" >> cabal.project 210 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 211 | cat >> cabal.project <> cabal.project.local 214 | cat cabal.project 215 | cat cabal.project.local 216 | - name: dump install plan 217 | run: | 218 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 219 | cabal-plan 220 | - name: restore cache 221 | uses: actions/cache/restore@v4 222 | with: 223 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 224 | path: ~/.cabal/store 225 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 226 | - name: install dependencies 227 | run: | 228 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 229 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 230 | - name: build w/o tests 231 | run: | 232 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 233 | - name: build 234 | run: | 235 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 236 | - name: tests 237 | run: | 238 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 239 | - name: cabal check 240 | run: | 241 | cd ${PKGDIR_unordered_containers} || false 242 | ${CABAL} -vnormal check 243 | - name: haddock 244 | run: | 245 | if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all ; fi 246 | - name: unconstrained build 247 | run: | 248 | rm -f cabal.project.local 249 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 250 | - name: prepare for constraint sets 251 | run: | 252 | rm -f cabal.project.local 253 | - name: constraint set debug 254 | run: | 255 | $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='unordered-containers +debug' all --dry-run 256 | cabal-plan topo | sort 257 | $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='unordered-containers +debug' --dependencies-only -j2 all 258 | $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='unordered-containers +debug' all 259 | $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='unordered-containers +debug' all 260 | - name: save cache 261 | if: always() 262 | uses: actions/cache/save@v4 263 | with: 264 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 265 | path: ~/.cabal/store 266 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *.p_hi 4 | *.prof 5 | *.tix 6 | .hpc/ 7 | /benchmarks/dist/* 8 | /dist/* 9 | .cabal-sandbox 10 | cabal.sandbox.config 11 | dist-* 12 | cabal-dev 13 | *.chi 14 | *.chs.h 15 | *.dyn_o 16 | *.dyn_hi 17 | .hsenv 18 | *.prof 19 | *.aux 20 | *.hp 21 | *.eventlog 22 | .stack-work/ 23 | cabal.project.local 24 | cabal.project.local~ 25 | .HTF/ 26 | .ghc.environment.* 27 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | ^dist$ 2 | ^benchmarks/(?:dist|bench)$ 3 | ^tests/(?:Map|Set)Properties$ 4 | \.(?:aux|eventlog|h[ip]|log|[oa]|orig|prof|ps|rej|swp)$ 5 | ~$ 6 | syntax: glob 7 | .\#* 8 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - imports: 3 | align: group 4 | pad_module_names: true 5 | long_list_align: inline 6 | - language_pragmas: 7 | align: true 8 | remove_redundant: true 9 | language_prefix: LANGUAGE 10 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## [0.2.20] - January 2024 2 | 3 | * [Allow `template-haskell-2.21`](https://github.com/haskell-unordered-containers/unordered-containers/pull/484) 4 | 5 | * [Rename confusing variables](https://github.com/haskell-unordered-containers/unordered-containers/pull/479) 6 | 7 | * [Deal with introduction of `Prelude.foldl'`](https://github.com/haskell-unordered-containers/unordered-containers/pull/480) 8 | 9 | * [Remove redundant `Hashable` constraints](https://github.com/haskell-unordered-containers/unordered-containers/pull/478) 10 | from `intersection.*` and `union.*`. 11 | 12 | * Various optimizations and cleanups: 13 | [#458](https://github.com/haskell-unordered-containers/unordered-containers/pull/458), 14 | [#469](https://github.com/haskell-unordered-containers/unordered-containers/pull/469), 15 | [#404](https://github.com/haskell-unordered-containers/unordered-containers/pull/404), 16 | [#460](https://github.com/haskell-unordered-containers/unordered-containers/pull/460), 17 | [#456](https://github.com/haskell-unordered-containers/unordered-containers/pull/456), 18 | [#433](https://github.com/haskell-unordered-containers/unordered-containers/pull/433) 19 | 20 | * Add invariant tests: 21 | [#444](https://github.com/haskell-unordered-containers/unordered-containers/pull/444), 22 | [#455](https://github.com/haskell-unordered-containers/unordered-containers/pull/455) 23 | 24 | * [Improve test case generation](https://github.com/haskell-unordered-containers/unordered-containers/pull/442) 25 | 26 | * [Improve test failure reporting](https://github.com/haskell-unordered-containers/unordered-containers/pull/440) 27 | 28 | ## [0.2.19.1] – April 2022 29 | 30 | * [Fix bug in `intersection[With[Key]]`](https://github.com/haskell-unordered-containers/unordered-containers/pull/427) 31 | 32 | * [Improve docs of bit twiddling functions](https://github.com/haskell-unordered-containers/unordered-containers/pull/396) 33 | 34 | [0.2.19.1]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.19.0...v0.2.19.1 35 | 36 | ## [0.2.19.0] – April 2022 37 | 38 | * [Make intersections much faster](https://github.com/haskell-unordered-containers/unordered-containers/pull/406) 39 | 40 | * [Fix undefined behaviour on 32-bit platforms](https://github.com/haskell-unordered-containers/unordered-containers/pull/413) 41 | 42 | * Speed up some array-appending operations: [#407](https://github.com/haskell-unordered-containers/unordered-containers/pull/407), [#409](https://github.com/haskell-unordered-containers/unordered-containers/pull/409) 43 | 44 | * [Use MathJax format for complexity annotations](https://github.com/haskell-unordered-containers/unordered-containers/pull/411) 45 | 46 | [0.2.19.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.18.0...v0.2.19.0 47 | 48 | ## [0.2.18.0] 49 | 50 | * [Fix strictness properties of `Strict.mapMaybe[WithKey]`](https://github.com/haskell-unordered-containers/unordered-containers/pull/385) 51 | 52 | * [Fix strictness properties of `Strict.alterFEager`](https://github.com/haskell-unordered-containers/unordered-containers/pull/384) 53 | 54 | * [Fix space leaks in `union[With[Key]]`](https://github.com/haskell-unordered-containers/unordered-containers/pull/380) 55 | 56 | * [Fix space leak in `Lazy.fromListWith`](https://github.com/haskell-unordered-containers/unordered-containers/pull/386) 57 | 58 | * [Speed up `difference*` and `intersection*` with `unsafeInsert`](https://github.com/haskell-unordered-containers/unordered-containers/pull/372) 59 | 60 | * [`unionArrayBy`: Find next 1-bits with `countTrailingZeros`](https://github.com/haskell-unordered-containers/unordered-containers/pull/395) 61 | - This speeds up `union*` for sparsely filled nodes, while penalizing `union` operations on densely filled nodes. 62 | 63 | * [Reduce reboxing in internal array operations](https://github.com/haskell-unordered-containers/unordered-containers/pull/377) 64 | 65 | * [Reduce code size of array operations in `union*`](https://github.com/haskell-unordered-containers/unordered-containers/pull/376) 66 | 67 | [0.2.18.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.17.0...v0.2.18.0 68 | 69 | ## [0.2.17.0] 70 | 71 | * [Define `dataCast1` for `HashMap`](https://github.com/haskell-unordered-containers/unordered-containers/pull/345) 72 | 73 | * [Add `Lift` instances for Template Haskell](https://github.com/haskell-unordered-containers/unordered-containers/pull/343) 74 | 75 | * [Add definitions for `stimes`](https://github.com/haskell-unordered-containers/unordered-containers/pull/340) 76 | 77 | * [Expose internal constructors for `HashSet`, `Array` and `MArray`](https://github.com/haskell-unordered-containers/unordered-containers/pull/347) 78 | 79 | * [Tweak internal `Array.insertM` function](https://github.com/haskell-unordered-containers/unordered-containers/pull/359) 80 | 81 | * [Drop support for GHC 8.0](https://github.com/haskell-unordered-containers/unordered-containers/pull/354) 82 | 83 | * [Drop support for `hashable < 1.2.5`](https://github.com/haskell-unordered-containers/unordered-containers/pull/355) 84 | 85 | * Various cleanup and documentation improvements 86 | 87 | [0.2.17.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.16.0...v0.2.17.0 88 | 89 | ## [0.2.16.0] 90 | 91 | * [Increase maximum branching factor from 16 to 32](https://github.com/haskell-unordered-containers/unordered-containers/pull/317) 92 | 93 | * [Tweak `union.goDifferentHash`](https://github.com/haskell-unordered-containers/unordered-containers/pull/277) 94 | 95 | * [Fix debug mode bounds check in `cloneM`](https://github.com/haskell-unordered-containers/unordered-containers/pull/331) 96 | 97 | * [Remove some old internal compatibility code](https://github.com/haskell-unordered-containers/unordered-containers/pull/334) 98 | 99 | [0.2.16.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.15.0...v0.2.16.0 100 | 101 | ## [0.2.15.0] 102 | 103 | * [Add security advisory regarding hash collision attacks](https://github.com/haskell-unordered-containers/unordered-containers/pull/320) 104 | 105 | * [Add support for hashable 1.4](https://github.com/haskell-unordered-containers/unordered-containers/pull/324) 106 | 107 | * [Drop support for GHC < 8](https://github.com/haskell-unordered-containers/unordered-containers/pull/323) 108 | 109 | [0.2.15.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.14.0...v0.2.15.0 110 | 111 | ## [0.2.14.0] 112 | 113 | * [Add `HashMap.mapKeys`.](https://github.com/haskell-unordered-containers/unordered-containers/pull/308) Thanks, Marco Perone! 114 | 115 | * [Add instances for `NFData1` and `NFData2`.](https://github.com/haskell-unordered-containers/unordered-containers/pull/314) Thanks, Isaac Elliott and Oleg Grenrus! 116 | 117 | * [Fix `@since`-annotation for `compose`.](https://github.com/haskell-unordered-containers/unordered-containers/pull/303) Thanks, @Mathnerd314! 118 | 119 | [0.2.14.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.13.0...v0.2.14.0 120 | 121 | ## [0.2.13.0] 122 | 123 | * [Add `HashMap.compose`.](https://github.com/haskell-unordered-containers/unordered-containers/pull/299) Thanks Alexandre Esteves. 124 | 125 | [0.2.13.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.12.0...v0.2.13.0 126 | 127 | ## [0.2.12.0] 128 | 129 | * Add `HashMap.isSubmapOf[By]` and `HashSet.isSubsetOf`. Thanks Sven Keidel. ([#282]) 130 | 131 | * Expose internal modules. ([#283]) 132 | 133 | * Documentation improvements in `Data.HashSet`, including a beginner-friendly 134 | introduction. Thanks Matt Renaud. ([#267]) 135 | 136 | * `HashMap.alterF`: Skip key deletion for absent keys. ([#288]) 137 | 138 | * Remove custom `unsafeShift{L,R}` definitions. ([#281]) 139 | 140 | * Various other documentation improvements. 141 | 142 | [0.2.12.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.11.0...v0.2.12.0 143 | [#267]: https://github.com/haskell-unordered-containers/unordered-containers/pull/267 144 | [#281]: https://github.com/haskell-unordered-containers/unordered-containers/pull/281 145 | [#282]: https://github.com/haskell-unordered-containers/unordered-containers/pull/282 146 | [#283]: https://github.com/haskell-unordered-containers/unordered-containers/pull/283 147 | [#288]: https://github.com/haskell-unordered-containers/unordered-containers/pull/288 148 | 149 | ## 0.2.11.0 150 | 151 | * Add `HashMap.findWithDefault` (soft-deprecates `HashMap.lookupDefault`). 152 | Thanks, Matt Renaud. 153 | 154 | * Add `HashMap.fromListWithKey`. Thanks, Josef Svenningsson. 155 | 156 | * Add more folding functions and use them in `Foldable` instances. Thanks, 157 | David Feuer. 158 | 159 | * Add `HashMap.!?`, a flipped version of `lookup`. Thanks, Matt Renaud. 160 | 161 | * Add a `Bifoldable` instance for `HashMap`. Thanks, Joseph Sible. 162 | 163 | * Add a `HasCallStack` constraint to `(!)`. Thanks, Roman Cheplyaka. 164 | 165 | ### Bug fixes 166 | 167 | * Fix a space leak affecting updates on keys with hash collisions. Thanks, 168 | Neil Mitchell. ([#254]) 169 | 170 | * Get rid of some silly thunks that could be left lying around. ([#232]). 171 | Thanks, David Feuer. 172 | 173 | ### Other changes 174 | 175 | * Speed up the `Hashable` instances for `HashMap` and `HashSet`. Thanks, 176 | Edward Amsden. 177 | 178 | * Remove a dependency cycle hack from the benchmark suite. Thanks, 179 | Andrew Martin. 180 | 181 | * Improve documentation. Thanks, Tristan McLeay, Li-yao Xia, Gareth Smith, 182 | Simon Jakobi, Sergey Vinokurov, and likely others. 183 | 184 | [#232]: https://github.com/haskell-unordered-containers/unordered-containers/issues/232 185 | [#254]: https://github.com/haskell-unordered-containers/unordered-containers/issues/254 186 | 187 | ## 0.2.10.0 188 | 189 | * Add `HashMap.alterF`. 190 | 191 | * Add `HashMap.keysSet`. 192 | 193 | * Make `HashMap.Strict.traverseWithKey` force the results before 194 | installing them in the map. 195 | 196 | ## 0.2.9.0 197 | 198 | * Add `Ord/Ord1/Ord2` instances. (Thanks, Oleg Grenrus) 199 | 200 | * Use `SmallArray#` instead of `Array#` for GHC versions 7.10 and above. 201 | (Thanks, Dmitry Ivanov) 202 | 203 | * Adjust for `Semigroup => Monoid` proposal implementation. 204 | (Thanks, Ryan Scott) 205 | 206 | ### Bug fixes 207 | 208 | * Fix a strictness bug in `fromListWith`. 209 | 210 | * Enable eager blackholing for pre-8.2 GHC versions to work around 211 | a runtime system bug. (Thanks, Ben Gamari) 212 | 213 | * Avoid sketchy reimplementation of `ST` when compiling with recent 214 | GHC. 215 | 216 | ### Other changes 217 | 218 | * Remove support for GHC versions before 7.8. (Thanks, Dmitry Ivanov) 219 | 220 | * Add internal documentaton. (Thanks, Johan Tibell) 221 | 222 | ## 0.2.8.0 223 | 224 | * Add `Eq1/2`, `Show1/2`, `Read1` instances with `base-4.9` 225 | 226 | * `Eq (HashSet a)` doesn't require `Hashable a` anymore, only `Eq a`. 227 | 228 | * Add `Hashable1/2` with `hashable-1.2.6.0` 229 | 230 | * Add `differenceWith` function. 231 | 232 | ## 0.2.7.2 233 | 234 | * Don't use -fregs-graphs 235 | 236 | * Fix benchmark compilation on stack. 237 | 238 | ## 0.2.7.1 239 | 240 | * Fix linker error related to popcnt. 241 | 242 | * Haddock improvements. 243 | 244 | * Fix benchmark compilation when downloaded from Hackage. 245 | 246 | ## 0.2.7.0 247 | 248 | * Support criterion 1.1 249 | 250 | * Add unionWithKey for hash maps. 251 | 252 | ## 0.2.6.0 253 | 254 | * Mark several modules as Trustworthy. 255 | 256 | * Add Hashable instances for HashMap and HashSet. 257 | 258 | * Add mapMaybe, mapMaybeWithKey, update, alter, and 259 | intersectionWithKey. 260 | 261 | * Add roles. 262 | 263 | * Add Hashable and Semigroup instances. 264 | 265 | ## 0.2.5.1 (2014-10-11) 266 | 267 | * Support base-4.8 268 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | ## Building, testing, benchmarking 4 | 5 | Building the library: 6 | 7 | ``` 8 | cabal build 9 | ``` 10 | 11 | Running the testsuite: 12 | 13 | ``` 14 | cabal test 15 | ``` 16 | 17 | Viewing the test options: 18 | 19 | ``` 20 | cabal run tests -- --help 21 | ``` 22 | 23 | Running a specific property test with an increased number of test cases 24 | (default: 100 cases): 25 | 26 | ``` 27 | cabal run tests -- -p '/All.Properties.Data.HashSet.basic interface.member/' --quickcheck-tests 100_000 28 | ``` 29 | 30 | Running the benchmarks: 31 | 32 | ``` 33 | cabal bench 34 | ``` 35 | 36 | Viewing the benchmark options: 37 | 38 | ``` 39 | cabal run benches -- --help 40 | ``` 41 | 42 | Running a specific benchmark with a reduced target standard deviation (default: 43 | 5%): 44 | 45 | ``` 46 | cabal run benches -- -p /All.HashMap.lookup-miss.ByteString/ --stdev 1 47 | ``` 48 | 49 | To include comparison benchmarks for `containers` and `hashmap` uncomment the 50 | `cpp-options` in the benchmark section of `unordered-containers.cabal`: 51 | 52 | ``` 53 | cpp-options: -DBENCH_containers_Map -DBENCH_containers_IntMap -DBENCH_hashmap_Map 54 | ``` 55 | 56 | ### References 57 | 58 | * [Documentation for `cabal`](https://cabal.readthedocs.io/en/latest/) 59 | * [Documentation for our testing framework, `tasty`](https://github.com/UnkindPartition/tasty#readme) 60 | * [Documentation for our benchmark framework, `tasty-bench`](https://github.com/Bodigrim/tasty-bench#readme) 61 | 62 | 63 | ## Inspecting the generated code 64 | 65 | The library section in `unordered-containers.cabal` contains a commented-out set of `ghc-options` for 66 | dumping Core and other forms of generated code. To dump this code, uncomment these options and run 67 | 68 | ``` 69 | cabal clean 70 | cabal build 71 | ``` 72 | 73 | You can find the resulting `.dump-*` files in `dist-newstyle/build/**/unordered-containers-*/build/`, e.g. 74 | 75 | ``` 76 | $ tree dist-newstyle/build/x86_64-linux/ghc-9.2.2/unordered-containers-0.2.16.0/build/ 77 | dist-newstyle/build/x86_64-linux/ghc-9.2.2/unordered-containers-0.2.16.0/build/ 78 | ├── Data 79 | │   ├── HashMap 80 | │   │   ├── Internal 81 | │   │   │   ├── Array.dump-asm 82 | │   │   │   ├── Array.dump-cmm 83 | │   │   │   ├── Array.dump-simpl 84 | │   │   │   ├── Array.dump-stg-final 85 | ... 86 | ``` 87 | 88 | To visually compare the generated code from two different states of the source tree, you can copy 89 | the `dist-newstyle/build/**/unordered-containers-*/build/` directory from each state to two 90 | directories `a` and `b` and then use a diff tool like [Meld](https://meldmerge.org/) to compare 91 | them: 92 | 93 | ``` 94 | meld a/ b/ 95 | ``` 96 | 97 | ### References 98 | 99 | * [A collection of resources on GHC Core](https://stackoverflow.com/q/6121146/1013393) 100 | * [Some links about STG](https://stackoverflow.com/a/12118567/1013393) 101 | * [GHC User's Guide: _Debugging the compiler_](http://downloads.haskell.org/~ghc/latest/docs/html/users_guide/debugging.html) 102 | 103 | 104 | ## Code style 105 | 106 | This package uses [`stylish-haskell`](https://hackage.haskell.org/package/stylish-haskell) 107 | to format language pragmas and import sections. To format a specific file, run 108 | 109 | ``` 110 | stylish-haskell -i FILENAME 111 | ``` 112 | 113 | To format all the Haskell files under a specific directory, run 114 | 115 | ``` 116 | stylish-haskell -ir DIRNAME 117 | ``` 118 | -------------------------------------------------------------------------------- /Data/HashMap/Internal/Array.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE Rank2Types #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TemplateHaskellQuotes #-} 7 | {-# LANGUAGE UnboxedTuples #-} 8 | {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} 9 | {-# OPTIONS_HADDOCK not-home #-} 10 | 11 | -- | = WARNING 12 | -- 13 | -- This module is considered __internal__. 14 | -- 15 | -- The Package Versioning Policy __does not apply__. 16 | -- 17 | -- The contents of this module may change __in any way whatsoever__ 18 | -- and __without any warning__ between minor versions of this package. 19 | -- 20 | -- Authors importing this module are expected to track development 21 | -- closely. 22 | -- 23 | -- = Description 24 | -- 25 | -- Zero based arrays. 26 | -- 27 | -- Note that no bounds checking are performed. 28 | module Data.HashMap.Internal.Array 29 | ( Array(..) 30 | , MArray(..) 31 | 32 | -- * Creation 33 | , new 34 | , new_ 35 | , singleton 36 | , singletonM 37 | , snoc 38 | , pair 39 | 40 | -- * Basic interface 41 | , length 42 | , lengthM 43 | , read 44 | , write 45 | , index 46 | , indexM 47 | , index# 48 | , update 49 | , updateWith' 50 | , unsafeUpdateM 51 | , insert 52 | , insertM 53 | , delete 54 | , sameArray1 55 | 56 | , unsafeFreeze 57 | , unsafeThaw 58 | , unsafeSameArray 59 | , run 60 | , copy 61 | , copyM 62 | , cloneM 63 | 64 | -- * Folds 65 | , foldl 66 | , foldl' 67 | , foldr 68 | , foldr' 69 | , foldMap 70 | , all 71 | 72 | , thaw 73 | , map 74 | , map' 75 | , traverse 76 | , traverse' 77 | , toList 78 | , fromList 79 | , fromList' 80 | , shrink 81 | ) where 82 | 83 | import Control.Applicative (liftA2) 84 | import Control.DeepSeq (NFData (..), NFData1 (..)) 85 | import Control.Monad ((>=>)) 86 | import Control.Monad.ST (runST, stToIO) 87 | import GHC.Exts (Int (..), SmallArray#, SmallMutableArray#, 88 | cloneSmallMutableArray#, copySmallArray#, 89 | copySmallMutableArray#, indexSmallArray#, 90 | newSmallArray#, readSmallArray#, 91 | reallyUnsafePtrEquality#, sizeofSmallArray#, 92 | sizeofSmallMutableArray#, tagToEnum#, 93 | thawSmallArray#, unsafeCoerce#, 94 | unsafeFreezeSmallArray#, unsafeThawSmallArray#, 95 | writeSmallArray#) 96 | import GHC.ST (ST (..)) 97 | import Prelude hiding (Foldable(..), all, filter, 98 | map, read, traverse) 99 | 100 | import qualified GHC.Exts as Exts 101 | import qualified Language.Haskell.TH.Syntax as TH 102 | #if defined(ASSERTS) 103 | import qualified Prelude 104 | #endif 105 | 106 | 107 | #if defined(ASSERTS) 108 | -- This fugly hack is brought by GHC's apparent reluctance to deal 109 | -- with MagicHash and UnboxedTuples when inferring types. Eek! 110 | # define CHECK_BOUNDS(_func_,_len_,_k_) \ 111 | if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Internal.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else 112 | # define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \ 113 | if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Internal.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else 114 | # define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_) 115 | # define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_) 116 | # define CHECK_EQ(_func_,_lhs_,_rhs_) CHECK_OP(_func_,==,_lhs_,_rhs_) 117 | #else 118 | # define CHECK_BOUNDS(_func_,_len_,_k_) 119 | # define CHECK_OP(_func_,_op_,_lhs_,_rhs_) 120 | # define CHECK_GT(_func_,_lhs_,_rhs_) 121 | # define CHECK_LE(_func_,_lhs_,_rhs_) 122 | # define CHECK_EQ(_func_,_lhs_,_rhs_) 123 | #endif 124 | 125 | data Array a = Array { 126 | unArray :: !(SmallArray# a) 127 | } 128 | 129 | instance Show a => Show (Array a) where 130 | show = show . toList 131 | 132 | -- Determines whether two arrays have the same memory address. 133 | -- This is more reliable than testing pointer equality on the 134 | -- Array wrappers, but it's still slightly bogus. 135 | unsafeSameArray :: Array a -> Array b -> Bool 136 | unsafeSameArray (Array xs) (Array ys) = 137 | tagToEnum# (unsafeCoerce# reallyUnsafePtrEquality# xs ys) 138 | 139 | sameArray1 :: (a -> b -> Bool) -> Array a -> Array b -> Bool 140 | sameArray1 eq !xs0 !ys0 141 | | lenxs /= lenys = False 142 | | otherwise = go 0 xs0 ys0 143 | where 144 | go !k !xs !ys 145 | | k == lenxs = True 146 | | (# x #) <- index# xs k 147 | , (# y #) <- index# ys k 148 | = eq x y && go (k + 1) xs ys 149 | 150 | !lenxs = length xs0 151 | !lenys = length ys0 152 | 153 | length :: Array a -> Int 154 | length ary = I# (sizeofSmallArray# (unArray ary)) 155 | {-# INLINE length #-} 156 | 157 | data MArray s a = MArray { 158 | unMArray :: !(SmallMutableArray# s a) 159 | } 160 | 161 | lengthM :: MArray s a -> Int 162 | lengthM mary = I# (sizeofSmallMutableArray# (unMArray mary)) 163 | {-# INLINE lengthM #-} 164 | 165 | ------------------------------------------------------------------------ 166 | 167 | instance NFData a => NFData (Array a) where 168 | rnf = rnfArray 169 | 170 | rnfArray :: NFData a => Array a -> () 171 | rnfArray ary0 = go ary0 n0 0 172 | where 173 | n0 = length ary0 174 | go !ary !n !i 175 | | i >= n = () 176 | | (# x #) <- index# ary i 177 | = rnf x `seq` go ary n (i+1) 178 | -- We use index# just in case GHC can't see that the 179 | -- relevant rnf is strict, or in case it actually isn't. 180 | {-# INLINE rnfArray #-} 181 | 182 | -- | @since 0.2.14.0 183 | instance NFData1 Array where 184 | liftRnf = liftRnfArray 185 | 186 | liftRnfArray :: (a -> ()) -> Array a -> () 187 | liftRnfArray rnf0 ary0 = go ary0 n0 0 188 | where 189 | n0 = length ary0 190 | go !ary !n !i 191 | | i >= n = () 192 | | (# x #) <- index# ary i 193 | = rnf0 x `seq` go ary n (i+1) 194 | {-# INLINE liftRnfArray #-} 195 | 196 | -- | Create a new mutable array of specified size, in the specified 197 | -- state thread, with each element containing the specified initial 198 | -- value. 199 | new :: Int -> a -> ST s (MArray s a) 200 | new _n@(I# n#) b = 201 | CHECK_GT("new",_n,(0 :: Int)) 202 | ST $ \s -> 203 | case newSmallArray# n# b s of 204 | (# s', ary #) -> (# s', MArray ary #) 205 | {-# INLINE new #-} 206 | 207 | new_ :: Int -> ST s (MArray s a) 208 | new_ n = new n undefinedElem 209 | 210 | -- | When 'Exts.shrinkSmallMutableArray#' is available, the returned array is the same as the array given, as it is shrunk in place. 211 | -- Otherwise a copy is made. 212 | shrink :: MArray s a -> Int -> ST s (MArray s a) 213 | #if __GLASGOW_HASKELL__ >= 810 214 | shrink mary _n@(I# n#) = 215 | CHECK_GT("shrink", _n, (0 :: Int)) 216 | CHECK_LE("shrink", _n, (lengthM mary)) 217 | ST $ \s -> case Exts.shrinkSmallMutableArray# (unMArray mary) n# s of 218 | s' -> (# s', mary #) 219 | #else 220 | shrink mary n = cloneM mary 0 n 221 | #endif 222 | {-# INLINE shrink #-} 223 | 224 | singleton :: a -> Array a 225 | singleton x = runST (singletonM x) 226 | {-# INLINE singleton #-} 227 | 228 | singletonM :: a -> ST s (Array a) 229 | singletonM x = new 1 x >>= unsafeFreeze 230 | {-# INLINE singletonM #-} 231 | 232 | snoc :: Array a -> a -> Array a 233 | snoc ary x = run $ do 234 | mary <- new (n + 1) x 235 | copy ary 0 mary 0 n 236 | pure mary 237 | where 238 | n = length ary 239 | {-# INLINE snoc #-} 240 | 241 | pair :: a -> a -> Array a 242 | pair x y = run $ do 243 | ary <- new 2 x 244 | write ary 1 y 245 | return ary 246 | {-# INLINE pair #-} 247 | 248 | read :: MArray s a -> Int -> ST s a 249 | read ary _i@(I# i#) = ST $ \ s -> 250 | CHECK_BOUNDS("read", lengthM ary, _i) 251 | readSmallArray# (unMArray ary) i# s 252 | {-# INLINE read #-} 253 | 254 | write :: MArray s a -> Int -> a -> ST s () 255 | write ary _i@(I# i#) b = ST $ \ s -> 256 | CHECK_BOUNDS("write", lengthM ary, _i) 257 | case writeSmallArray# (unMArray ary) i# b s of 258 | s' -> (# s' , () #) 259 | {-# INLINE write #-} 260 | 261 | index :: Array a -> Int -> a 262 | index ary _i@(I# i#) = 263 | CHECK_BOUNDS("index", length ary, _i) 264 | case indexSmallArray# (unArray ary) i# of (# b #) -> b 265 | {-# INLINE index #-} 266 | 267 | index# :: Array a -> Int -> (# a #) 268 | index# ary _i@(I# i#) = 269 | CHECK_BOUNDS("index#", length ary, _i) 270 | indexSmallArray# (unArray ary) i# 271 | {-# INLINE index# #-} 272 | 273 | indexM :: Array a -> Int -> ST s a 274 | indexM ary _i@(I# i#) = 275 | CHECK_BOUNDS("indexM", length ary, _i) 276 | case indexSmallArray# (unArray ary) i# of (# b #) -> return b 277 | {-# INLINE indexM #-} 278 | 279 | unsafeFreeze :: MArray s a -> ST s (Array a) 280 | unsafeFreeze mary 281 | = ST $ \s -> case unsafeFreezeSmallArray# (unMArray mary) s of 282 | (# s', ary #) -> (# s', Array ary #) 283 | {-# INLINE unsafeFreeze #-} 284 | 285 | unsafeThaw :: Array a -> ST s (MArray s a) 286 | unsafeThaw ary 287 | = ST $ \s -> case unsafeThawSmallArray# (unArray ary) s of 288 | (# s', mary #) -> (# s', MArray mary #) 289 | {-# INLINE unsafeThaw #-} 290 | 291 | run :: (forall s . ST s (MArray s e)) -> Array e 292 | run act = runST $ act >>= unsafeFreeze 293 | {-# INLINE run #-} 294 | 295 | -- | Unsafely copy the elements of an array. Array bounds are not checked. 296 | copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () 297 | copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = 298 | CHECK_LE("copy", _sidx + _n, length src) 299 | CHECK_LE("copy", _didx + _n, lengthM dst) 300 | ST $ \ s# -> 301 | case copySmallArray# (unArray src) sidx# (unMArray dst) didx# n# s# of 302 | s2 -> (# s2, () #) 303 | 304 | -- | Unsafely copy the elements of an array. Array bounds are not checked. 305 | copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s () 306 | copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = 307 | CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1) 308 | CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1) 309 | ST $ \ s# -> 310 | case copySmallMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of 311 | s2 -> (# s2, () #) 312 | 313 | cloneM :: MArray s a -> Int -> Int -> ST s (MArray s a) 314 | cloneM _mary@(MArray mary#) _off@(I# off#) _len@(I# len#) = 315 | CHECK_BOUNDS("cloneM_off", lengthM _mary, _off) 316 | CHECK_BOUNDS("cloneM_end", lengthM _mary, _off + _len - 1) 317 | ST $ \ s -> 318 | case cloneSmallMutableArray# mary# off# len# s of 319 | (# s', mary'# #) -> (# s', MArray mary'# #) 320 | 321 | -- | \(O(n)\) Insert an element at the given position in this array, 322 | -- increasing its size by one. 323 | insert :: Array e -> Int -> e -> Array e 324 | insert ary idx b = runST (insertM ary idx b) 325 | {-# INLINE insert #-} 326 | 327 | -- | \(O(n)\) Insert an element at the given position in this array, 328 | -- increasing its size by one. 329 | insertM :: Array e -> Int -> e -> ST s (Array e) 330 | insertM ary idx b = 331 | CHECK_BOUNDS("insertM", count + 1, idx) 332 | do mary <- new (count+1) b 333 | copy ary 0 mary 0 idx 334 | copy ary idx mary (idx+1) (count-idx) 335 | unsafeFreeze mary 336 | where !count = length ary 337 | {-# INLINE insertM #-} 338 | 339 | -- | \(O(n)\) Update the element at the given position in this array. 340 | update :: Array e -> Int -> e -> Array e 341 | update ary idx b = runST (updateM ary idx b) 342 | {-# INLINE update #-} 343 | 344 | -- | \(O(n)\) Update the element at the given position in this array. 345 | updateM :: Array e -> Int -> e -> ST s (Array e) 346 | updateM ary idx b = 347 | CHECK_BOUNDS("updateM", count, idx) 348 | do mary <- thaw ary 0 count 349 | write mary idx b 350 | unsafeFreeze mary 351 | where !count = length ary 352 | {-# INLINE updateM #-} 353 | 354 | -- | \(O(n)\) Update the element at the given position in this array, by 355 | -- applying a function to it. Evaluates the element to WHNF before 356 | -- inserting it into the array. 357 | updateWith' :: Array e -> Int -> (e -> e) -> Array e 358 | updateWith' ary idx f 359 | | (# x #) <- index# ary idx 360 | = update ary idx $! f x 361 | {-# INLINE updateWith' #-} 362 | 363 | -- | \(O(1)\) Update the element at the given position in this array, 364 | -- without copying. 365 | unsafeUpdateM :: Array e -> Int -> e -> ST s () 366 | unsafeUpdateM ary idx b = 367 | CHECK_BOUNDS("unsafeUpdateM", length ary, idx) 368 | do mary <- unsafeThaw ary 369 | write mary idx b 370 | _ <- unsafeFreeze mary 371 | return () 372 | {-# INLINE unsafeUpdateM #-} 373 | 374 | foldl' :: (b -> a -> b) -> b -> Array a -> b 375 | foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 376 | where 377 | go ary n i !z 378 | | i >= n = z 379 | | otherwise 380 | = case index# ary i of 381 | (# x #) -> go ary n (i+1) (f z x) 382 | {-# INLINE foldl' #-} 383 | 384 | foldr' :: (a -> b -> b) -> b -> Array a -> b 385 | foldr' f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0 386 | where 387 | go !_ary (-1) z = z 388 | go !ary i !z 389 | | (# x #) <- index# ary i 390 | = go ary (i - 1) (f x z) 391 | {-# INLINE foldr' #-} 392 | 393 | foldr :: (a -> b -> b) -> b -> Array a -> b 394 | foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 395 | where 396 | go ary n i z 397 | | i >= n = z 398 | | otherwise 399 | = case index# ary i of 400 | (# x #) -> f x (go ary n (i+1) z) 401 | {-# INLINE foldr #-} 402 | 403 | foldl :: (b -> a -> b) -> b -> Array a -> b 404 | foldl f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0 405 | where 406 | go _ary (-1) z = z 407 | go ary i z 408 | | (# x #) <- index# ary i 409 | = f (go ary (i - 1) z) x 410 | {-# INLINE foldl #-} 411 | 412 | -- We go to a bit of trouble here to avoid appending an extra mempty. 413 | -- The below implementation is by Mateusz Kowalczyk, who indicates that 414 | -- benchmarks show it to be faster than one that avoids lifting out 415 | -- lst. 416 | foldMap :: Monoid m => (a -> m) -> Array a -> m 417 | foldMap f = \ary0 -> case length ary0 of 418 | 0 -> mempty 419 | len -> 420 | let !lst = len - 1 421 | go i | (# x #) <- index# ary0 i, let fx = f x = 422 | if i == lst then fx else fx `mappend` go (i + 1) 423 | in go 0 424 | {-# INLINE foldMap #-} 425 | 426 | -- | Verifies that a predicate holds for all elements of an array. 427 | all :: (a -> Bool) -> Array a -> Bool 428 | all p = foldr (\a acc -> p a && acc) True 429 | {-# INLINE all #-} 430 | 431 | undefinedElem :: a 432 | undefinedElem = error "Data.HashMap.Internal.Array: Undefined element" 433 | {-# NOINLINE undefinedElem #-} 434 | 435 | thaw :: Array e -> Int -> Int -> ST s (MArray s e) 436 | thaw !ary !_o@(I# o#) _n@(I# n#) = 437 | CHECK_LE("thaw", _o + _n, length ary) 438 | ST $ \ s -> case thawSmallArray# (unArray ary) o# n# s of 439 | (# s2, mary# #) -> (# s2, MArray mary# #) 440 | {-# INLINE thaw #-} 441 | 442 | -- | \(O(n)\) Delete an element at the given position in this array, 443 | -- decreasing its size by one. 444 | delete :: Array e -> Int -> Array e 445 | delete ary idx = runST (deleteM ary idx) 446 | {-# INLINE delete #-} 447 | 448 | -- | \(O(n)\) Delete an element at the given position in this array, 449 | -- decreasing its size by one. 450 | deleteM :: Array e -> Int -> ST s (Array e) 451 | deleteM ary idx = do 452 | CHECK_BOUNDS("deleteM", count, idx) 453 | do mary <- new_ (count-1) 454 | copy ary 0 mary 0 idx 455 | copy ary (idx+1) mary idx (count-(idx+1)) 456 | unsafeFreeze mary 457 | where !count = length ary 458 | {-# INLINE deleteM #-} 459 | 460 | map :: (a -> b) -> Array a -> Array b 461 | map f = \ ary -> 462 | let !n = length ary 463 | in run $ do 464 | mary <- new_ n 465 | go ary mary 0 n 466 | return mary 467 | where 468 | go ary mary i n 469 | | i >= n = return () 470 | | otherwise = do 471 | x <- indexM ary i 472 | write mary i $ f x 473 | go ary mary (i+1) n 474 | {-# INLINE map #-} 475 | 476 | -- | Strict version of 'map'. 477 | map' :: (a -> b) -> Array a -> Array b 478 | map' f = \ ary -> 479 | let !n = length ary 480 | in run $ do 481 | mary <- new_ n 482 | go ary mary 0 n 483 | return mary 484 | where 485 | go ary mary i n 486 | | i >= n = return () 487 | | otherwise = do 488 | x <- indexM ary i 489 | write mary i $! f x 490 | go ary mary (i+1) n 491 | {-# INLINE map' #-} 492 | 493 | fromList :: Int -> [a] -> Array a 494 | fromList n xs0 = 495 | CHECK_EQ("fromList", n, Prelude.length xs0) 496 | run $ do 497 | mary <- new_ n 498 | go xs0 mary 0 499 | return mary 500 | where 501 | go [] !_ !_ = return () 502 | go (x:xs) mary i = do write mary i x 503 | go xs mary (i+1) 504 | 505 | fromList' :: Int -> [a] -> Array a 506 | fromList' n xs0 = 507 | CHECK_EQ("fromList'", n, Prelude.length xs0) 508 | run $ do 509 | mary <- new_ n 510 | go xs0 mary 0 511 | return mary 512 | where 513 | go [] !_ !_ = return () 514 | go (!x:xs) mary i = do write mary i x 515 | go xs mary (i+1) 516 | 517 | -- | @since 0.2.17.0 518 | instance TH.Lift a => TH.Lift (Array a) where 519 | #if MIN_VERSION_template_haskell(2,16,0) 520 | liftTyped ar = [|| fromList' arlen arlist ||] 521 | #else 522 | lift ar = [| fromList' arlen arlist |] 523 | #endif 524 | where 525 | arlen = length ar 526 | arlist = toList ar 527 | 528 | toList :: Array a -> [a] 529 | toList = foldr (:) [] 530 | 531 | newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (Array a)} 532 | 533 | runSTA :: Int -> STA a -> Array a 534 | runSTA !n (STA m) = runST $ new_ n >>= \ (MArray ar) -> m ar 535 | 536 | traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b) 537 | traverse f = \ !ary -> 538 | let 539 | !len = length ary 540 | go !i 541 | | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary) 542 | | (# x #) <- index# ary i 543 | = liftA2 (\b (STA m) -> STA $ \mary -> 544 | write (MArray mary) i b >> m mary) 545 | (f x) (go (i + 1)) 546 | in runSTA len <$> go 0 547 | {-# INLINE [1] traverse #-} 548 | 549 | -- TODO: Would it be better to just use a lazy traversal 550 | -- and then force the elements of the result? My guess is 551 | -- yes. 552 | traverse' :: Applicative f => (a -> f b) -> Array a -> f (Array b) 553 | traverse' f = \ !ary -> 554 | let 555 | !len = length ary 556 | go !i 557 | | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary) 558 | | (# x #) <- index# ary i 559 | = liftA2 (\ !b (STA m) -> STA $ \mary -> 560 | write (MArray mary) i b >> m mary) 561 | (f x) (go (i + 1)) 562 | in runSTA len <$> go 0 563 | {-# INLINE [1] traverse' #-} 564 | 565 | -- Traversing in ST, we don't need to get fancy; we 566 | -- can just do it directly. 567 | traverseST :: (a -> ST s b) -> Array a -> ST s (Array b) 568 | traverseST f = \ ary0 -> 569 | let 570 | !len = length ary0 571 | go k !mary 572 | | k == len = return mary 573 | | otherwise = do 574 | x <- indexM ary0 k 575 | y <- f x 576 | write mary k y 577 | go (k + 1) mary 578 | in new_ len >>= (go 0 >=> unsafeFreeze) 579 | {-# INLINE traverseST #-} 580 | 581 | traverseIO :: (a -> IO b) -> Array a -> IO (Array b) 582 | traverseIO f = \ ary0 -> 583 | let 584 | !len = length ary0 585 | go k !mary 586 | | k == len = return mary 587 | | otherwise = do 588 | x <- stToIO $ indexM ary0 k 589 | y <- f x 590 | stToIO $ write mary k y 591 | go (k + 1) mary 592 | in stToIO (new_ len) >>= (go 0 >=> stToIO . unsafeFreeze) 593 | {-# INLINE traverseIO #-} 594 | 595 | 596 | -- Why don't we have similar RULES for traverse'? The efficient 597 | -- way to traverse strictly in IO or ST is to force results as 598 | -- they come in, which leads to different semantics. In particular, 599 | -- we need to ensure that 600 | -- 601 | -- traverse' (\x -> print x *> pure undefined) xs 602 | -- 603 | -- will actually print all the values and then return undefined. 604 | -- We could add a strict mapMWithIndex, operating in an arbitrary 605 | -- Monad, that supported such rules, but we don't have that right now. 606 | {-# RULES 607 | "traverse/ST" forall f. traverse f = traverseST f 608 | "traverse/IO" forall f. traverse f = traverseIO f 609 | #-} 610 | -------------------------------------------------------------------------------- /Data/HashMap/Internal/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | -- | = WARNING 5 | -- 6 | -- This module is considered __internal__. 7 | -- 8 | -- The Package Versioning Policy __does not apply__. 9 | -- 10 | -- The contents of this module may change __in any way whatsoever__ 11 | -- and __without any warning__ between minor versions of this package. 12 | -- 13 | -- Authors importing this module are expected to track development 14 | -- closely. 15 | -- 16 | -- = Description 17 | -- 18 | -- Debugging utilities for 'HashMap's. 19 | 20 | module Data.HashMap.Internal.Debug 21 | ( valid 22 | , Validity(..) 23 | , Error(..) 24 | , SubHash 25 | , SubHashPath 26 | ) where 27 | 28 | import Data.Bits (complement, countTrailingZeros, popCount, shiftL, 29 | unsafeShiftL, (.&.), (.|.)) 30 | import Data.Hashable (Hashable) 31 | import Data.HashMap.Internal (Bitmap, Hash, HashMap (..), Leaf (..), 32 | bitsPerSubkey, fullBitmap, hash, 33 | isLeafOrCollision, maxChildren, sparseIndex) 34 | import Data.Semigroup (Sum (..)) 35 | 36 | import qualified Data.HashMap.Internal.Array as A 37 | 38 | 39 | #if !MIN_VERSION_base(4,11,0) 40 | import Data.Semigroup (Semigroup (..)) 41 | #endif 42 | 43 | data Validity k = Invalid (Error k) SubHashPath | Valid 44 | deriving (Eq, Show) 45 | 46 | instance Semigroup (Validity k) where 47 | Valid <> y = y 48 | x <> _ = x 49 | 50 | instance Monoid (Validity k) where 51 | mempty = Valid 52 | mappend = (<>) 53 | 54 | -- | An error corresponding to a broken invariant. 55 | -- 56 | -- See 'HashMap' for the documentation of the invariants. 57 | data Error k 58 | = INV1_internal_Empty 59 | | INV2_Bitmap_unexpected_1_bits !Bitmap 60 | | INV3_bad_BitmapIndexed_size !Int 61 | | INV4_bitmap_array_size_mismatch !Bitmap !Int 62 | | INV5_BitmapIndexed_invalid_single_subtree 63 | | INV6_misplaced_hash !Hash 64 | | INV7_key_hash_mismatch k !Hash 65 | | INV8_bad_Full_size !Int 66 | | INV9_Collision_size !Int 67 | | INV10_Collision_duplicate_key k !Hash 68 | deriving (Eq, Show) 69 | 70 | -- TODO: Name this 'Index'?! 71 | -- (https://github.com/haskell-unordered-containers/unordered-containers/issues/425) 72 | -- | A part of a 'Hash' with 'bitsPerSubkey' bits. 73 | type SubHash = Word 74 | 75 | data SubHashPath = SubHashPath 76 | { partialHash :: !Word 77 | -- ^ The bits we already know, starting from the lower bits. 78 | -- The unknown upper bits are @0@. 79 | , lengthInBits :: !Int 80 | -- ^ The number of bits known. 81 | } deriving (Eq, Show) 82 | 83 | initialSubHashPath :: SubHashPath 84 | initialSubHashPath = SubHashPath 0 0 85 | 86 | addSubHash :: SubHashPath -> SubHash -> SubHashPath 87 | addSubHash (SubHashPath ph l) sh = 88 | SubHashPath (ph .|. (sh `unsafeShiftL` l)) (l + bitsPerSubkey) 89 | 90 | hashMatchesSubHashPath :: SubHashPath -> Hash -> Bool 91 | hashMatchesSubHashPath (SubHashPath ph l) h = maskToLength h l == ph 92 | where 93 | -- Note: This needs to use `shiftL` instead of `unsafeShiftL` because 94 | -- @l'@ may be greater than 32/64 at the deepest level. 95 | maskToLength h' l' = h' .&. complement (complement 0 `shiftL` l') 96 | 97 | valid :: Hashable k => HashMap k v -> Validity k 98 | valid Empty = Valid 99 | valid t = validInternal initialSubHashPath t 100 | where 101 | validInternal p Empty = Invalid INV1_internal_Empty p 102 | validInternal p (Leaf h l) = validHash p h <> validLeaf p h l 103 | validInternal p (Collision h ary) = validHash p h <> validCollision p h ary 104 | validInternal p (BitmapIndexed b ary) = validBitmapIndexed p b ary 105 | validInternal p (Full ary) = validFull p ary 106 | 107 | validHash p h | hashMatchesSubHashPath p h = Valid 108 | | otherwise = Invalid (INV6_misplaced_hash h) p 109 | 110 | validLeaf p h (L k _) | hash k == h = Valid 111 | | otherwise = Invalid (INV7_key_hash_mismatch k h) p 112 | 113 | validCollision p h ary = validCollisionSize <> A.foldMap (validLeaf p h) ary <> distinctKeys 114 | where 115 | n = A.length ary 116 | validCollisionSize | n < 2 = Invalid (INV9_Collision_size n) p 117 | | otherwise = Valid 118 | distinctKeys = A.foldMap (\(L k _) -> appearsOnce k) ary 119 | appearsOnce k | A.foldMap (\(L k' _) -> if k' == k then Sum @Int 1 else Sum 0) ary == 1 = Valid 120 | | otherwise = Invalid (INV10_Collision_duplicate_key k h) p 121 | 122 | validBitmapIndexed p b ary = validBitmap <> validArraySize <> validSubTrees p b ary 123 | where 124 | validBitmap | b .&. complement fullBitmap == 0 = Valid 125 | | otherwise = Invalid (INV2_Bitmap_unexpected_1_bits b) p 126 | n = A.length ary 127 | validArraySize | n < 1 || n >= maxChildren = Invalid (INV3_bad_BitmapIndexed_size n) p 128 | | popCount b == n = Valid 129 | | otherwise = Invalid (INV4_bitmap_array_size_mismatch b n) p 130 | 131 | validSubTrees p b ary 132 | | A.length ary == 1 133 | , isLeafOrCollision (A.index ary 0) 134 | = Invalid INV5_BitmapIndexed_invalid_single_subtree p 135 | | otherwise = go b 136 | where 137 | go 0 = Valid 138 | go b' = validInternal (addSubHash p (fromIntegral c)) (A.index ary i) <> go b'' 139 | where 140 | c = countTrailingZeros b' 141 | m = 1 `unsafeShiftL` c 142 | i = sparseIndex b m 143 | b'' = b' .&. complement m 144 | 145 | validFull p ary = validArraySize <> validSubTrees p fullBitmap ary 146 | where 147 | n = A.length ary 148 | validArraySize | n == maxChildren = Valid 149 | | otherwise = Invalid (INV8_bad_Full_size n) p 150 | -------------------------------------------------------------------------------- /Data/HashMap/Internal/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} 4 | {-# OPTIONS_HADDOCK not-home #-} 5 | 6 | -- | = WARNING 7 | -- 8 | -- This module is considered __internal__. 9 | -- 10 | -- The Package Versioning Policy __does not apply__. 11 | -- 12 | -- The contents of this module may change __in any way whatsoever__ 13 | -- and __without any warning__ between minor versions of this package. 14 | -- 15 | -- Authors importing this module are expected to track development 16 | -- closely. 17 | -- 18 | -- = Description 19 | -- 20 | -- Extra list functions 21 | -- 22 | -- In separate module to aid testing. 23 | module Data.HashMap.Internal.List 24 | ( isPermutationBy 25 | , deleteBy 26 | , unorderedCompare 27 | ) where 28 | 29 | import Data.List (sortBy) 30 | import Data.Maybe (fromMaybe) 31 | #if !MIN_VERSION_base(4,11,0) 32 | import Data.Semigroup ((<>)) 33 | #endif 34 | 35 | -- Note: previous implementation isPermutation = null (as // bs) 36 | -- was O(n^2) too. 37 | -- 38 | -- This assumes lists are of equal length 39 | isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool 40 | isPermutationBy f = go 41 | where 42 | f' = flip f 43 | 44 | go [] [] = True 45 | go (x : xs) (y : ys) 46 | | f x y = go xs ys 47 | | otherwise = fromMaybe False $ do 48 | xs' <- deleteBy f' y xs 49 | ys' <- deleteBy f x ys 50 | return (go xs' ys') 51 | go [] (_ : _) = False 52 | go (_ : _) [] = False 53 | 54 | -- The idea: 55 | -- 56 | -- Homogenous version 57 | -- 58 | -- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering 59 | -- uc c as bs = compare (sortBy c as) (sortBy c bs) 60 | -- 61 | -- But as we have only (a -> b -> Ordering), we cannot directly compare 62 | -- elements from the same list. 63 | -- 64 | -- So when comparing elements from the list, we count how many elements are 65 | -- "less and greater" in the other list, and use the count as a metric. 66 | -- 67 | unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering 68 | unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs) 69 | where 70 | go [] [] = EQ 71 | go [] (_ : _) = LT 72 | go (_ : _) [] = GT 73 | go (x : xs) (y : ys) = c x y <> go xs ys 74 | 75 | cmpA a a' = compare (inB a) (inB a') 76 | cmpB b b' = compare (inA b) (inA b') 77 | 78 | inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs) 79 | inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as) 80 | 81 | -- Returns Nothing is nothing deleted 82 | deleteBy :: (a -> b -> Bool) -> a -> [b] -> Maybe [b] 83 | deleteBy _ _ [] = Nothing 84 | deleteBy eq x (y:ys) = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys) 85 | -------------------------------------------------------------------------------- /Data/HashMap/Internal/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE PatternGuards #-} 6 | {-# LANGUAGE Trustworthy #-} 7 | {-# LANGUAGE UnboxedTuples #-} 8 | {-# OPTIONS_HADDOCK not-home #-} 9 | 10 | ------------------------------------------------------------------------ 11 | -- | 12 | -- Module : Data.HashMap.Strict 13 | -- Copyright : 2010-2012 Johan Tibell 14 | -- License : BSD-style 15 | -- Maintainer : johan.tibell@gmail.com 16 | -- Portability : portable 17 | -- 18 | -- = WARNING 19 | -- 20 | -- This module is considered __internal__. 21 | -- 22 | -- The Package Versioning Policy __does not apply__. 23 | -- 24 | -- The contents of this module may change __in any way whatsoever__ 25 | -- and __without any warning__ between minor versions of this package. 26 | -- 27 | -- Authors importing this module are expected to track development 28 | -- closely. 29 | -- 30 | -- = Description 31 | -- 32 | -- A map from /hashable/ keys to values. A map cannot contain 33 | -- duplicate keys; each key can map to at most one value. A 'HashMap' 34 | -- makes no guarantees as to the order of its elements. 35 | -- 36 | -- The implementation is based on /hash array mapped tries/. A 37 | -- 'HashMap' is often faster than other tree-based set types, 38 | -- especially when key comparison is expensive, as in the case of 39 | -- strings. 40 | -- 41 | -- Many operations have a average-case complexity of \(O(\log n)\). The 42 | -- implementation uses a large base (i.e. 32) so in practice these 43 | -- operations are constant time. 44 | module Data.HashMap.Internal.Strict 45 | ( 46 | -- * Strictness properties 47 | -- $strictness 48 | 49 | HashMap 50 | 51 | -- * Construction 52 | , HM.empty 53 | , singleton 54 | 55 | -- * Basic interface 56 | , HM.null 57 | , HM.size 58 | , HM.member 59 | , HM.lookup 60 | , (HM.!?) 61 | , HM.findWithDefault 62 | , HM.lookupDefault 63 | , (HM.!) 64 | , insert 65 | , insertWith 66 | , HM.delete 67 | , adjust 68 | , update 69 | , alter 70 | , alterF 71 | , HM.isSubmapOf 72 | , HM.isSubmapOfBy 73 | 74 | -- * Combine 75 | -- ** Union 76 | , HM.union 77 | , unionWith 78 | , unionWithKey 79 | , HM.unions 80 | 81 | -- ** Compose 82 | , HM.compose 83 | 84 | -- * Transformations 85 | , map 86 | , mapWithKey 87 | , traverseWithKey 88 | , HM.mapKeys 89 | 90 | -- * Difference and intersection 91 | , HM.difference 92 | , differenceWith 93 | , HM.intersection 94 | , intersectionWith 95 | , intersectionWithKey 96 | 97 | -- * Folds 98 | , HM.foldMapWithKey 99 | , HM.foldr' 100 | , HM.foldl' 101 | , HM.foldrWithKey' 102 | , HM.foldlWithKey' 103 | , HM.foldr 104 | , HM.foldl 105 | , HM.foldrWithKey 106 | , HM.foldlWithKey 107 | 108 | -- * Filter 109 | , HM.filter 110 | , HM.filterWithKey 111 | , mapMaybe 112 | , mapMaybeWithKey 113 | 114 | -- * Conversions 115 | , HM.keys 116 | , HM.elems 117 | 118 | -- ** Lists 119 | , HM.toList 120 | , fromList 121 | , fromListWith 122 | , fromListWithKey 123 | ) where 124 | 125 | import Control.Applicative (Const (..)) 126 | import Control.Monad.ST (runST) 127 | import Data.Bits ((.&.), (.|.)) 128 | import Data.Coerce (coerce) 129 | import Data.Functor.Identity (Identity (..)) 130 | -- See Note [Imports from Data.HashMap.Internal] 131 | import Data.Hashable (Hashable) 132 | import Data.HashMap.Internal (Hash, HashMap (..), Leaf (..), LookupRes (..), 133 | fullBitmap, hash, index, mask, nextShift, ptrEq, 134 | sparseIndex) 135 | import Prelude hiding (lookup, map) 136 | 137 | -- See Note [Imports from Data.HashMap.Internal] 138 | import qualified Data.HashMap.Internal as HM 139 | import qualified Data.HashMap.Internal.Array as A 140 | import qualified Data.List as List 141 | import qualified GHC.Exts as Exts 142 | 143 | {- 144 | Note [Imports from Data.HashMap.Internal] 145 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 146 | 147 | It is very important for code in this module not to make mistakes about 148 | the strictness properties of any utilities. Mistakes can easily lead to space 149 | leaks, see e.g. #383. 150 | 151 | Therefore nearly all functions imported from Data.HashMap.Internal should be 152 | imported qualified. Only functions that do not manipulate HashMaps or their 153 | values are exempted. 154 | -} 155 | 156 | -- $strictness 157 | -- 158 | -- This module satisfies the following strictness properties: 159 | -- 160 | -- 1. Key arguments are evaluated to WHNF; 161 | -- 162 | -- 2. Keys and values are evaluated to WHNF before they are stored in 163 | -- the map. 164 | 165 | ------------------------------------------------------------------------ 166 | -- * Construction 167 | 168 | -- | \(O(1)\) Construct a map with a single element. 169 | singleton :: (Hashable k) => k -> v -> HashMap k v 170 | singleton k !v = HM.singleton k v 171 | 172 | ------------------------------------------------------------------------ 173 | -- * Basic interface 174 | 175 | -- | \(O(\log n)\) Associate the specified value with the specified 176 | -- key in this map. If this map previously contained a mapping for 177 | -- the key, the old value is replaced. 178 | insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v 179 | insert k !v = HM.insert k v 180 | {-# INLINABLE insert #-} 181 | 182 | -- | \(O(\log n)\) Associate the value with the key in this map. If 183 | -- this map previously contained a mapping for the key, the old value 184 | -- is replaced by the result of applying the given function to the new 185 | -- and old value. Example: 186 | -- 187 | -- > insertWith f k v map 188 | -- > where f new old = new + old 189 | insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v 190 | -> HashMap k v 191 | insertWith f k0 v0 m0 = go h0 k0 v0 0 m0 192 | where 193 | h0 = hash k0 194 | go !h !k x !_ Empty = leaf h k x 195 | go h k x s t@(Leaf hy l@(L ky y)) 196 | | hy == h = if ky == k 197 | then leaf h k (f x y) 198 | else x `seq` HM.collision h l (L k x) 199 | | otherwise = x `seq` runST (HM.two s h k x hy t) 200 | go h k x s (BitmapIndexed b ary) 201 | | b .&. m == 0 = 202 | let ary' = A.insert ary i $! leaf h k x 203 | in HM.bitmapIndexedOrFull (b .|. m) ary' 204 | | otherwise = 205 | let st = A.index ary i 206 | st' = go h k x (nextShift s) st 207 | ary' = A.update ary i $! st' 208 | in BitmapIndexed b ary' 209 | where m = mask h s 210 | i = sparseIndex b m 211 | go h k x s (Full ary) = 212 | let st = A.index ary i 213 | st' = go h k x (nextShift s) st 214 | ary' = HM.update32 ary i $! st' 215 | in Full ary' 216 | where i = index h s 217 | go h k x s t@(Collision hy v) 218 | | h == hy = Collision h (updateOrSnocWith f k x v) 219 | | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) 220 | {-# INLINABLE insertWith #-} 221 | 222 | -- | In-place update version of insertWith 223 | unsafeInsertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v 224 | -> HashMap k v 225 | unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (const f) k0 v0 m0 226 | {-# INLINABLE unsafeInsertWith #-} 227 | 228 | unsafeInsertWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> k -> v -> HashMap k v 229 | -> HashMap k v 230 | unsafeInsertWithKey f k0 v0 m0 = runST (go h0 k0 v0 0 m0) 231 | where 232 | h0 = hash k0 233 | go !h !k x !_ Empty = return $! leaf h k x 234 | go h k x s t@(Leaf hy l@(L ky y)) 235 | | hy == h = if ky == k 236 | then return $! leaf h k (f k x y) 237 | else do 238 | let l' = x `seq` L k x 239 | return $! HM.collision h l l' 240 | | otherwise = x `seq` HM.two s h k x hy t 241 | go h k x s t@(BitmapIndexed b ary) 242 | | b .&. m == 0 = do 243 | ary' <- A.insertM ary i $! leaf h k x 244 | return $! HM.bitmapIndexedOrFull (b .|. m) ary' 245 | | otherwise = do 246 | st <- A.indexM ary i 247 | st' <- go h k x (nextShift s) st 248 | A.unsafeUpdateM ary i st' 249 | return t 250 | where m = mask h s 251 | i = sparseIndex b m 252 | go h k x s t@(Full ary) = do 253 | st <- A.indexM ary i 254 | st' <- go h k x (nextShift s) st 255 | A.unsafeUpdateM ary i st' 256 | return t 257 | where i = index h s 258 | go h k x s t@(Collision hy v) 259 | | h == hy = return $! Collision h (updateOrSnocWithKey f k x v) 260 | | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) 261 | {-# INLINABLE unsafeInsertWithKey #-} 262 | 263 | -- | \(O(\log n)\) Adjust the value tied to a given key in this map only 264 | -- if it is present. Otherwise, leave the map alone. 265 | adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v 266 | adjust f k0 m0 = go h0 k0 0 m0 267 | where 268 | h0 = hash k0 269 | go !_ !_ !_ Empty = Empty 270 | go h k _ t@(Leaf hy (L ky y)) 271 | | hy == h && ky == k = leaf h k (f y) 272 | | otherwise = t 273 | go h k s t@(BitmapIndexed b ary) 274 | | b .&. m == 0 = t 275 | | otherwise = let st = A.index ary i 276 | st' = go h k (nextShift s) st 277 | ary' = A.update ary i $! st' 278 | in BitmapIndexed b ary' 279 | where m = mask h s 280 | i = sparseIndex b m 281 | go h k s (Full ary) = 282 | let i = index h s 283 | st = A.index ary i 284 | st' = go h k (nextShift s) st 285 | ary' = HM.update32 ary i $! st' 286 | in Full ary' 287 | go h k _ t@(Collision hy v) 288 | | h == hy = Collision h (updateWith f k v) 289 | | otherwise = t 290 | {-# INLINABLE adjust #-} 291 | 292 | -- | \(O(\log n)\) The expression @('update' f k map)@ updates the value @x@ at @k@ 293 | -- (if it is in the map). If @(f x)@ is 'Nothing', the element is deleted. 294 | -- If it is @('Just' y)@, the key @k@ is bound to the new value @y@. 295 | update :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a 296 | update f = alter (>>= f) 297 | {-# INLINABLE update #-} 298 | 299 | -- | \(O(\log n)\) The expression @('alter' f k map)@ alters the value @x@ at @k@, or 300 | -- absence thereof. 301 | -- 302 | -- 'alter' can be used to insert, delete, or update a value in a map. In short: 303 | -- 304 | -- @ 305 | -- 'lookup' k ('alter' f k m) = f ('lookup' k m) 306 | -- @ 307 | alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v 308 | alter f k m = 309 | let !h = hash k 310 | !lookupRes = HM.lookupRecordCollision h k m 311 | in case f (HM.lookupResToMaybe lookupRes) of 312 | Nothing -> case lookupRes of 313 | Absent -> m 314 | Present _ collPos -> HM.deleteKeyExists collPos h k m 315 | Just !v' -> case lookupRes of 316 | Absent -> HM.insertNewKey h k v' m 317 | Present v collPos -> 318 | if v `ptrEq` v' 319 | then m 320 | else HM.insertKeyExists collPos h k v' m 321 | {-# INLINABLE alter #-} 322 | 323 | -- | \(O(\log n)\) The expression (@'alterF' f k map@) alters the value @x@ at 324 | -- @k@, or absence thereof. 325 | -- 326 | -- 'alterF' can be used to insert, delete, or update a value in a map. 327 | -- 328 | -- Note: 'alterF' is a flipped version of the 'at' combinator from 329 | -- . 330 | -- 331 | -- @since 0.2.10 332 | alterF :: (Functor f, Eq k, Hashable k) 333 | => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v) 334 | -- Special care is taken to only calculate the hash once. When we rewrite 335 | -- with RULES, we also ensure that we only compare the key for equality 336 | -- once. We force the value of the map for consistency with the rewritten 337 | -- version; otherwise someone could tell the difference using a lazy 338 | -- @f@ and a functor that is similar to Const but not actually Const. 339 | alterF f = \ !k !m -> 340 | let !h = hash k 341 | mv = HM.lookup' h k m 342 | in (<$> f mv) $ \case 343 | Nothing -> maybe m (const (HM.delete' h k m)) mv 344 | Just !v' -> HM.insert' h k v' m 345 | 346 | -- We rewrite this function unconditionally in RULES, but we expose 347 | -- an unfolding just in case it's used in a context where the rules 348 | -- don't fire. 349 | {-# INLINABLE [0] alterF #-} 350 | 351 | -- See notes in Data.HashMap.Internal 352 | test_bottom :: a 353 | test_bottom = error "Data.HashMap.alterF internal error: hit test_bottom" 354 | 355 | bogus# :: (# #) -> (# a #) 356 | bogus# _ = error "Data.HashMap.alterF internal error: hit bogus#" 357 | 358 | impossibleAdjust :: a 359 | impossibleAdjust = error "Data.HashMap.alterF internal error: impossible adjust" 360 | 361 | {-# RULES 362 | 363 | -- See detailed notes on alterF rules in Data.HashMap.Internal. 364 | 365 | "alterFWeird" forall f. alterF f = 366 | alterFWeird (f Nothing) (f (Just test_bottom)) f 367 | 368 | "alterFconstant" forall (f :: Maybe a -> Identity (Maybe a)) x. 369 | alterFWeird x x f = \ !k !m -> 370 | Identity (case runIdentity x of {Nothing -> HM.delete k m; Just a -> insert k a m}) 371 | 372 | "alterFinsertWith" [1] forall (f :: Maybe a -> Identity (Maybe a)) x y. 373 | alterFWeird (coerce (Just x)) (coerce (Just y)) f = 374 | coerce (HM.insertModifying x (\mold -> case runIdentity (f (Just mold)) of 375 | Nothing -> bogus# (# #) 376 | Just !new -> (# new #))) 377 | 378 | -- This rule is written a bit differently than the one for lazy 379 | -- maps because the adjust here is strict. We could write it the 380 | -- same general way anyway, but this seems simpler. 381 | "alterFadjust" forall (f :: Maybe a -> Identity (Maybe a)) x. 382 | alterFWeird (coerce Nothing) (coerce (Just x)) f = 383 | coerce (adjust (\a -> case runIdentity (f (Just a)) of 384 | Just a' -> a' 385 | Nothing -> impossibleAdjust)) 386 | 387 | "alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)) . 388 | alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (HM.lookup k m))) 389 | #-} 390 | 391 | -- This is a very unsafe version of alterF used for RULES. When calling 392 | -- alterFWeird x y f, the following *must* hold: 393 | -- 394 | -- x = f Nothing 395 | -- y = f (Just _|_) 396 | -- 397 | -- Failure to abide by these laws will make demons come out of your nose. 398 | alterFWeird 399 | :: (Functor f, Eq k, Hashable k) 400 | => f (Maybe v) 401 | -> f (Maybe v) 402 | -> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v) 403 | alterFWeird _ _ f = alterFEager f 404 | {-# INLINE [0] alterFWeird #-} 405 | 406 | -- | This is the default version of alterF that we use in most non-trivial 407 | -- cases. It's called "eager" because it looks up the given key in the map 408 | -- eagerly, whether or not the given function requires that information. 409 | alterFEager :: (Functor f, Eq k, Hashable k) 410 | => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v) 411 | alterFEager f !k !m = (<$> f mv) $ \fres -> 412 | case fres of 413 | 414 | ------------------------------ 415 | -- Delete the key from the map. 416 | Nothing -> case lookupRes of 417 | 418 | -- Key did not exist in the map to begin with, no-op 419 | Absent -> m 420 | 421 | -- Key did exist, no collision 422 | Present _ collPos -> HM.deleteKeyExists collPos h k m 423 | 424 | ------------------------------ 425 | -- Update value 426 | Just !v' -> case lookupRes of 427 | 428 | -- Key did not exist before, insert v' under a new key 429 | Absent -> HM.insertNewKey h k v' m 430 | 431 | -- Key existed before, no hash collision 432 | Present v collPos -> 433 | if v `ptrEq` v' 434 | -- If the value is identical, no-op 435 | then m 436 | -- If the value changed, update the value. 437 | else HM.insertKeyExists collPos h k v' m 438 | 439 | where !h = hash k 440 | !lookupRes = HM.lookupRecordCollision h k m 441 | !mv = HM.lookupResToMaybe lookupRes 442 | {-# INLINABLE alterFEager #-} 443 | 444 | ------------------------------------------------------------------------ 445 | -- * Combine 446 | 447 | -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, 448 | -- the provided function (first argument) will be used to compute the result. 449 | unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v 450 | -> HashMap k v 451 | unionWith f = unionWithKey (const f) 452 | {-# INLINE unionWith #-} 453 | 454 | -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, 455 | -- the provided function (first argument) will be used to compute the result. 456 | unionWithKey :: Eq k => (k -> v -> v -> v) -> HashMap k v -> HashMap k v 457 | -> HashMap k v 458 | unionWithKey f = go 0 459 | where 460 | -- empty vs. anything 461 | go !_ t1 Empty = t1 462 | go _ Empty t2 = t2 463 | -- leaf vs. leaf 464 | go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2)) 465 | | h1 == h2 = if k1 == k2 466 | then leaf h1 k1 (f k1 v1 v2) 467 | else HM.collision h1 l1 l2 468 | | otherwise = goDifferentHash s h1 h2 t1 t2 469 | go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2) 470 | | h1 == h2 = Collision h1 (updateOrSnocWithKey f k1 v1 ls2) 471 | | otherwise = goDifferentHash s h1 h2 t1 t2 472 | go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2)) 473 | | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1) 474 | | otherwise = goDifferentHash s h1 h2 t1 t2 475 | go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) 476 | | h1 == h2 = Collision h1 (HM.updateOrConcatWithKey (\k a b -> let !v = f k a b in (# v #)) ls1 ls2) 477 | | otherwise = goDifferentHash s h1 h2 t1 t2 478 | -- branch vs. branch 479 | go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = 480 | let b' = b1 .|. b2 481 | ary' = HM.unionArrayBy (go (nextShift s)) b1 b2 ary1 ary2 482 | in HM.bitmapIndexedOrFull b' ary' 483 | go s (BitmapIndexed b1 ary1) (Full ary2) = 484 | let ary' = HM.unionArrayBy (go (nextShift s)) b1 fullBitmap ary1 ary2 485 | in Full ary' 486 | go s (Full ary1) (BitmapIndexed b2 ary2) = 487 | let ary' = HM.unionArrayBy (go (nextShift s)) fullBitmap b2 ary1 ary2 488 | in Full ary' 489 | go s (Full ary1) (Full ary2) = 490 | let ary' = HM.unionArrayBy (go (nextShift s)) fullBitmap fullBitmap 491 | ary1 ary2 492 | in Full ary' 493 | -- leaf vs. branch 494 | go s (BitmapIndexed b1 ary1) t2 495 | | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2 496 | b' = b1 .|. m2 497 | in HM.bitmapIndexedOrFull b' ary' 498 | | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> 499 | go (nextShift s) st1 t2 500 | in BitmapIndexed b1 ary' 501 | where 502 | h2 = leafHashCode t2 503 | m2 = mask h2 s 504 | i = sparseIndex b1 m2 505 | go s t1 (BitmapIndexed b2 ary2) 506 | | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 507 | b' = b2 .|. m1 508 | in HM.bitmapIndexedOrFull b' ary' 509 | | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> 510 | go (nextShift s) t1 st2 511 | in BitmapIndexed b2 ary' 512 | where 513 | h1 = leafHashCode t1 514 | m1 = mask h1 s 515 | i = sparseIndex b2 m1 516 | go s (Full ary1) t2 = 517 | let h2 = leafHashCode t2 518 | i = index h2 s 519 | ary' = HM.update32With' ary1 i $ \st1 -> go (nextShift s) st1 t2 520 | in Full ary' 521 | go s t1 (Full ary2) = 522 | let h1 = leafHashCode t1 523 | i = index h1 s 524 | ary' = HM.update32With' ary2 i $ \st2 -> go (nextShift s) t1 st2 525 | in Full ary' 526 | 527 | leafHashCode (Leaf h _) = h 528 | leafHashCode (Collision h _) = h 529 | leafHashCode _ = error "leafHashCode" 530 | 531 | goDifferentHash s h1 h2 t1 t2 532 | | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (nextShift s) h1 h2 t1 t2) 533 | | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) 534 | | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) 535 | where 536 | m1 = mask h1 s 537 | m2 = mask h2 s 538 | {-# INLINE unionWithKey #-} 539 | 540 | ------------------------------------------------------------------------ 541 | -- * Transformations 542 | 543 | -- | \(O(n)\) Transform this map by applying a function to every value. 544 | mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2 545 | mapWithKey f = go 546 | where 547 | go Empty = Empty 548 | go (Leaf h (L k v)) = leaf h k (f k v) 549 | go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary 550 | go (Full ary) = Full $ A.map' go ary 551 | go (Collision h ary) = 552 | Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary 553 | {-# INLINE mapWithKey #-} 554 | 555 | -- | \(O(n)\) Transform this map by applying a function to every value. 556 | map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 557 | map f = mapWithKey (const f) 558 | {-# INLINE map #-} 559 | 560 | 561 | ------------------------------------------------------------------------ 562 | -- * Filter 563 | 564 | -- | \(O(n)\) Transform this map by applying a function to every value 565 | -- and retaining only some of them. 566 | mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 567 | mapMaybeWithKey f = HM.filterMapAux onLeaf onColl 568 | where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (leaf h k v') 569 | onLeaf _ = Nothing 570 | 571 | onColl (L k v) | Just !v' <- f k v = Just (L k v') 572 | | otherwise = Nothing 573 | {-# INLINE mapMaybeWithKey #-} 574 | 575 | -- | \(O(n)\) Transform this map by applying a function to every value 576 | -- and retaining only some of them. 577 | mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 578 | mapMaybe f = mapMaybeWithKey (const f) 579 | {-# INLINE mapMaybe #-} 580 | 581 | -- | \(O(n)\) Perform an 'Applicative' action for each key-value pair 582 | -- in a 'HashMap' and produce a 'HashMap' of all the results. Each 'HashMap' 583 | -- will be strict in all its values. 584 | -- 585 | -- @ 586 | -- traverseWithKey f = fmap ('map' id) . "Data.HashMap.Lazy".'Data.HashMap.Lazy.traverseWithKey' f 587 | -- @ 588 | -- 589 | -- Note: the order in which the actions occur is unspecified. In particular, 590 | -- when the map contains hash collisions, the order in which the actions 591 | -- associated with the keys involved will depend in an unspecified way on 592 | -- their insertion order. 593 | traverseWithKey 594 | :: Applicative f 595 | => (k -> v1 -> f v2) 596 | -> HashMap k v1 -> f (HashMap k v2) 597 | traverseWithKey f = go 598 | where 599 | go Empty = pure Empty 600 | go (Leaf h (L k v)) = leaf h k <$> f k v 601 | go (BitmapIndexed b ary) = BitmapIndexed b <$> A.traverse' go ary 602 | go (Full ary) = Full <$> A.traverse' go ary 603 | go (Collision h ary) = 604 | Collision h <$> A.traverse' (\ (L k v) -> (L k $!) <$> f k v) ary 605 | {-# INLINE traverseWithKey #-} 606 | 607 | ------------------------------------------------------------------------ 608 | -- * Difference and intersection 609 | 610 | -- | \(O(n \log m)\) Difference with a combining function. When two equal keys are 611 | -- encountered, the combining function is applied to the values of these keys. 612 | -- If it returns 'Nothing', the element is discarded (proper set difference). If 613 | -- it returns (@'Just' y@), the element is updated with a new value @y@. 614 | differenceWith :: (Eq k, Hashable k) => (v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v 615 | differenceWith f a b = HM.foldlWithKey' go HM.empty a 616 | where 617 | go m k v = case HM.lookup k b of 618 | Nothing -> v `seq` HM.unsafeInsert k v m 619 | Just w -> maybe m (\ !y -> HM.unsafeInsert k y m) (f v w) 620 | {-# INLINABLE differenceWith #-} 621 | 622 | -- | \(O(n+m)\) Intersection of two maps. If a key occurs in both maps 623 | -- the provided function is used to combine the values from the two 624 | -- maps. 625 | intersectionWith :: Eq k => (v1 -> v2 -> v3) -> HashMap k v1 626 | -> HashMap k v2 -> HashMap k v3 627 | intersectionWith f = Exts.inline intersectionWithKey $ const f 628 | {-# INLINABLE intersectionWith #-} 629 | 630 | -- | \(O(n+m)\) Intersection of two maps. If a key occurs in both maps 631 | -- the provided function is used to combine the values from the two 632 | -- maps. 633 | intersectionWithKey :: Eq k => (k -> v1 -> v2 -> v3) 634 | -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 635 | intersectionWithKey f = HM.intersectionWithKey# $ \k v1 v2 -> let !v3 = f k v1 v2 in (# v3 #) 636 | {-# INLINABLE intersectionWithKey #-} 637 | 638 | ------------------------------------------------------------------------ 639 | -- ** Lists 640 | 641 | -- | \(O(n \log n)\) Construct a map with the supplied mappings. If the 642 | -- list contains duplicate mappings, the later mappings take 643 | -- precedence. 644 | fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v 645 | fromList = List.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) HM.empty 646 | {-# INLINABLE fromList #-} 647 | 648 | -- | \(O(n \log n)\) Construct a map from a list of elements. Uses 649 | -- the provided function @f@ to merge duplicate entries with 650 | -- @(f newVal oldVal)@. 651 | -- 652 | -- === Examples 653 | -- 654 | -- Given a list @xs@, create a map with the number of occurrences of each 655 | -- element in @xs@: 656 | -- 657 | -- > let xs = ['a', 'b', 'a'] 658 | -- > in fromListWith (+) [ (x, 1) | x <- xs ] 659 | -- > 660 | -- > = fromList [('a', 2), ('b', 1)] 661 | -- 662 | -- Given a list of key-value pairs @xs :: [(k, v)]@, group all values by their 663 | -- keys and return a @HashMap k [v]@. 664 | -- 665 | -- > let xs = ('a', 1), ('b', 2), ('a', 3)] 666 | -- > in fromListWith (++) [ (k, [v]) | (k, v) <- xs ] 667 | -- > 668 | -- > = fromList [('a', [3, 1]), ('b', [2])] 669 | -- 670 | -- Note that the lists in the resulting map contain elements in reverse order 671 | -- from their occurrences in the original list. 672 | -- 673 | -- More generally, duplicate entries are accumulated as follows; 674 | -- this matters when @f@ is not commutative or not associative. 675 | -- 676 | -- > fromListWith f [(k, a), (k, b), (k, c), (k, d)] 677 | -- > = fromList [(k, f d (f c (f b a)))] 678 | fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v 679 | fromListWith f = List.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) HM.empty 680 | {-# INLINE fromListWith #-} 681 | 682 | -- | \(O(n \log n)\) Construct a map from a list of elements. Uses 683 | -- the provided function to merge duplicate entries. 684 | -- 685 | -- === Examples 686 | -- 687 | -- Given a list of key-value pairs where the keys are of different flavours, e.g: 688 | -- 689 | -- > data Key = Div | Sub 690 | -- 691 | -- and the values need to be combined differently when there are duplicates, 692 | -- depending on the key: 693 | -- 694 | -- > combine Div = div 695 | -- > combine Sub = (-) 696 | -- 697 | -- then @fromListWithKey@ can be used as follows: 698 | -- 699 | -- > fromListWithKey combine [(Div, 2), (Div, 6), (Sub, 2), (Sub, 3)] 700 | -- > = fromList [(Div, 3), (Sub, 1)] 701 | -- 702 | -- More generally, duplicate entries are accumulated as follows; 703 | -- 704 | -- > fromListWith f [(k, a), (k, b), (k, c), (k, d)] 705 | -- > = fromList [(k, f k d (f k c (f k b a)))] 706 | -- 707 | -- @since 0.2.11 708 | fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v 709 | fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) HM.empty 710 | {-# INLINE fromListWithKey #-} 711 | 712 | ------------------------------------------------------------------------ 713 | -- Array operations 714 | 715 | updateWith :: Eq k => (v -> v) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v) 716 | updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0) 717 | where 718 | go !k !ary !i !n 719 | | i >= n = ary 720 | | otherwise = case A.index ary i of 721 | (L kx y) | k == kx -> let !v' = f y in A.update ary i (L k v') 722 | | otherwise -> go k ary (i+1) n 723 | {-# INLINABLE updateWith #-} 724 | 725 | -- | Append the given key and value to the array. If the key is 726 | -- already present, instead update the value of the key by applying 727 | -- the given function to the new and old value (in that order). The 728 | -- value is always evaluated to WHNF before being inserted into the 729 | -- array. 730 | updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v) 731 | -> A.Array (Leaf k v) 732 | updateOrSnocWith f = updateOrSnocWithKey (const f) 733 | {-# INLINABLE updateOrSnocWith #-} 734 | 735 | -- | Append the given key and value to the array. If the key is 736 | -- already present, instead update the value of the key by applying 737 | -- the given function to the new and old value (in that order). The 738 | -- value is always evaluated to WHNF before being inserted into the 739 | -- array. 740 | updateOrSnocWithKey :: Eq k => (k -> v -> v -> v) -> k -> v -> A.Array (Leaf k v) 741 | -> A.Array (Leaf k v) 742 | updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) 743 | where 744 | go !k v !ary !i !n 745 | -- Not found, append to the end. 746 | | i >= n = A.snoc ary $! L k $! v 747 | | otherwise = case A.index ary i of 748 | (L kx y) | k == kx -> let !v' = f k v y in A.update ary i (L k v') 749 | | otherwise -> go k v ary (i+1) n 750 | {-# INLINABLE updateOrSnocWithKey #-} 751 | 752 | ------------------------------------------------------------------------ 753 | -- Smart constructors 754 | -- 755 | -- These constructors make sure the value is in WHNF before it's 756 | -- inserted into the constructor. 757 | 758 | leaf :: Hash -> k -> v -> HashMap k v 759 | leaf h k = \ !v -> Leaf h (L k v) 760 | {-# INLINE leaf #-} 761 | -------------------------------------------------------------------------------- /Data/HashMap/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | 4 | ------------------------------------------------------------------------ 5 | -- | 6 | -- Module : Data.HashMap.Lazy 7 | -- Copyright : 2010-2012 Johan Tibell 8 | -- License : BSD-style 9 | -- Maintainer : johan.tibell@gmail.com 10 | -- Stability : provisional 11 | -- Portability : portable 12 | -- 13 | -- A map from /hashable/ keys to values. A map cannot contain 14 | -- duplicate keys; each key can map to at most one value. A 'HashMap' 15 | -- makes no guarantees as to the order of its elements. 16 | -- 17 | -- The implementation is based on /hash array mapped tries/. A 18 | -- 'HashMap' is often faster than other tree-based set types, 19 | -- especially when key comparison is expensive, as in the case of 20 | -- strings. 21 | -- 22 | -- Many operations have a average-case complexity of \(O(\log n)\). The 23 | -- implementation uses a large base (i.e. 32) so in practice these 24 | -- operations are constant time. 25 | module Data.HashMap.Lazy 26 | ( 27 | -- * Strictness properties 28 | -- $strictness 29 | 30 | HashMap 31 | 32 | -- * Construction 33 | , empty 34 | , singleton 35 | 36 | -- * Basic interface 37 | , null 38 | , size 39 | , member 40 | , lookup 41 | , (!?) 42 | , findWithDefault 43 | , lookupDefault 44 | , (!) 45 | , insert 46 | , insertWith 47 | , delete 48 | , adjust 49 | , update 50 | , alter 51 | , alterF 52 | , isSubmapOf 53 | , isSubmapOfBy 54 | 55 | -- * Combine 56 | -- ** Union 57 | , union 58 | , unionWith 59 | , unionWithKey 60 | , unions 61 | 62 | -- ** Compose 63 | , compose 64 | 65 | -- * Transformations 66 | , map 67 | , mapWithKey 68 | , traverseWithKey 69 | , mapKeys 70 | 71 | -- * Difference and intersection 72 | , difference 73 | , differenceWith 74 | , intersection 75 | , intersectionWith 76 | , intersectionWithKey 77 | 78 | -- * Folds 79 | , foldMapWithKey 80 | , foldr 81 | , foldl 82 | , foldr' 83 | , foldl' 84 | , foldrWithKey' 85 | , foldlWithKey' 86 | , foldrWithKey 87 | , foldlWithKey 88 | 89 | -- * Filter 90 | , filter 91 | , filterWithKey 92 | , mapMaybe 93 | , mapMaybeWithKey 94 | 95 | -- * Conversions 96 | , keys 97 | , elems 98 | 99 | -- ** Lists 100 | , toList 101 | , fromList 102 | , fromListWith 103 | , fromListWithKey 104 | 105 | -- ** HashSets 106 | , HS.keysSet 107 | ) where 108 | 109 | import Data.HashMap.Internal 110 | import Prelude () 111 | 112 | import qualified Data.HashSet.Internal as HS 113 | 114 | -- $strictness 115 | -- 116 | -- This module satisfies the following strictness property: 117 | -- 118 | -- * Key arguments are evaluated to WHNF. 119 | -------------------------------------------------------------------------------- /Data/HashMap/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | ------------------------------------------------------------------------ 4 | -- | 5 | -- Module : Data.HashMap.Strict 6 | -- Copyright : 2010-2012 Johan Tibell 7 | -- License : BSD-style 8 | -- Maintainer : johan.tibell@gmail.com 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- A map from /hashable/ keys to values. A map cannot contain 13 | -- duplicate keys; each key can map to at most one value. A 'HashMap' 14 | -- makes no guarantees as to the order of its elements. 15 | -- 16 | -- The implementation is based on /hash array mapped tries/. A 17 | -- 'HashMap' is often faster than other tree-based set types, 18 | -- especially when key comparison is expensive, as in the case of 19 | -- strings. 20 | -- 21 | -- Many operations have a average-case complexity of \(O(\log n)\). The 22 | -- implementation uses a large base (i.e. 16) so in practice these 23 | -- operations are constant time. 24 | module Data.HashMap.Strict 25 | ( 26 | -- * Strictness properties 27 | -- $strictness 28 | 29 | HashMap 30 | 31 | -- * Construction 32 | , empty 33 | , singleton 34 | 35 | -- * Basic interface 36 | , null 37 | , size 38 | , member 39 | , lookup 40 | , (!?) 41 | , findWithDefault 42 | , lookupDefault 43 | , (!) 44 | , insert 45 | , insertWith 46 | , delete 47 | , adjust 48 | , update 49 | , alter 50 | , alterF 51 | , isSubmapOf 52 | , isSubmapOfBy 53 | 54 | -- * Combine 55 | -- ** Union 56 | , union 57 | , unionWith 58 | , unionWithKey 59 | , unions 60 | 61 | -- ** Compose 62 | , compose 63 | 64 | -- * Transformations 65 | , map 66 | , mapWithKey 67 | , traverseWithKey 68 | , mapKeys 69 | 70 | -- * Difference and intersection 71 | , difference 72 | , differenceWith 73 | , intersection 74 | , intersectionWith 75 | , intersectionWithKey 76 | 77 | -- * Folds 78 | , foldMapWithKey 79 | , foldr 80 | , foldl 81 | , foldr' 82 | , foldl' 83 | , foldrWithKey' 84 | , foldlWithKey' 85 | , foldrWithKey 86 | , foldlWithKey 87 | 88 | -- * Filter 89 | , filter 90 | , filterWithKey 91 | , mapMaybe 92 | , mapMaybeWithKey 93 | 94 | -- * Conversions 95 | , keys 96 | , elems 97 | 98 | -- ** Lists 99 | , toList 100 | , fromList 101 | , fromListWith 102 | , fromListWithKey 103 | 104 | -- ** HashSets 105 | , HS.keysSet 106 | ) where 107 | 108 | import Data.HashMap.Internal.Strict 109 | import Prelude () 110 | 111 | import qualified Data.HashSet.Internal as HS 112 | 113 | -- $strictness 114 | -- 115 | -- This module satisfies the following strictness properties: 116 | -- 117 | -- 1. Key arguments are evaluated to WHNF; 118 | -- 119 | -- 2. Keys and values are evaluated to WHNF before they are stored in 120 | -- the map. 121 | -------------------------------------------------------------------------------- /Data/HashSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | ------------------------------------------------------------------------ 5 | {-| 6 | Module : Data.HashSet 7 | Copyright : 2011 Bryan O'Sullivan 8 | License : BSD-style 9 | Maintainer : johan.tibell@gmail.com 10 | Stability : provisional 11 | Portability : portable 12 | 13 | = Introduction 14 | 15 | 'HashSet' allows you to store /unique/ elements, providing efficient insertion, 16 | lookups, and deletion. A 'HashSet' makes no guarantees as to the order of its 17 | elements. 18 | 19 | If you are storing sets of "Data.Int"s consider using "Data.IntSet" from the 20 | package. 21 | 22 | 23 | == Examples 24 | 25 | All the examples below assume @HashSet@ is imported qualified, and uses the following @dataStructures@ set. 26 | 27 | >>> import qualified Data.HashSet as HashSet 28 | >>> let dataStructures = HashSet.fromList ["Set", "Map", "Graph", "Sequence"] 29 | 30 | === Basic Operations 31 | 32 | Check membership in a set: 33 | 34 | >>> -- Check if "Map" and "Trie" are in the set of data structures. 35 | >>> HashSet.member "Map" dataStructures 36 | True 37 | >>> HashSet.member "Trie" dataStructures 38 | False 39 | 40 | Add a new entry to the set: 41 | 42 | >>> let moreDataStructures = HashSet.insert "Trie" dataStructures 43 | >>> HashSet.member "Trie" moreDataStructures 44 | > True 45 | 46 | Remove the @\"Graph\"@ entry from the set of data structures. 47 | 48 | >>> let fewerDataStructures = HashSet.delete "Graph" dataStructures 49 | >>> HashSet.toList fewerDataStructures 50 | ["Map","Set","Sequence"] 51 | 52 | 53 | Create a new set and combine it with our original set. 54 | 55 | >>> let unorderedDataStructures = HashSet.fromList ["HashSet", "HashMap"] 56 | >>> HashSet.union dataStructures unorderedDataStructures 57 | fromList ["Map","HashSet","Graph","HashMap","Set","Sequence"] 58 | 59 | === Using custom data with HashSet 60 | 61 | To create a @HashSet@ of your custom type, the type must have instances for 62 | 'Data.Eq.Eq' and 'Data.Hashable.Hashable'. The @Hashable@ typeclass is defined in the 63 | package, see the 64 | documentation for information on how to make your type an instance of 65 | @Hashable@. 66 | 67 | We'll start by setting up our custom data type: 68 | 69 | >>> :set -XDeriveGeneric 70 | >>> import GHC.Generics (Generic) 71 | >>> import Data.Hashable 72 | >>> data Person = Person { name :: String, likesDogs :: Bool } deriving (Show, Eq, Generic) 73 | >>> instance Hashable Person 74 | 75 | And now we'll use it! 76 | 77 | >>> let people = HashSet.fromList [Person "Lana" True, Person "Joe" False, Person "Simon" True] 78 | >>> HashSet.filter likesDogs people 79 | fromList [Person {name = "Simon", likesDogs = True},Person {name = "Lana", likesDogs = True}] 80 | 81 | 82 | == Performance 83 | 84 | The implementation is based on /hash array mapped tries/. A 85 | 'HashSet' is often faster than other 'Data.Ord.Ord'-based set types, 86 | especially when value comparisons are expensive, as in the case of 87 | strings. 88 | 89 | Many operations have a average-case complexity of \(O(\log n)\). The 90 | implementation uses a large base (i.e. 16) so in practice these 91 | operations are constant time. 92 | -} 93 | 94 | module Data.HashSet 95 | ( 96 | HashSet 97 | 98 | -- * Construction 99 | , empty 100 | , singleton 101 | 102 | -- * Combine 103 | , union 104 | , unions 105 | 106 | -- * Basic interface 107 | , null 108 | , size 109 | , member 110 | , insert 111 | , delete 112 | , isSubsetOf 113 | 114 | -- * Transformations 115 | , map 116 | 117 | -- * Difference and intersection 118 | , difference 119 | , intersection 120 | 121 | -- * Folds 122 | , foldl' 123 | , foldr 124 | 125 | -- * Filter 126 | , filter 127 | 128 | -- * Conversions 129 | 130 | -- ** Lists 131 | , toList 132 | , fromList 133 | 134 | -- * HashMaps 135 | , toMap 136 | , fromMap 137 | ) where 138 | 139 | import Data.HashSet.Internal 140 | import Prelude () 141 | -------------------------------------------------------------------------------- /Data/HashSet/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE RoleAnnotations #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE Trustworthy #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# OPTIONS_HADDOCK not-home #-} 8 | 9 | ------------------------------------------------------------------------ 10 | -- | 11 | -- Module : Data.HashSet.Internal 12 | -- Copyright : 2011 Bryan O'Sullivan 13 | -- License : BSD-style 14 | -- Maintainer : johan.tibell@gmail.com 15 | -- Portability : portable 16 | -- 17 | -- = WARNING 18 | -- 19 | -- This module is considered __internal__. 20 | -- 21 | -- The Package Versioning Policy __does not apply__. 22 | -- 23 | -- The contents of this module may change __in any way whatsoever__ 24 | -- and __without any warning__ between minor versions of this package. 25 | -- 26 | -- Authors importing this module are expected to track development 27 | -- closely. 28 | -- 29 | -- = Description 30 | -- 31 | -- A set of /hashable/ values. A set cannot contain duplicate items. 32 | -- A 'HashSet' makes no guarantees as to the order of its elements. 33 | -- 34 | -- The implementation is based on /hash array mapped tries/. A 35 | -- 'HashSet' is often faster than other tree-based set types, 36 | -- especially when value comparison is expensive, as in the case of 37 | -- strings. 38 | -- 39 | -- Many operations have a average-case complexity of \(O(\log n)\). The 40 | -- implementation uses a large base (i.e. 32) so in practice these 41 | -- operations are constant time. 42 | 43 | module Data.HashSet.Internal 44 | ( 45 | HashSet(..) 46 | 47 | -- * Construction 48 | , empty 49 | , singleton 50 | 51 | -- * Basic interface 52 | , null 53 | , size 54 | , member 55 | , insert 56 | , delete 57 | , isSubsetOf 58 | 59 | -- * Transformations 60 | , map 61 | 62 | -- * Combine 63 | , union 64 | , unions 65 | 66 | -- * Difference and intersection 67 | , difference 68 | , intersection 69 | 70 | -- * Folds 71 | , foldr 72 | , foldr' 73 | , foldl 74 | , foldl' 75 | 76 | -- * Filter 77 | , filter 78 | 79 | -- * Conversions 80 | 81 | -- ** Lists 82 | , toList 83 | , fromList 84 | 85 | -- * HashMaps 86 | , toMap 87 | , fromMap 88 | 89 | -- Exported from Data.HashMap.{Strict, Lazy} 90 | , keysSet 91 | ) where 92 | 93 | import Control.DeepSeq (NFData (..), NFData1 (..), liftRnf2) 94 | import Data.Data (Constr, Data (..), DataType) 95 | import Data.Functor.Classes 96 | import Data.Hashable (Hashable (hashWithSalt)) 97 | import Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..)) 98 | import Data.HashMap.Internal (HashMap, equalKeys, equalKeys1, foldMapWithKey, 99 | foldlWithKey, foldrWithKey) 100 | import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid) 101 | import Prelude hiding (Foldable(..), filter, map) 102 | import Text.Read 103 | 104 | import qualified Data.Data as Data 105 | import qualified Data.Foldable as Foldable 106 | import qualified Data.HashMap.Internal as H 107 | import qualified Data.List as List 108 | import qualified GHC.Exts as Exts 109 | import qualified Language.Haskell.TH.Syntax as TH 110 | 111 | -- | A set of values. A set cannot contain duplicate values. 112 | newtype HashSet a = HashSet { 113 | asMap :: HashMap a () 114 | } 115 | 116 | type role HashSet nominal 117 | 118 | -- | @since 0.2.17.0 119 | deriving instance TH.Lift a => TH.Lift (HashSet a) 120 | 121 | instance (NFData a) => NFData (HashSet a) where 122 | rnf = rnf . asMap 123 | {-# INLINE rnf #-} 124 | 125 | -- | @since 0.2.14.0 126 | instance NFData1 HashSet where 127 | liftRnf rnf1 = liftRnf2 rnf1 rnf . asMap 128 | 129 | -- | Note that, in the presence of hash collisions, equal @HashSet@s may 130 | -- behave differently, i.e. extensionality may be violated: 131 | -- 132 | -- >>> data D = A | B deriving (Eq, Show) 133 | -- >>> instance Hashable D where hashWithSalt salt _d = salt 134 | -- 135 | -- >>> x = fromList [A, B] 136 | -- >>> y = fromList [B, A] 137 | -- 138 | -- >>> x == y 139 | -- True 140 | -- >>> toList x 141 | -- [A,B] 142 | -- >>> toList y 143 | -- [B,A] 144 | -- 145 | -- In general, the lack of extensionality can be observed with any function 146 | -- that depends on the key ordering, such as folds and traversals. 147 | instance (Eq a) => Eq (HashSet a) where 148 | HashSet a == HashSet b = equalKeys a b 149 | {-# INLINE (==) #-} 150 | 151 | instance Eq1 HashSet where 152 | liftEq eq (HashSet a) (HashSet b) = equalKeys1 eq a b 153 | 154 | instance (Ord a) => Ord (HashSet a) where 155 | compare (HashSet a) (HashSet b) = compare a b 156 | {-# INLINE compare #-} 157 | 158 | instance Ord1 HashSet where 159 | liftCompare c (HashSet a) (HashSet b) = liftCompare2 c compare a b 160 | 161 | instance Foldable.Foldable HashSet where 162 | foldMap f = foldMapWithKey (\a _ -> f a) . asMap 163 | foldr = foldr 164 | {-# INLINE foldr #-} 165 | foldl = foldl 166 | {-# INLINE foldl #-} 167 | foldl' = foldl' 168 | {-# INLINE foldl' #-} 169 | foldr' = foldr' 170 | {-# INLINE foldr' #-} 171 | toList = toList 172 | {-# INLINE toList #-} 173 | null = null 174 | {-# INLINE null #-} 175 | length = size 176 | {-# INLINE length #-} 177 | 178 | -- | '<>' = 'union' 179 | -- 180 | -- \(O(n+m)\) 181 | -- 182 | -- To obtain good performance, the smaller set must be presented as 183 | -- the first argument. 184 | -- 185 | -- ==== __Examples__ 186 | -- 187 | -- >>> fromList [1,2] <> fromList [2,3] 188 | -- fromList [1,2,3] 189 | instance (Hashable a, Eq a) => Semigroup (HashSet a) where 190 | (<>) = union 191 | {-# INLINE (<>) #-} 192 | stimes = stimesIdempotentMonoid 193 | {-# INLINE stimes #-} 194 | 195 | -- | 'mempty' = 'empty' 196 | -- 197 | -- 'mappend' = 'union' 198 | -- 199 | -- \(O(n+m)\) 200 | -- 201 | -- To obtain good performance, the smaller set must be presented as 202 | -- the first argument. 203 | -- 204 | -- ==== __Examples__ 205 | -- 206 | -- >>> mappend (fromList [1,2]) (fromList [2,3]) 207 | -- fromList [1,2,3] 208 | instance (Hashable a, Eq a) => Monoid (HashSet a) where 209 | mempty = empty 210 | {-# INLINE mempty #-} 211 | mappend = (<>) 212 | {-# INLINE mappend #-} 213 | 214 | instance (Eq a, Hashable a, Read a) => Read (HashSet a) where 215 | readPrec = parens $ prec 10 $ do 216 | Ident "fromList" <- lexP 217 | fromList <$> readPrec 218 | 219 | readListPrec = readListPrecDefault 220 | 221 | instance Show1 HashSet where 222 | liftShowsPrec sp sl d m = 223 | showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) 224 | 225 | instance (Show a) => Show (HashSet a) where 226 | showsPrec d m = showParen (d > 10) $ 227 | showString "fromList " . shows (toList m) 228 | 229 | instance (Data a, Eq a, Hashable a) => Data (HashSet a) where 230 | gfoldl f z m = z fromList `f` toList m 231 | toConstr _ = fromListConstr 232 | gunfold k z c = case Data.constrIndex c of 233 | 1 -> k (z fromList) 234 | _ -> error "gunfold" 235 | dataTypeOf _ = hashSetDataType 236 | dataCast1 f = Data.gcast1 f 237 | 238 | instance Hashable1 HashSet where 239 | liftHashWithSalt h s = liftHashWithSalt2 h hashWithSalt s . asMap 240 | 241 | instance (Hashable a) => Hashable (HashSet a) where 242 | hashWithSalt salt = hashWithSalt salt . asMap 243 | 244 | fromListConstr :: Constr 245 | fromListConstr = Data.mkConstr hashSetDataType "fromList" [] Data.Prefix 246 | 247 | hashSetDataType :: DataType 248 | hashSetDataType = Data.mkDataType "Data.HashSet.Internal.HashSet" [fromListConstr] 249 | 250 | -- | \(O(1)\) Construct an empty set. 251 | -- 252 | -- >>> HashSet.empty 253 | -- fromList [] 254 | empty :: HashSet a 255 | empty = HashSet H.empty 256 | 257 | -- | \(O(1)\) Construct a set with a single element. 258 | -- 259 | -- >>> HashSet.singleton 1 260 | -- fromList [1] 261 | singleton :: Hashable a => a -> HashSet a 262 | singleton a = HashSet (H.singleton a ()) 263 | {-# INLINABLE singleton #-} 264 | 265 | -- | \(O(1)\) Convert to set to the equivalent 'HashMap' with @()@ values. 266 | -- 267 | -- >>> HashSet.toMap (HashSet.singleton 1) 268 | -- fromList [(1,())] 269 | toMap :: HashSet a -> HashMap a () 270 | toMap = asMap 271 | 272 | -- | \(O(1)\) Convert from the equivalent 'HashMap' with @()@ values. 273 | -- 274 | -- >>> HashSet.fromMap (HashMap.singleton 1 ()) 275 | -- fromList [1] 276 | fromMap :: HashMap a () -> HashSet a 277 | fromMap = HashSet 278 | 279 | -- | \(O(n)\) Produce a 'HashSet' of all the keys in the given 'HashMap'. 280 | -- 281 | -- >>> HashSet.keysSet (HashMap.fromList [(1, "a"), (2, "b")] 282 | -- fromList [1,2] 283 | -- 284 | -- @since 0.2.10.0 285 | keysSet :: HashMap k a -> HashSet k 286 | keysSet m = fromMap (() <$ m) 287 | 288 | -- | \(O(n \log m)\) Inclusion of sets. 289 | -- 290 | -- ==== __Examples__ 291 | -- 292 | -- >>> fromList [1,3] `isSubsetOf` fromList [1,2,3] 293 | -- True 294 | -- 295 | -- >>> fromList [1,2] `isSubsetOf` fromList [1,3] 296 | -- False 297 | -- 298 | -- @since 0.2.12 299 | isSubsetOf :: (Eq a, Hashable a) => HashSet a -> HashSet a -> Bool 300 | isSubsetOf s1 s2 = H.isSubmapOfBy (\_ _ -> True) (asMap s1) (asMap s2) 301 | 302 | -- | \(O(n+m)\) Construct a set containing all elements from both sets. 303 | -- 304 | -- To obtain good performance, the smaller set must be presented as 305 | -- the first argument. 306 | -- 307 | -- >>> union (fromList [1,2]) (fromList [2,3]) 308 | -- fromList [1,2,3] 309 | union :: Eq a => HashSet a -> HashSet a -> HashSet a 310 | union s1 s2 = HashSet $ H.union (asMap s1) (asMap s2) 311 | {-# INLINE union #-} 312 | 313 | -- TODO: Figure out the time complexity of 'unions'. 314 | 315 | -- | Construct a set containing all elements from a list of sets. 316 | unions :: Eq a => [HashSet a] -> HashSet a 317 | unions = List.foldl' union empty 318 | {-# INLINE unions #-} 319 | 320 | -- | \(O(1)\) Return 'True' if this set is empty, 'False' otherwise. 321 | -- 322 | -- >>> HashSet.null HashSet.empty 323 | -- True 324 | -- >>> HashSet.null (HashSet.singleton 1) 325 | -- False 326 | null :: HashSet a -> Bool 327 | null = H.null . asMap 328 | {-# INLINE null #-} 329 | 330 | -- | \(O(n)\) Return the number of elements in this set. 331 | -- 332 | -- >>> HashSet.size HashSet.empty 333 | -- 0 334 | -- >>> HashSet.size (HashSet.fromList [1,2,3]) 335 | -- 3 336 | size :: HashSet a -> Int 337 | size = H.size . asMap 338 | {-# INLINE size #-} 339 | 340 | -- | \(O(\log n)\) Return 'True' if the given value is present in this 341 | -- set, 'False' otherwise. 342 | -- 343 | -- >>> HashSet.member 1 (Hashset.fromList [1,2,3]) 344 | -- True 345 | -- >>> HashSet.member 1 (Hashset.fromList [4,5,6]) 346 | -- False 347 | member :: (Eq a, Hashable a) => a -> HashSet a -> Bool 348 | member a s = case H.lookup a (asMap s) of 349 | Just _ -> True 350 | _ -> False 351 | {-# INLINABLE member #-} 352 | 353 | -- | \(O(\log n)\) Add the specified value to this set. 354 | -- 355 | -- >>> HashSet.insert 1 HashSet.empty 356 | -- fromList [1] 357 | insert :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a 358 | insert a = HashSet . H.insert a () . asMap 359 | {-# INLINABLE insert #-} 360 | 361 | -- | \(O(\log n)\) Remove the specified value from this set if present. 362 | -- 363 | -- >>> HashSet.delete 1 (HashSet.fromList [1,2,3]) 364 | -- fromList [2,3] 365 | -- >>> HashSet.delete 1 (HashSet.fromList [4,5,6]) 366 | -- fromList [4,5,6] 367 | delete :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a 368 | delete a = HashSet . H.delete a . asMap 369 | {-# INLINABLE delete #-} 370 | 371 | -- | \(O(n)\) Transform this set by applying a function to every value. 372 | -- The resulting set may be smaller than the source. 373 | -- 374 | -- >>> HashSet.map show (HashSet.fromList [1,2,3]) 375 | -- HashSet.fromList ["1","2","3"] 376 | map :: (Hashable b, Eq b) => (a -> b) -> HashSet a -> HashSet b 377 | map f = fromList . List.map f . toList 378 | {-# INLINE map #-} 379 | 380 | -- | \(O(n)\) Difference of two sets. Return elements of the first set 381 | -- not existing in the second. 382 | -- 383 | -- >>> HashSet.difference (HashSet.fromList [1,2,3]) (HashSet.fromList [2,3,4]) 384 | -- fromList [1] 385 | difference :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a 386 | difference (HashSet a) (HashSet b) = HashSet (H.difference a b) 387 | {-# INLINABLE difference #-} 388 | 389 | -- | \(O(n)\) Intersection of two sets. Return elements present in both 390 | -- the first set and the second. 391 | -- 392 | -- >>> HashSet.intersection (HashSet.fromList [1,2,3]) (HashSet.fromList [2,3,4]) 393 | -- fromList [2,3] 394 | intersection :: Eq a => HashSet a -> HashSet a -> HashSet a 395 | intersection (HashSet a) (HashSet b) = HashSet (H.intersection a b) 396 | {-# INLINABLE intersection #-} 397 | 398 | -- | \(O(n)\) Reduce this set by applying a binary operator to all 399 | -- elements, using the given starting value (typically the 400 | -- left-identity of the operator). Each application of the operator 401 | -- is evaluated before before using the result in the next 402 | -- application. This function is strict in the starting value. 403 | foldl' :: (a -> b -> a) -> a -> HashSet b -> a 404 | foldl' f z0 = H.foldlWithKey' g z0 . asMap 405 | where g z k _ = f z k 406 | {-# INLINE foldl' #-} 407 | 408 | -- | \(O(n)\) Reduce this set by applying a binary operator to all 409 | -- elements, using the given starting value (typically the 410 | -- right-identity of the operator). Each application of the operator 411 | -- is evaluated before before using the result in the next 412 | -- application. This function is strict in the starting value. 413 | foldr' :: (b -> a -> a) -> a -> HashSet b -> a 414 | foldr' f z0 = H.foldrWithKey' g z0 . asMap 415 | where g k _ z = f k z 416 | {-# INLINE foldr' #-} 417 | 418 | -- | \(O(n)\) Reduce this set by applying a binary operator to all 419 | -- elements, using the given starting value (typically the 420 | -- right-identity of the operator). 421 | foldr :: (b -> a -> a) -> a -> HashSet b -> a 422 | foldr f z0 = foldrWithKey g z0 . asMap 423 | where g k _ z = f k z 424 | {-# INLINE foldr #-} 425 | 426 | -- | \(O(n)\) Reduce this set by applying a binary operator to all 427 | -- elements, using the given starting value (typically the 428 | -- left-identity of the operator). 429 | foldl :: (a -> b -> a) -> a -> HashSet b -> a 430 | foldl f z0 = foldlWithKey g z0 . asMap 431 | where g z k _ = f z k 432 | {-# INLINE foldl #-} 433 | 434 | -- | \(O(n)\) Filter this set by retaining only elements satisfying a 435 | -- predicate. 436 | filter :: (a -> Bool) -> HashSet a -> HashSet a 437 | filter p = HashSet . H.filterWithKey q . asMap 438 | where q k _ = p k 439 | {-# INLINE filter #-} 440 | 441 | -- | \(O(n)\) Return a list of this set's elements. The list is 442 | -- produced lazily. 443 | toList :: HashSet a -> [a] 444 | toList t = Exts.build (\ c z -> foldrWithKey (const . c) z (asMap t)) 445 | {-# INLINE toList #-} 446 | 447 | -- | \(O(n \min(W, n))\) Construct a set from a list of elements. 448 | fromList :: (Eq a, Hashable a) => [a] -> HashSet a 449 | fromList = HashSet . List.foldl' (\ m k -> H.insert k () m) H.empty 450 | {-# INLINE fromList #-} 451 | 452 | instance (Eq a, Hashable a) => Exts.IsList (HashSet a) where 453 | type Item (HashSet a) = a 454 | fromList = fromList 455 | toList = toList 456 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, Johan Tibell 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Johan Tibell nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## unordered-containers 2 | 3 | Efficient hashing-based container types. The containers have been optimized for 4 | performance critical use, both in terms of large data quantities and high speed. 5 | 6 | The declared cost of each operation is either worst-case or amortized, but 7 | remains valid even if structures are shared. 8 | 9 | For background information and design considerations on this package see the 10 | [Developer Guide](docs/developer-guide.md). 11 | 12 | For practical advice for contributors see [`CONTRIBUTING.md`](CONTRIBUTING.md). 13 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmarks/Benchmarks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE PackageImports #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | 8 | module Main where 9 | 10 | import Control.DeepSeq (NFData (..)) 11 | import Data.Bits ((.&.)) 12 | import Data.Functor.Identity (Identity (..)) 13 | import Data.Hashable (Hashable, hash) 14 | import Data.List (foldl') 15 | import Data.Maybe (fromMaybe) 16 | import GHC.Generics (Generic) 17 | import Prelude hiding (lookup) 18 | import Test.Tasty.Bench (bench, bgroup, defaultMain, env, nf, whnf) 19 | 20 | import qualified Data.ByteString as BS 21 | import qualified "hashmap" Data.HashMap as IHM 22 | import qualified Data.HashMap.Strict as HM 23 | import qualified Data.IntMap as IM 24 | import qualified Data.Map as M 25 | import qualified Util.ByteString as UBS 26 | import qualified Util.Int as UI 27 | import qualified Util.String as US 28 | 29 | data B where 30 | B :: NFData a => a -> B 31 | 32 | instance NFData B where 33 | rnf (B b) = rnf b 34 | 35 | -- TODO: This a stopgap measure to keep the benchmark work with 36 | -- Criterion 1.0. 37 | data Env = Env { 38 | n :: !Int, 39 | 40 | elems :: ![(String, Int)], 41 | keys :: ![String], 42 | elemsBS :: ![(BS.ByteString, Int)], 43 | keysBS :: ![BS.ByteString], 44 | elemsI :: ![(Int, Int)], 45 | keysI :: ![Int], 46 | elemsI2 :: ![(Int, Int)], -- for union 47 | 48 | keys' :: ![String], 49 | keysBS' :: ![BS.ByteString], 50 | keysI' :: ![Int], 51 | 52 | keysDup :: ![String], 53 | keysDupBS :: ![BS.ByteString], 54 | keysDupI :: ![Int], 55 | elemsDup :: ![(String, Int)], 56 | elemsDupBS :: ![(BS.ByteString, Int)], 57 | elemsDupI :: ![(Int, Int)], 58 | 59 | hm :: !(HM.HashMap String Int), 60 | hmSubset :: !(HM.HashMap String Int), 61 | hmbs :: !(HM.HashMap BS.ByteString Int), 62 | hmbsSubset :: !(HM.HashMap BS.ByteString Int), 63 | hmi :: !(HM.HashMap Int Int), 64 | hmiSubset :: !(HM.HashMap Int Int), 65 | hmi2 :: !(HM.HashMap Int Int), 66 | m :: !(M.Map String Int), 67 | mSubset :: !(M.Map String Int), 68 | mbs :: !(M.Map BS.ByteString Int), 69 | mbsSubset :: !(M.Map BS.ByteString Int), 70 | im :: !(IM.IntMap Int), 71 | imSubset :: !(IM.IntMap Int), 72 | ihm :: !(IHM.Map String Int), 73 | ihmSubset :: !(IHM.Map String Int), 74 | ihmbs :: !(IHM.Map BS.ByteString Int), 75 | ihmbsSubset :: !(IHM.Map BS.ByteString Int) 76 | } deriving (Generic, NFData) 77 | 78 | setupEnv :: IO Env 79 | setupEnv = do 80 | let n = 2^(12 :: Int) 81 | 82 | elems = zip keys [1..n] 83 | keys = US.rnd 8 n 84 | elemsBS = zip keysBS [1..n] 85 | keysBS = UBS.rnd 8 n 86 | elemsI = zip keysI [1..n] 87 | keysI = UI.rnd (n+n) n 88 | elemsI2 = zip [n `div` 2..n + (n `div` 2)] [1..n] -- for union 89 | 90 | keys' = US.rnd' 8 n 91 | keysBS' = UBS.rnd' 8 n 92 | keysI' = UI.rnd' (n+n) n 93 | 94 | keysDup = US.rnd 2 n 95 | keysDupBS = UBS.rnd 2 n 96 | keysDupI = UI.rnd (n`div`4) n 97 | elemsDup = zip keysDup [1..n] 98 | elemsDupBS = zip keysDupBS [1..n] 99 | elemsDupI = zip keysDupI [1..n] 100 | 101 | hm = HM.fromList elems 102 | hmSubset = HM.fromList (takeSubset n elems) 103 | hmbs = HM.fromList elemsBS 104 | hmbsSubset = HM.fromList (takeSubset n elemsBS) 105 | hmi = HM.fromList elemsI 106 | hmiSubset = HM.fromList (takeSubset n elemsI) 107 | hmi2 = HM.fromList elemsI2 108 | m = M.fromList elems 109 | mSubset = M.fromList (takeSubset n elems) 110 | mbs = M.fromList elemsBS 111 | mbsSubset = M.fromList (takeSubset n elemsBS) 112 | im = IM.fromList elemsI 113 | imSubset = IM.fromList (takeSubset n elemsI) 114 | ihm = IHM.fromList elems 115 | ihmSubset = IHM.fromList (takeSubset n elems) 116 | ihmbs = IHM.fromList elemsBS 117 | ihmbsSubset = IHM.fromList (takeSubset n elemsBS) 118 | return Env{..} 119 | where 120 | takeSubset n elements = 121 | -- use 50% of the elements for a subset check. 122 | let subsetSize = round (fromIntegral n * 0.5 :: Double) :: Int 123 | in take subsetSize elements 124 | 125 | main :: IO () 126 | main = do 127 | defaultMain 128 | [ 129 | #ifdef BENCH_containers_Map 130 | env setupEnv $ \ ~(Env{..}) -> 131 | -- * Comparison to other data structures 132 | -- ** Map 133 | bgroup "Map" 134 | [ bgroup "lookup" 135 | [ bench "String" $ whnf (lookupM keys) m 136 | , bench "ByteString" $ whnf (lookupM keysBS) mbs 137 | ] 138 | , bgroup "lookup-miss" 139 | [ bench "String" $ whnf (lookupM keys') m 140 | , bench "ByteString" $ whnf (lookupM keysBS') mbs 141 | ] 142 | , bgroup "insert" 143 | [ bench "String" $ whnf (insertM elems) M.empty 144 | , bench "ByteStringString" $ whnf (insertM elemsBS) M.empty 145 | ] 146 | , bgroup "insert-dup" 147 | [ bench "String" $ whnf (insertM elems) m 148 | , bench "ByteStringString" $ whnf (insertM elemsBS) mbs 149 | ] 150 | , bgroup "delete" 151 | [ bench "String" $ whnf (deleteM keys) m 152 | , bench "ByteString" $ whnf (deleteM keysBS) mbs 153 | ] 154 | , bgroup "delete-miss" 155 | [ bench "String" $ whnf (deleteM keys') m 156 | , bench "ByteString" $ whnf (deleteM keysBS') mbs 157 | ] 158 | , bgroup "size" 159 | [ bench "String" $ whnf M.size m 160 | , bench "ByteString" $ whnf M.size mbs 161 | ] 162 | , bgroup "fromList" 163 | [ bench "String" $ whnf M.fromList elems 164 | , bench "ByteString" $ whnf M.fromList elemsBS 165 | ] 166 | , bgroup "isSubmapOf" 167 | [ bench "String" $ whnf (M.isSubmapOf mSubset) m 168 | , bench "ByteString" $ whnf (M.isSubmapOf mbsSubset) mbs 169 | ] 170 | ], 171 | #endif 172 | 173 | #ifdef BENCH_hashmap_Map 174 | -- ** Map from the hashmap package 175 | env setupEnv $ \ ~(Env{..}) -> 176 | bgroup "hashmap/Map" 177 | [ bgroup "lookup" 178 | [ bench "String" $ whnf (lookupIHM keys) ihm 179 | , bench "ByteString" $ whnf (lookupIHM keysBS) ihmbs 180 | ] 181 | , bgroup "lookup-miss" 182 | [ bench "String" $ whnf (lookupIHM keys') ihm 183 | , bench "ByteString" $ whnf (lookupIHM keysBS') ihmbs 184 | ] 185 | , bgroup "insert" 186 | [ bench "String" $ whnf (insertIHM elems) IHM.empty 187 | , bench "ByteStringString" $ whnf (insertIHM elemsBS) IHM.empty 188 | ] 189 | , bgroup "insert-dup" 190 | [ bench "String" $ whnf (insertIHM elems) ihm 191 | , bench "ByteStringString" $ whnf (insertIHM elemsBS) ihmbs 192 | ] 193 | , bgroup "delete" 194 | [ bench "String" $ whnf (deleteIHM keys) ihm 195 | , bench "ByteString" $ whnf (deleteIHM keysBS) ihmbs 196 | ] 197 | , bgroup "delete-miss" 198 | [ bench "String" $ whnf (deleteIHM keys') ihm 199 | , bench "ByteString" $ whnf (deleteIHM keysBS') ihmbs 200 | ] 201 | , bgroup "size" 202 | [ bench "String" $ whnf IHM.size ihm 203 | , bench "ByteString" $ whnf IHM.size ihmbs 204 | ] 205 | , bgroup "fromList" 206 | [ bench "String" $ whnf IHM.fromList elems 207 | , bench "ByteString" $ whnf IHM.fromList elemsBS 208 | ] 209 | , bgroup "isSubmapOf" 210 | [ bench "String" $ whnf (IHM.isSubmapOf ihmSubset) ihm 211 | , bench "ByteString" $ whnf (IHM.isSubmapOf ihmbsSubset) ihmbs 212 | ] 213 | ], 214 | #endif 215 | 216 | #ifdef BENCH_containers_IntMap 217 | -- ** IntMap 218 | env setupEnv $ \ ~(Env{..}) -> 219 | bgroup "IntMap" 220 | [ bench "lookup" $ whnf (lookupIM keysI) im 221 | , bench "lookup-miss" $ whnf (lookupIM keysI') im 222 | , bench "insert" $ whnf (insertIM elemsI) IM.empty 223 | , bench "insert-dup" $ whnf (insertIM elemsI) im 224 | , bench "delete" $ whnf (deleteIM keysI) im 225 | , bench "delete-miss" $ whnf (deleteIM keysI') im 226 | , bench "size" $ whnf IM.size im 227 | , bench "fromList" $ whnf IM.fromList elemsI 228 | , bench "isSubmapOf" $ whnf (IM.isSubmapOf imSubset) im 229 | ], 230 | #endif 231 | 232 | env setupEnv $ \ ~(Env{..}) -> 233 | bgroup "HashMap" 234 | [ -- * Basic interface 235 | bgroup "lookup" 236 | [ bench "String" $ whnf (lookup keys) hm 237 | , bench "ByteString" $ whnf (lookup keysBS) hmbs 238 | , bench "Int" $ whnf (lookup keysI) hmi 239 | ] 240 | , bgroup "lookup-miss" 241 | [ bench "String" $ whnf (lookup keys') hm 242 | , bench "ByteString" $ whnf (lookup keysBS') hmbs 243 | , bench "Int" $ whnf (lookup keysI') hmi 244 | ] 245 | , bgroup "insert" 246 | [ bench "String" $ whnf (insert elems) HM.empty 247 | , bench "ByteString" $ whnf (insert elemsBS) HM.empty 248 | , bench "Int" $ whnf (insert elemsI) HM.empty 249 | ] 250 | , bgroup "insert-dup" 251 | [ bench "String" $ whnf (insert elems) hm 252 | , bench "ByteString" $ whnf (insert elemsBS) hmbs 253 | , bench "Int" $ whnf (insert elemsI) hmi 254 | ] 255 | , bgroup "delete" 256 | [ bench "String" $ whnf (delete keys) hm 257 | , bench "ByteString" $ whnf (delete keysBS) hmbs 258 | , bench "Int" $ whnf (delete keysI) hmi 259 | ] 260 | , bgroup "delete-miss" 261 | [ bench "String" $ whnf (delete keys') hm 262 | , bench "ByteString" $ whnf (delete keysBS') hmbs 263 | , bench "Int" $ whnf (delete keysI') hmi 264 | ] 265 | , bgroup "alterInsert" 266 | [ bench "String" $ whnf (alterInsert elems) HM.empty 267 | , bench "ByteString" $ whnf (alterInsert elemsBS) HM.empty 268 | , bench "Int" $ whnf (alterInsert elemsI) HM.empty 269 | ] 270 | , bgroup "alterFInsert" 271 | [ bench "String" $ whnf (alterFInsert elems) HM.empty 272 | , bench "ByteString" $ whnf (alterFInsert elemsBS) HM.empty 273 | , bench "Int" $ whnf (alterFInsert elemsI) HM.empty 274 | ] 275 | , bgroup "alterInsert-dup" 276 | [ bench "String" $ whnf (alterInsert elems) hm 277 | , bench "ByteString" $ whnf (alterInsert elemsBS) hmbs 278 | , bench "Int" $ whnf (alterInsert elemsI) hmi 279 | ] 280 | , bgroup "alterFInsert-dup" 281 | [ bench "String" $ whnf (alterFInsert elems) hm 282 | , bench "ByteString" $ whnf (alterFInsert elemsBS) hmbs 283 | , bench "Int" $ whnf (alterFInsert elemsI) hmi 284 | ] 285 | , bgroup "alterDelete" 286 | [ bench "String" $ whnf (alterDelete keys) hm 287 | , bench "ByteString" $ whnf (alterDelete keysBS) hmbs 288 | , bench "Int" $ whnf (alterDelete keysI) hmi 289 | ] 290 | , bgroup "alterFDelete" 291 | [ bench "String" $ whnf (alterFDelete keys) hm 292 | , bench "ByteString" $ whnf (alterFDelete keysBS) hmbs 293 | , bench "Int" $ whnf (alterFDelete keysI) hmi 294 | ] 295 | , bgroup "alterDelete-miss" 296 | [ bench "String" $ whnf (alterDelete keys') hm 297 | , bench "ByteString" $ whnf (alterDelete keysBS') hmbs 298 | , bench "Int" $ whnf (alterDelete keysI') hmi 299 | ] 300 | , bgroup "alterFDelete-miss" 301 | [ bench "String" $ whnf (alterFDelete keys') hm 302 | , bench "ByteString" $ whnf (alterFDelete keysBS') hmbs 303 | , bench "Int" $ whnf (alterFDelete keysI') hmi 304 | ] 305 | , bgroup "isSubmapOf" 306 | [ bench "String" $ whnf (HM.isSubmapOf hmSubset) hm 307 | , bench "ByteString" $ whnf (HM.isSubmapOf hmbsSubset) hmbs 308 | , bench "Int" $ whnf (HM.isSubmapOf hmiSubset) hmi 309 | ] 310 | , bgroup "isSubmapOfNaive" 311 | [ bench "String" $ whnf (isSubmapOfNaive hmSubset) hm 312 | , bench "ByteString" $ whnf (isSubmapOfNaive hmbsSubset) hmbs 313 | , bench "Int" $ whnf (isSubmapOfNaive hmiSubset) hmi 314 | ] 315 | 316 | -- Combine 317 | , bgroup "union" 318 | [ bench "Int" $ whnf (HM.union hmi) hmi2 319 | , bench "ByteString" $ whnf (HM.union hmbs) hmbsSubset 320 | ] 321 | 322 | , bgroup "intersection" 323 | [ bench "Int" $ whnf (HM.intersection hmi) hmi2 324 | , bench "ByteString" $ whnf (HM.intersection hmbs) hmbsSubset 325 | ] 326 | 327 | -- Transformations 328 | , bench "map" $ whnf (HM.map (\ v -> v + 1)) hmi 329 | 330 | -- * Difference and intersection 331 | , bench "difference" $ whnf (HM.difference hmi) hmi2 332 | 333 | -- Folds 334 | , bench "foldl'" $ whnf (HM.foldl' (+) 0) hmi 335 | , bench "foldr" $ nf (HM.foldr (:) []) hmi 336 | 337 | -- Filter 338 | , bench "filter" $ whnf (HM.filter (\ v -> v .&. 1 == 0)) hmi 339 | , bench "filterWithKey" $ whnf (HM.filterWithKey (\ k _ -> k .&. 1 == 0)) hmi 340 | 341 | -- Size 342 | , bgroup "size" 343 | [ bench "String" $ whnf HM.size hm 344 | , bench "ByteString" $ whnf HM.size hmbs 345 | , bench "Int" $ whnf HM.size hmi 346 | ] 347 | 348 | -- fromList 349 | , bgroup "fromList" 350 | [ bgroup "long" 351 | [ bench "String" $ whnf HM.fromList elems 352 | , bench "ByteString" $ whnf HM.fromList elemsBS 353 | , bench "Int" $ whnf HM.fromList elemsI 354 | ] 355 | , bgroup "short" 356 | [ bench "String" $ whnf HM.fromList elemsDup 357 | , bench "ByteString" $ whnf HM.fromList elemsDupBS 358 | , bench "Int" $ whnf HM.fromList elemsDupI 359 | ] 360 | ] 361 | -- fromListWith 362 | , bgroup "fromListWith" 363 | [ bgroup "long" 364 | [ bench "String" $ whnf (HM.fromListWith (+)) elems 365 | , bench "ByteString" $ whnf (HM.fromListWith (+)) elemsBS 366 | , bench "Int" $ whnf (HM.fromListWith (+)) elemsI 367 | ] 368 | , bgroup "short" 369 | [ bench "String" $ whnf (HM.fromListWith (+)) elemsDup 370 | , bench "ByteString" $ whnf (HM.fromListWith (+)) elemsDupBS 371 | , bench "Int" $ whnf (HM.fromListWith (+)) elemsDupI 372 | ] 373 | ] 374 | -- Hashable instance 375 | , bgroup "hash" 376 | [ bench "String" $ whnf hash hm 377 | , bench "ByteString" $ whnf hash hmbs 378 | ] 379 | ] 380 | ] 381 | 382 | ------------------------------------------------------------------------ 383 | -- * HashMap 384 | 385 | lookup :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> Int 386 | lookup xs m = foldl' (\z k -> fromMaybe z (HM.lookup k m)) 0 xs 387 | {-# SPECIALIZE lookup :: [Int] -> HM.HashMap Int Int -> Int #-} 388 | {-# SPECIALIZE lookup :: [String] -> HM.HashMap String Int -> Int #-} 389 | {-# SPECIALIZE lookup :: [BS.ByteString] -> HM.HashMap BS.ByteString Int 390 | -> Int #-} 391 | 392 | insert :: (Eq k, Hashable k) => [(k, Int)] -> HM.HashMap k Int 393 | -> HM.HashMap k Int 394 | insert xs m0 = foldl' (\m (k, v) -> HM.insert k v m) m0 xs 395 | {-# SPECIALIZE insert :: [(Int, Int)] -> HM.HashMap Int Int 396 | -> HM.HashMap Int Int #-} 397 | {-# SPECIALIZE insert :: [(String, Int)] -> HM.HashMap String Int 398 | -> HM.HashMap String Int #-} 399 | {-# SPECIALIZE insert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int 400 | -> HM.HashMap BS.ByteString Int #-} 401 | 402 | delete :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> HM.HashMap k Int 403 | delete xs m0 = foldl' (\m k -> HM.delete k m) m0 xs 404 | {-# SPECIALIZE delete :: [Int] -> HM.HashMap Int Int -> HM.HashMap Int Int #-} 405 | {-# SPECIALIZE delete :: [String] -> HM.HashMap String Int 406 | -> HM.HashMap String Int #-} 407 | {-# SPECIALIZE delete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int 408 | -> HM.HashMap BS.ByteString Int #-} 409 | 410 | alterInsert :: (Eq k, Hashable k) => [(k, Int)] -> HM.HashMap k Int 411 | -> HM.HashMap k Int 412 | alterInsert xs m0 = 413 | foldl' (\m (k, v) -> HM.alter (const . Just $ v) k m) m0 xs 414 | {-# SPECIALIZE alterInsert :: [(Int, Int)] -> HM.HashMap Int Int 415 | -> HM.HashMap Int Int #-} 416 | {-# SPECIALIZE alterInsert :: [(String, Int)] -> HM.HashMap String Int 417 | -> HM.HashMap String Int #-} 418 | {-# SPECIALIZE alterInsert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int 419 | -> HM.HashMap BS.ByteString Int #-} 420 | 421 | alterDelete :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int 422 | -> HM.HashMap k Int 423 | alterDelete xs m0 = 424 | foldl' (\m k -> HM.alter (const Nothing) k m) m0 xs 425 | {-# SPECIALIZE alterDelete :: [Int] -> HM.HashMap Int Int 426 | -> HM.HashMap Int Int #-} 427 | {-# SPECIALIZE alterDelete :: [String] -> HM.HashMap String Int 428 | -> HM.HashMap String Int #-} 429 | {-# SPECIALIZE alterDelete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int 430 | -> HM.HashMap BS.ByteString Int #-} 431 | 432 | alterFInsert :: (Eq k, Hashable k) => [(k, Int)] -> HM.HashMap k Int 433 | -> HM.HashMap k Int 434 | alterFInsert xs m0 = 435 | foldl' (\m (k, v) -> runIdentity $ HM.alterF (const . Identity . Just $ v) k m) m0 xs 436 | {-# SPECIALIZE alterFInsert :: [(Int, Int)] -> HM.HashMap Int Int 437 | -> HM.HashMap Int Int #-} 438 | {-# SPECIALIZE alterFInsert :: [(String, Int)] -> HM.HashMap String Int 439 | -> HM.HashMap String Int #-} 440 | {-# SPECIALIZE alterFInsert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int 441 | -> HM.HashMap BS.ByteString Int #-} 442 | 443 | alterFDelete :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int 444 | -> HM.HashMap k Int 445 | alterFDelete xs m0 = 446 | foldl' (\m k -> runIdentity $ HM.alterF (const . Identity $ Nothing) k m) m0 xs 447 | {-# SPECIALIZE alterFDelete :: [Int] -> HM.HashMap Int Int 448 | -> HM.HashMap Int Int #-} 449 | {-# SPECIALIZE alterFDelete :: [String] -> HM.HashMap String Int 450 | -> HM.HashMap String Int #-} 451 | {-# SPECIALIZE alterFDelete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int 452 | -> HM.HashMap BS.ByteString Int #-} 453 | 454 | isSubmapOfNaive :: (Eq k, Hashable k) => HM.HashMap k Int -> HM.HashMap k Int -> Bool 455 | isSubmapOfNaive m1 m2 = and [ Just v1 == HM.lookup k1 m2 | (k1,v1) <- HM.toList m1 ] 456 | {-# SPECIALIZE isSubmapOfNaive :: HM.HashMap Int Int -> HM.HashMap Int Int -> Bool #-} 457 | {-# SPECIALIZE isSubmapOfNaive :: HM.HashMap String Int -> HM.HashMap String Int -> Bool #-} 458 | {-# SPECIALIZE isSubmapOfNaive :: HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int -> Bool #-} 459 | 460 | #ifdef BENCH_containers_Map 461 | ------------------------------------------------------------------------ 462 | -- * Map 463 | 464 | lookupM :: Ord k => [k] -> M.Map k Int -> Int 465 | lookupM xs m = foldl' (\z k -> fromMaybe z (M.lookup k m)) 0 xs 466 | {-# SPECIALIZE lookupM :: [String] -> M.Map String Int -> Int #-} 467 | {-# SPECIALIZE lookupM :: [BS.ByteString] -> M.Map BS.ByteString Int -> Int #-} 468 | 469 | insertM :: Ord k => [(k, Int)] -> M.Map k Int -> M.Map k Int 470 | insertM xs m0 = foldl' (\m (k, v) -> M.insert k v m) m0 xs 471 | {-# SPECIALIZE insertM :: [(String, Int)] -> M.Map String Int 472 | -> M.Map String Int #-} 473 | {-# SPECIALIZE insertM :: [(BS.ByteString, Int)] -> M.Map BS.ByteString Int 474 | -> M.Map BS.ByteString Int #-} 475 | 476 | deleteM :: Ord k => [k] -> M.Map k Int -> M.Map k Int 477 | deleteM xs m0 = foldl' (\m k -> M.delete k m) m0 xs 478 | {-# SPECIALIZE deleteM :: [String] -> M.Map String Int -> M.Map String Int #-} 479 | {-# SPECIALIZE deleteM :: [BS.ByteString] -> M.Map BS.ByteString Int 480 | -> M.Map BS.ByteString Int #-} 481 | #endif 482 | 483 | #ifdef BENCH_hashmap_Map 484 | ------------------------------------------------------------------------ 485 | -- * Map from the hashmap package 486 | 487 | lookupIHM :: (Eq k, Hashable k, Ord k) => [k] -> IHM.Map k Int -> Int 488 | lookupIHM xs m = foldl' (\z k -> fromMaybe z (IHM.lookup k m)) 0 xs 489 | {-# SPECIALIZE lookupIHM :: [String] -> IHM.Map String Int -> Int #-} 490 | {-# SPECIALIZE lookupIHM :: [BS.ByteString] -> IHM.Map BS.ByteString Int 491 | -> Int #-} 492 | 493 | insertIHM :: (Eq k, Hashable k, Ord k) => [(k, Int)] -> IHM.Map k Int 494 | -> IHM.Map k Int 495 | insertIHM xs m0 = foldl' (\m (k, v) -> IHM.insert k v m) m0 xs 496 | {-# SPECIALIZE insertIHM :: [(String, Int)] -> IHM.Map String Int 497 | -> IHM.Map String Int #-} 498 | {-# SPECIALIZE insertIHM :: [(BS.ByteString, Int)] -> IHM.Map BS.ByteString Int 499 | -> IHM.Map BS.ByteString Int #-} 500 | 501 | deleteIHM :: (Eq k, Hashable k, Ord k) => [k] -> IHM.Map k Int -> IHM.Map k Int 502 | deleteIHM xs m0 = foldl' (\m k -> IHM.delete k m) m0 xs 503 | {-# SPECIALIZE deleteIHM :: [String] -> IHM.Map String Int 504 | -> IHM.Map String Int #-} 505 | {-# SPECIALIZE deleteIHM :: [BS.ByteString] -> IHM.Map BS.ByteString Int 506 | -> IHM.Map BS.ByteString Int #-} 507 | #endif 508 | 509 | #ifdef BENCH_containers_IntMap 510 | ------------------------------------------------------------------------ 511 | -- * IntMap 512 | 513 | lookupIM :: [Int] -> IM.IntMap Int -> Int 514 | lookupIM xs m = foldl' (\z k -> fromMaybe z (IM.lookup k m)) 0 xs 515 | 516 | insertIM :: [(Int, Int)] -> IM.IntMap Int -> IM.IntMap Int 517 | insertIM xs m0 = foldl' (\m (k, v) -> IM.insert k v m) m0 xs 518 | 519 | deleteIM :: [Int] -> IM.IntMap Int -> IM.IntMap Int 520 | deleteIM xs m0 = foldl' (\m k -> IM.delete k m) m0 xs 521 | #endif 522 | -------------------------------------------------------------------------------- /benchmarks/Util/ByteString.hs: -------------------------------------------------------------------------------- 1 | -- | Benchmarking utilities. For example, functions for generating 2 | -- random 'ByteString's. 3 | module Util.ByteString where 4 | 5 | import qualified Data.ByteString as S 6 | import qualified Data.ByteString.Char8 as C 7 | import qualified Util.String as String 8 | 9 | -- | Generate a number of fixed length 'ByteString's where the content 10 | -- of the strings are letters in ascending order. 11 | asc :: Int -- ^ Length of each string 12 | -> Int -- ^ Number of strings 13 | -> [S.ByteString] 14 | asc strlen num = map C.pack $ String.asc strlen num 15 | 16 | -- | Generate a number of fixed length 'ByteString's where the content 17 | -- of the strings are letters in random order. 18 | rnd :: Int -- ^ Length of each string 19 | -> Int -- ^ Number of strings 20 | -> [S.ByteString] 21 | rnd strlen num = map C.pack $ String.rnd strlen num 22 | 23 | -- | Generate a number of fixed length 'ByteString's where the content 24 | -- of the strings are letters in random order, different from @rnd@. 25 | rnd' :: Int -- ^ Length of each string 26 | -> Int -- ^ Number of strings 27 | -> [S.ByteString] 28 | rnd' strlen num = map C.pack $ String.rnd' strlen num 29 | -------------------------------------------------------------------------------- /benchmarks/Util/Int.hs: -------------------------------------------------------------------------------- 1 | -- | Benchmarking utilities. For example, functions for generating 2 | -- random integers. 3 | module Util.Int where 4 | 5 | import System.Random (mkStdGen, randomRs) 6 | 7 | -- | Generate a number of uniform random integers in the interval 8 | -- @[0..upper]@. 9 | rnd :: Int -- ^ Upper bound (inclusive) 10 | -> Int -- ^ Number of integers 11 | -> [Int] 12 | rnd upper num = take num $ randomRs (0, upper) $ mkStdGen 1234 13 | 14 | -- | Generate a number of uniform random integers in the interval 15 | -- @[0..upper]@ different from @rnd@. 16 | rnd' :: Int -- ^ Upper bound (inclusive) 17 | -> Int -- ^ Number of integers 18 | -> [Int] 19 | rnd' upper num = take num $ randomRs (0, upper) $ mkStdGen 5678 20 | -------------------------------------------------------------------------------- /benchmarks/Util/String.hs: -------------------------------------------------------------------------------- 1 | -- | Benchmarking utilities. For example, functions for generating 2 | -- random strings. 3 | module Util.String where 4 | 5 | import System.Random (mkStdGen, randomRs) 6 | 7 | -- | Generate a number of fixed length strings where the content of 8 | -- the strings are letters in ascending order. 9 | asc :: Int -- ^ Length of each string 10 | -> Int -- ^ Number of strings 11 | -> [String] 12 | asc strlen num = take num $ iterate (snd . inc) $ replicate strlen 'a' 13 | where inc [] = (True, []) 14 | inc (c:cs) = case inc cs of (True, cs') | c == 'z' -> (True, 'a' : cs') 15 | | otherwise -> (False, succ c : cs') 16 | (False, cs') -> (False, c : cs') 17 | 18 | -- | Generate a number of fixed length strings where the content of 19 | -- the strings are letters in random order. 20 | rnd :: Int -- ^ Length of each string 21 | -> Int -- ^ Number of strings 22 | -> [String] 23 | rnd strlen num = take num $ split $ randomRs ('a', 'z') $ mkStdGen 1234 24 | where 25 | split cs = case splitAt strlen cs of (str, cs') -> str : split cs' 26 | 27 | -- | Generate a number of fixed length strings where the content of 28 | -- the strings are letters in random order, different from rnd 29 | rnd' :: Int -- ^ Length of each string 30 | -> Int -- ^ Number of strings 31 | -> [String] 32 | rnd' strlen num = take num $ split $ randomRs ('a', 'z') $ mkStdGen 5678 33 | where 34 | split cs = case splitAt strlen cs of (str, cs') -> str : split cs' 35 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | -- Configuration for haskell-ci 2 | 3 | branches: master 4 | 5 | constraint-set debug 6 | constraints: unordered-containers +debug 7 | tests: True 8 | run-tests: True 9 | 10 | installed: -containers 11 | installed: -binary 12 | 13 | -- With GHC < 9, haddock fails due to a parse error in the benchmarks. 14 | -- https://github.com/haskell-CI/haskell-ci/issues/605 15 | haddock: >= 9 16 | -------------------------------------------------------------------------------- /docs/developer-guide.md: -------------------------------------------------------------------------------- 1 | # Developer Guide 2 | 3 | This guide is meant as an entry point for developer. It both gives the 4 | philosophy behind the design of this package and some concrete details, such as 5 | invariants. 6 | 7 | ## Why does this package exist? 8 | 9 | This package exists to offer a different performance/functionality 10 | trade-off vis-a-vis ordered container packages 11 | (e.g. [containers](http://hackage.haskell.org/package/containers)). Hashing-based 12 | data structures tend to be faster than comparison-based ones, at the cost of not 13 | providing operations that rely on the data being ordered. 14 | 15 | This means that this package must be faster than ordered containers, or there 16 | would be no reason for it to exist, given that its functionality is a strict 17 | subset of ordered containers. This might seem obvious, but the author has 18 | rejected several proposals in the past (e.g. to switch to higher quality but 19 | slower hash functions) that would have made unordered-containers too slow to 20 | motivate its existence. 21 | 22 | ## A note on hash functions 23 | 24 | While the [hashable](http://hackage.haskell.org/package/hashable) package is a 25 | separate package, it was co-designed with this package. Its main role is to 26 | support this package and not to provide good general purpose hash functions 27 | (e.g. to use when fingerprinting a text file). 28 | 29 | The hash functions used (by default) were picked to make data structures 30 | fast. The actual functions used often surprise developers who have learned 31 | about hashing during their studies but haven't looked at which functions are 32 | actually used in practice. 33 | 34 | For example, integers are hashed to themselves. This might seemed contrary to 35 | what you might have learned about hashing (e.g. that you need avalanche 36 | behavior; changing one bit of input changes half of the bits in the output). It 37 | turns out that this isn't what typically is done in practice (take a little tour 38 | of the various programming languages standard libraries to see this for 39 | yourself). Hashing integers to themselves is both faster (i.e. free) and the 40 | improved locality can be helpful given common input patterns. 41 | 42 | Another interesting example of hashing is string hashing, where 43 | [FNV](https://en.wikipedia.org/wiki/Fowler%E2%80%93Noll%E2%80%93Vo_hash_function) 44 | is used. FNV is a decent hash function, but has worse properties than say 45 | [MurmurHash](https://en.wikipedia.org/wiki/MurmurHash). However, it's much 46 | faster. The fact that it's faster is not obvious given the way hash function 47 | performance is often quoted, namely by giving the average throughput on large 48 | inputs. Most inputs (e.g. keys) aren't large, often no more than 10 characters 49 | long. Hash functions typically have a start-up cost and many functions that have 50 | high throughput (such as MurmurHash) are more expensive for short strings than 51 | FNV. 52 | 53 | ### Security 54 | 55 | There's an uncomfortable trade-off with regards to security threats posed by 56 | e.g. denial of service attacks. Always using more secure hash function, like 57 | [SipHash](https://en.wikipedia.org/wiki/SipHash), would provide security by 58 | default. However, those functions would make the performance of the data 59 | structures no better than that of ordered containers, which defeats the purpose 60 | of this package. 61 | 62 | Previous versions of this package tried to switch to SipHash (and a different 63 | hash function for integers). Those changes eventually had to be rolled back 64 | after failing to make a fast enough implementation (using SSE instructions where 65 | possible) that also wasn't crashing on some platforms. 66 | 67 | The current, somewhat frustrating, state is that you have to know which data 68 | structures can be tampered with by users and either use SipHash just for those 69 | or switch to ordered containers that don't have collision problems. This package 70 | uses fast hash functions by default. 71 | 72 | ## Data structure design 73 | 74 | The data structures are based on the 75 | [hash array mapped trie (HAMT)](https://en.wikipedia.org/wiki/Hash_array_mapped_trie) 76 | data structures. There are several persistent implementations of the HAMT, 77 | including in Clojure and Scala. 78 | 79 | The actual implementation is as follows: 80 | 81 | ``` haskell 82 | data HashMap k v 83 | = Empty 84 | | BitmapIndexed !Bitmap !(A.Array (HashMap k v)) 85 | | Leaf !Hash !(Leaf k v) 86 | | Full !(A.Array (HashMap k v)) 87 | | Collision !Hash !(A.Array (Leaf k v)) 88 | ``` 89 | 90 | Here's a quick overview in order of simplicity: 91 | 92 | * `Empty` -- The empty map. 93 | * `Leaf` -- A key-value pair. 94 | * `Collision` -- An array of key-value pairs where the keys have identical hash 95 | values. Element order doesn't matter. 96 | * `Full` -- An array of *2^B* children. Given a key you can find the child it 97 | is part of by taking *B* bits of the hash value for the key and indexing into 98 | the key. Which bits to use depends on the tree level. 99 | * `BitmapIndexed` -- Similar to above except that the array is implemented as a 100 | sparse array (to avoid storing `Empty` values). A bitmask and popcount is 101 | used to convert from the index taken from the hash value, just like above, to 102 | the actual index in the array. This node gets upgraded to a `Full` node when 103 | it contains *2^B* elements. 104 | 105 | The number of bits of the hash value to use at each level of the tree, *B*, is a 106 | compile time constant, currently 5. In general a larger *B* improves lookup 107 | performance (shallower tree) but hurts modification (large nodes to copy when 108 | updating the spine of the tree). 109 | 110 | `Full` is just an optimized version of `BitmapIndexed` that allows us faster 111 | indexing, faster copying on modification (given that its size is statically 112 | know), and lower memory use. 113 | 114 | ## Why things are fast 115 | 116 | Performance is largely dominated by memory layout and allocation. The code has 117 | been carefully tuned by looking at the GHC core output and sometimes the 118 | assembly output. In particular there's no unnecessary allocation in the most 119 | important functions and the memory layout is about as good as we can get using 120 | GHC. 121 | 122 | Avoiding allocation is done by making things strict (laziness is the enemy of 123 | predictable performance) and using `INLINABLE` to allow to be specialized at the 124 | call site (so key and value arguments to functions are passed as values rather 125 | than pointers to heap objects). 126 | 127 | The main remaining bottlenecks are due to e.g. GHC not allowing us to unpack an 128 | array into a constructor. Two examples: the `Full` constructor is a separate 129 | heap object from the array it contains and the `Leaf` constructor contains 130 | pointers to the key and value instead of unpacking them into the 131 | constructor. There's nothing we can do about this at the moment. 132 | 133 | ## Backwards compatibility policy 134 | 135 | We support the last 3 major GHC releases. 136 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty (defaultMain, testGroup) 4 | 5 | import qualified Properties 6 | import qualified Regressions 7 | import qualified Strictness 8 | 9 | main :: IO () 10 | main = defaultMain $ testGroup "All" 11 | [ Properties.tests 12 | , Regressions.tests 13 | , Strictness.tests 14 | ] 15 | -------------------------------------------------------------------------------- /tests/Properties.hs: -------------------------------------------------------------------------------- 1 | module Properties (tests) where 2 | 3 | import Test.Tasty (TestTree, testGroup) 4 | 5 | import qualified Properties.HashMapLazy 6 | import qualified Properties.HashMapStrict 7 | import qualified Properties.HashSet 8 | import qualified Properties.List 9 | 10 | tests :: TestTree 11 | tests = testGroup "Properties" 12 | [ Properties.HashMapLazy.tests 13 | , Properties.HashMapStrict.tests 14 | , Properties.HashSet.tests 15 | , Properties.List.tests 16 | ] 17 | -------------------------------------------------------------------------------- /tests/Properties/HashMapLazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v) 7 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- https://github.com/nick8325/quickcheck/issues/344 8 | 9 | -- | Tests for "Data.HashMap.Lazy" and "Data.HashMap.Strict". We test functions by 10 | -- comparing them to @Map@ from @containers@. @Map@ is referred to as the /model/ 11 | -- for 'HashMap' 12 | 13 | #if defined(STRICT) 14 | #define MODULE_NAME Properties.HashMapStrict 15 | #else 16 | #define MODULE_NAME Properties.HashMapLazy 17 | #endif 18 | 19 | module MODULE_NAME (tests) where 20 | 21 | import Control.Applicative (Const (..)) 22 | import Data.Bifoldable 23 | import Data.Function (on) 24 | import Data.Functor.Identity (Identity (..)) 25 | import Data.Hashable (Hashable (hashWithSalt)) 26 | import Data.HashMap.Internal.Debug (Validity (..), valid) 27 | import Data.Ord (comparing) 28 | import Test.QuickCheck (Arbitrary (..), Fun, Property, pattern Fn, 29 | pattern Fn2, pattern Fn3, (===), (==>)) 30 | import Test.QuickCheck.Poly (A, B, C) 31 | import Test.Tasty (TestTree, testGroup) 32 | import Test.Tasty.QuickCheck (testProperty) 33 | import Util.Key (Key, incKey, keyToInt) 34 | 35 | import qualified Data.Foldable as Foldable 36 | import qualified Data.List as List 37 | import qualified Test.QuickCheck as QC 38 | 39 | #if defined(STRICT) 40 | import Data.HashMap.Strict (HashMap) 41 | import qualified Data.HashMap.Strict as HM 42 | import qualified Data.Map.Strict as M 43 | #else 44 | import Data.HashMap.Lazy (HashMap) 45 | import qualified Data.HashMap.Lazy as HM 46 | import qualified Data.Map.Lazy as M 47 | #endif 48 | 49 | instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where 50 | arbitrary = HM.fromList <$> arbitrary 51 | shrink = fmap HM.fromList . shrink . HM.toList 52 | 53 | ------------------------------------------------------------------------ 54 | -- Helpers 55 | 56 | type HMK = HashMap Key 57 | type HMKI = HMK Int 58 | 59 | sortByKey :: Ord k => [(k, v)] -> [(k, v)] 60 | sortByKey = List.sortBy (compare `on` fst) 61 | 62 | toOrdMap :: Ord k => HashMap k v -> M.Map k v 63 | toOrdMap = M.fromList . HM.toList 64 | 65 | isValid :: (Eq k, Hashable k, Show k) => HashMap k v -> Property 66 | isValid m = valid m === Valid 67 | 68 | -- The free magma is used to test that operations are applied in the 69 | -- same order. 70 | data Magma a 71 | = Leaf a 72 | | Op (Magma a) (Magma a) 73 | deriving (Show, Eq, Ord) 74 | 75 | instance Hashable a => Hashable (Magma a) where 76 | hashWithSalt s (Leaf a) = hashWithSalt s (hashWithSalt (1::Int) a) 77 | hashWithSalt s (Op m n) = hashWithSalt s (hashWithSalt (hashWithSalt (2::Int) m) n) 78 | 79 | ------------------------------------------------------------------------ 80 | -- Test list 81 | 82 | tests :: TestTree 83 | tests = 84 | testGroup 85 | #if defined(STRICT) 86 | "Data.HashMap.Strict" 87 | #else 88 | "Data.HashMap.Lazy" 89 | #endif 90 | [ 91 | -- Instances 92 | testGroup "instances" 93 | [ testGroup "Eq" 94 | [ testProperty "==" $ 95 | \(x :: HMKI) y -> (x == y) === (toOrdMap x == toOrdMap y) 96 | , testProperty "/=" $ 97 | \(x :: HMKI) y -> (x == y) === (toOrdMap x == toOrdMap y) 98 | ] 99 | , testGroup "Ord" 100 | [ testProperty "compare reflexive" $ 101 | \(m :: HMKI) -> compare m m === EQ 102 | , testProperty "compare transitive" $ 103 | \(x :: HMKI) y z -> case (compare x y, compare y z) of 104 | (EQ, o) -> compare x z === o 105 | (o, EQ) -> compare x z === o 106 | (LT, LT) -> compare x z === LT 107 | (GT, GT) -> compare x z === GT 108 | (LT, GT) -> QC.property True -- ys greater than xs and zs. 109 | (GT, LT) -> QC.property True 110 | , testProperty "compare antisymmetric" $ 111 | \(x :: HMKI) y -> case (compare x y, compare y x) of 112 | (EQ, EQ) -> True 113 | (LT, GT) -> True 114 | (GT, LT) -> True 115 | _ -> False 116 | , testProperty "Ord => Eq" $ 117 | \(x :: HMKI) y -> case (compare x y, x == y) of 118 | (EQ, True) -> True 119 | (LT, False) -> True 120 | (GT, False) -> True 121 | _ -> False 122 | ] 123 | , testProperty "Read/Show" $ 124 | \(x :: HMKI) -> x === read (show x) 125 | , testProperty "Functor" $ 126 | \(x :: HMKI) (Fn f :: Fun Int Int) -> 127 | toOrdMap (fmap f x) === fmap f (toOrdMap x) 128 | , testProperty "Foldable" $ 129 | \(x :: HMKI) -> 130 | let f = List.sort . Foldable.foldr (:) [] 131 | in f x === f (toOrdMap x) 132 | , testGroup "Bifoldable" 133 | [ testProperty "bifoldMap" $ 134 | \(m :: HMK Key) -> 135 | bifoldMap (:[]) (:[]) m === concatMap (\(k, v) -> [k, v]) (HM.toList m) 136 | , testProperty "bifoldr" $ 137 | \(m :: HMK Key) -> 138 | bifoldr (:) (:) [] m === concatMap (\(k, v) -> [k, v]) (HM.toList m) 139 | , testProperty "bifoldl" $ 140 | \(m :: HMK Key) -> 141 | bifoldl (flip (:)) (flip (:)) [] m 142 | === 143 | reverse (concatMap (\(k, v) -> [k, v]) (HM.toList m)) 144 | ] 145 | , testProperty "Hashable" $ 146 | \(xs :: [(Key, Int)]) is salt -> 147 | let xs' = List.nubBy (\(k,_) (k',_) -> k == k') xs 148 | -- Shuffle the list using indexes in the second 149 | shuffle :: [Int] -> [a] -> [a] 150 | shuffle idxs = List.map snd 151 | . List.sortBy (comparing fst) 152 | . List.zip (idxs ++ [List.maximum (0:is) + 1 ..]) 153 | ys = shuffle is xs' 154 | x = HM.fromList xs' 155 | y = HM.fromList ys 156 | in x == y ==> hashWithSalt salt x === hashWithSalt salt y 157 | ] 158 | -- Construction 159 | , testGroup "empty" 160 | [ testProperty "valid" $ QC.once $ 161 | isValid (HM.empty :: HMKI) 162 | ] 163 | , testGroup "singleton" 164 | [ testProperty "valid" $ 165 | \(k :: Key) (v :: A) -> isValid (HM.singleton k v) 166 | ] 167 | -- Basic interface 168 | , testProperty "size" $ 169 | \(x :: HMKI) -> HM.size x === M.size (toOrdMap x) 170 | , testProperty "member" $ 171 | \(k :: Key) (m :: HMKI) -> HM.member k m === M.member k (toOrdMap m) 172 | , testProperty "lookup" $ 173 | \(k :: Key) (m :: HMKI) -> HM.lookup k m === M.lookup k (toOrdMap m) 174 | , testProperty "!?" $ 175 | \(k :: Key) (m :: HMKI) -> m HM.!? k === M.lookup k (toOrdMap m) 176 | , testGroup "insert" 177 | [ testProperty "model" $ 178 | \(k :: Key) (v :: Int) x -> 179 | let y = HM.insert k v x 180 | in toOrdMap y === M.insert k v (toOrdMap x) 181 | , testProperty "valid" $ 182 | \(k :: Key) (v :: Int) x -> isValid (HM.insert k v x) 183 | ] 184 | , testGroup "insertWith" 185 | [ testProperty "insertWith" $ 186 | \(Fn2 f) k v (x :: HMKI) -> 187 | toOrdMap (HM.insertWith f k v x) === M.insertWith f k v (toOrdMap x) 188 | , testProperty "valid" $ 189 | \(Fn2 f) k v (x :: HMKI) -> isValid (HM.insertWith f k v x) 190 | ] 191 | , testGroup "delete" 192 | [ testProperty "model" $ 193 | \(k :: Key) (x :: HMKI) -> 194 | let y = HM.delete k x 195 | in toOrdMap y === M.delete k (toOrdMap x) 196 | , testProperty "valid" $ 197 | \(k :: Key) (x :: HMKI) -> isValid (HM.delete k x) 198 | ] 199 | , testGroup "adjust" 200 | [ testProperty "model" $ 201 | \(Fn f) k (x :: HMKI) -> 202 | toOrdMap (HM.adjust f k x) === M.adjust f k (toOrdMap x) 203 | , testProperty "valid" $ 204 | \(Fn f) k (x :: HMKI) -> isValid (HM.adjust f k x) 205 | ] 206 | , testGroup "update" 207 | [ testProperty "model" $ 208 | \(Fn f) k (x :: HMKI) -> 209 | toOrdMap (HM.update f k x) === M.update f k (toOrdMap x) 210 | , testProperty "valid" $ 211 | \(Fn f) k (x :: HMKI) -> isValid (HM.update f k x) 212 | ] 213 | , testGroup "alter" 214 | [ testProperty "model" $ 215 | \(Fn f) k (x :: HMKI) -> 216 | toOrdMap (HM.alter f k x) === M.alter f k (toOrdMap x) 217 | , testProperty "valid" $ 218 | \(Fn f) k (x :: HMKI) -> isValid (HM.alter f k x) 219 | ] 220 | , testGroup "alterF" 221 | [ testGroup "model" 222 | [ -- We choose the list functor here because we don't fuss with 223 | -- it in alterF rules and because it has a sufficiently interesting 224 | -- structure to have a good chance of breaking if something is wrong. 225 | testProperty "[]" $ 226 | \(Fn f :: Fun (Maybe A) [Maybe A]) k (x :: HMK A) -> 227 | map toOrdMap (HM.alterF f k x) === M.alterF f k (toOrdMap x) 228 | , testProperty "adjust" $ 229 | \(Fn f) k (x :: HMKI) -> 230 | let g = Identity . fmap f 231 | in fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x) 232 | , testProperty "insert" $ 233 | \v k (x :: HMKI) -> 234 | let g = const . Identity . Just $ v 235 | in fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x) 236 | , testProperty "insertWith" $ 237 | \(Fn f) k v (x :: HMKI) -> 238 | let g = Identity . Just . maybe v f 239 | in fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x) 240 | , testProperty "delete" $ 241 | \k (x :: HMKI) -> 242 | let f = const (Identity Nothing) 243 | in fmap toOrdMap (HM.alterF f k x) === M.alterF f k (toOrdMap x) 244 | , testProperty "lookup" $ 245 | \(Fn f :: Fun (Maybe A) B) k (x :: HMK A) -> 246 | let g = Const . f 247 | in fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x) 248 | ] 249 | , testProperty "valid" $ 250 | \(Fn f :: Fun (Maybe A) [Maybe A]) k (x :: HMK A) -> 251 | let ys = HM.alterF f k x 252 | in map valid ys === (Valid <$ ys) 253 | ] 254 | , testGroup "isSubmapOf" 255 | [ testProperty "model" $ 256 | \(x :: HMKI) y -> HM.isSubmapOf x y === M.isSubmapOf (toOrdMap x) (toOrdMap y) 257 | , testProperty "m ⊆ m" $ 258 | \(x :: HMKI) -> HM.isSubmapOf x x 259 | , testProperty "m1 ⊆ m1 ∪ m2" $ 260 | \(x :: HMKI) y -> HM.isSubmapOf x (HM.union x y) 261 | , testProperty "m1 ⊈ m2 ⇒ m1 ∪ m2 ⊈ m1" $ 262 | \(m1 :: HMKI) m2 -> not (HM.isSubmapOf m1 m2) ==> HM.isSubmapOf m1 (HM.union m1 m2) 263 | , testProperty "m1\\m2 ⊆ m1" $ 264 | \(m1 :: HMKI) (m2 :: HMKI) -> HM.isSubmapOf (HM.difference m1 m2) m1 265 | , testProperty "m1 ∩ m2 ≠ ∅ ⇒ m1 ⊈ m1\\m2 " $ 266 | \(m1 :: HMKI) (m2 :: HMKI) -> 267 | not (HM.null (HM.intersection m1 m2)) ==> 268 | not (HM.isSubmapOf m1 (HM.difference m1 m2)) 269 | , testProperty "delete k m ⊆ m" $ 270 | \(m :: HMKI) -> 271 | not (HM.null m) ==> 272 | QC.forAll (QC.elements (HM.keys m)) $ \k -> 273 | HM.isSubmapOf (HM.delete k m) m 274 | , testProperty "m ⊈ delete k m " $ 275 | \(m :: HMKI) -> 276 | not (HM.null m) ==> 277 | QC.forAll (QC.elements (HM.keys m)) $ \k -> 278 | not (HM.isSubmapOf m (HM.delete k m)) 279 | , testProperty "k ∉ m ⇒ m ⊆ insert k v m" $ 280 | \k v (m :: HMKI) -> not (HM.member k m) ==> HM.isSubmapOf m (HM.insert k v m) 281 | , testProperty "k ∉ m ⇒ insert k v m ⊈ m" $ 282 | \k v (m :: HMKI) -> not (HM.member k m) ==> not (HM.isSubmapOf (HM.insert k v m) m) 283 | ] 284 | -- Combine 285 | , testGroup "union" 286 | [ testProperty "model" $ 287 | \(x :: HMKI) y -> 288 | let z = HM.union x y 289 | in toOrdMap z === M.union (toOrdMap x) (toOrdMap y) 290 | , testProperty "valid" $ 291 | \(x :: HMKI) y -> isValid (HM.union x y) 292 | ] 293 | , testGroup "unionWith" 294 | [ testProperty "model" $ 295 | \(Fn2 f) (x :: HMKI) y -> 296 | toOrdMap (HM.unionWith f x y) === M.unionWith f (toOrdMap x) (toOrdMap y) 297 | , testProperty "valid" $ 298 | \(Fn2 f) (x :: HMKI) y -> isValid (HM.unionWith f x y) 299 | ] 300 | , testGroup "unionWithKey" 301 | [ testProperty "model" $ 302 | \(Fn3 f) (x :: HMKI) y -> 303 | toOrdMap (HM.unionWithKey f x y) === M.unionWithKey f (toOrdMap x) (toOrdMap y) 304 | , testProperty "valid" $ 305 | \(Fn3 f) (x :: HMKI) y -> isValid (HM.unionWithKey f x y) 306 | ] 307 | , testGroup "unions" 308 | [ testProperty "model" $ 309 | \(ms :: [HMKI]) -> toOrdMap (HM.unions ms) === M.unions (map toOrdMap ms) 310 | , testProperty "valid" $ 311 | \(ms :: [HMKI]) -> isValid (HM.unions ms) 312 | ] 313 | , testGroup "difference" 314 | [ testProperty "model" $ 315 | \(x :: HMKI) (y :: HMKI) -> 316 | toOrdMap (HM.difference x y) === M.difference (toOrdMap x) (toOrdMap y) 317 | , testProperty "valid" $ 318 | \(x :: HMKI) (y :: HMKI) -> isValid (HM.difference x y) 319 | ] 320 | , testGroup "differenceWith" 321 | [ testProperty "model" $ 322 | \(Fn2 f) (x :: HMK A) (y :: HMK B) -> 323 | toOrdMap (HM.differenceWith f x y) === M.differenceWith f (toOrdMap x) (toOrdMap y) 324 | , testProperty "valid" $ 325 | \(Fn2 f) (x :: HMK A) (y :: HMK B) -> isValid (HM.differenceWith f x y) 326 | ] 327 | , testGroup "intersection" 328 | [ testProperty "model" $ 329 | \(x :: HMKI) (y :: HMKI) -> 330 | toOrdMap (HM.intersection x y) === M.intersection (toOrdMap x) (toOrdMap y) 331 | , testProperty "valid" $ 332 | \(x :: HMKI) (y :: HMKI) -> 333 | isValid (HM.intersection x y) 334 | ] 335 | , testGroup "intersectionWith" 336 | [ testProperty "model" $ 337 | \(Fn2 f :: Fun (A, B) C) (x :: HMK A) (y :: HMK B) -> 338 | toOrdMap (HM.intersectionWith f x y) === M.intersectionWith f (toOrdMap x) (toOrdMap y) 339 | , testProperty "valid" $ 340 | \(Fn2 f :: Fun (A, B) C) (x :: HMK A) (y :: HMK B) -> 341 | isValid (HM.intersectionWith f x y) 342 | ] 343 | , testGroup "intersectionWithKey" 344 | [ testProperty "model" $ 345 | \(Fn3 f :: Fun (Key, A, B) C) (x :: HMK A) (y :: HMK B) -> 346 | toOrdMap (HM.intersectionWithKey f x y) 347 | === 348 | M.intersectionWithKey f (toOrdMap x) (toOrdMap y) 349 | , testProperty "valid" $ 350 | \(Fn3 f :: Fun (Key, A, B) C) (x :: HMK A) (y :: HMK B) -> 351 | isValid (HM.intersectionWithKey f x y) 352 | ] 353 | , testGroup "compose" 354 | [ testProperty "valid" $ 355 | \(x :: HMK Int) (y :: HMK Key) -> isValid (HM.compose x y) 356 | ] 357 | -- Transformations 358 | , testGroup "map" 359 | [ testProperty "model" $ 360 | \(Fn f :: Fun A B) (m :: HMK A) -> toOrdMap (HM.map f m) === M.map f (toOrdMap m) 361 | , testProperty "valid" $ 362 | \(Fn f :: Fun A B) (m :: HMK A) -> isValid (HM.map f m) 363 | ] 364 | , testGroup "traverseWithKey" 365 | [ testProperty "model" $ QC.mapSize (\s -> s `div` 8) $ 366 | \(x :: HMKI) -> 367 | let f k v = [keyToInt k + v + 1, keyToInt k + v + 2] 368 | ys = HM.traverseWithKey f x 369 | in List.sort (fmap toOrdMap ys) === List.sort (M.traverseWithKey f (toOrdMap x)) 370 | , testProperty "valid" $ QC.mapSize (\s -> s `div` 8) $ 371 | \(x :: HMKI) -> 372 | let f k v = [keyToInt k + v + 1, keyToInt k + v + 2] 373 | ys = HM.traverseWithKey f x 374 | in fmap valid ys === (Valid <$ ys) 375 | ] 376 | , testGroup "mapKeys" 377 | [ testProperty "model" $ 378 | \(m :: HMKI) -> toOrdMap (HM.mapKeys incKey m) === M.mapKeys incKey (toOrdMap m) 379 | , testProperty "valid" $ 380 | \(Fn f :: Fun Key Key) (m :: HMKI) -> isValid (HM.mapKeys f m) 381 | ] 382 | -- Folds 383 | , testProperty "foldr" $ 384 | \(m :: HMKI) -> List.sort (HM.foldr (:) [] m) === List.sort (M.foldr (:) [] (toOrdMap m)) 385 | , testProperty "foldl" $ 386 | \(m :: HMKI) -> 387 | List.sort (HM.foldl (flip (:)) [] m) === List.sort (M.foldl (flip (:)) [] (toOrdMap m)) 388 | , testProperty "foldrWithKey" $ 389 | \(m :: HMKI) -> 390 | let f k v z = (k, v) : z 391 | in sortByKey (HM.foldrWithKey f [] m) === sortByKey (M.foldrWithKey f [] (toOrdMap m)) 392 | , testProperty "foldlWithKey" $ 393 | \(m :: HMKI) -> 394 | let f z k v = (k, v) : z 395 | in sortByKey (HM.foldlWithKey f [] m) === sortByKey (M.foldlWithKey f [] (toOrdMap m)) 396 | , testProperty "foldrWithKey'" $ 397 | \(m :: HMKI) -> 398 | let f k v z = (k, v) : z 399 | in sortByKey (HM.foldrWithKey' f [] m) === sortByKey (M.foldrWithKey' f [] (toOrdMap m)) 400 | , testProperty "foldlWithKey'" $ 401 | \(m :: HMKI) -> 402 | let f z k v = (k, v) : z 403 | in sortByKey (HM.foldlWithKey' f [] m) === sortByKey (M.foldlWithKey' f [] (toOrdMap m)) 404 | , testProperty "foldl'" $ 405 | \(m :: HMKI) -> 406 | List.sort (HM.foldl' (flip (:)) [] m) === List.sort (M.foldl' (flip (:)) [] (toOrdMap m)) 407 | , testProperty "foldr'" $ 408 | \(m :: HMKI) -> List.sort (HM.foldr' (:) [] m) === List.sort (M.foldr' (:) [] (toOrdMap m)) 409 | , testProperty "foldMapWithKey" $ 410 | \(m :: HMKI) -> 411 | let f k v = [(k, v)] 412 | in sortByKey (HM.foldMapWithKey f m) === sortByKey (M.foldMapWithKey f (toOrdMap m)) 413 | -- Filter 414 | , testGroup "filter" 415 | [ testProperty "model" $ 416 | \(Fn p) (m :: HMKI) -> toOrdMap (HM.filter p m) === M.filter p (toOrdMap m) 417 | , testProperty "valid" $ 418 | \(Fn p) (m :: HMKI) -> isValid (HM.filter p m) 419 | ] 420 | , testGroup "filterWithKey" 421 | [ testProperty "model" $ 422 | \(Fn2 p) (m :: HMKI) -> 423 | toOrdMap (HM.filterWithKey p m) === M.filterWithKey p (toOrdMap m) 424 | , testProperty "valid" $ 425 | \(Fn2 p) (m :: HMKI) -> isValid (HM.filterWithKey p m) 426 | ] 427 | , testGroup "mapMaybe" 428 | [ testProperty "model" $ 429 | \(Fn f :: Fun A (Maybe B)) (m :: HMK A) -> 430 | toOrdMap (HM.mapMaybe f m) === M.mapMaybe f (toOrdMap m) 431 | , testProperty "valid" $ 432 | \(Fn f :: Fun A (Maybe B)) (m :: HMK A) -> isValid (HM.mapMaybe f m) 433 | ] 434 | , testGroup "mapMaybeWithKey" 435 | [ testProperty "model" $ 436 | \(Fn2 f :: Fun (Key, A) (Maybe B)) (m :: HMK A) -> 437 | toOrdMap (HM.mapMaybeWithKey f m) === M.mapMaybeWithKey f (toOrdMap m) 438 | , testProperty "valid" $ 439 | \(Fn2 f :: Fun (Key, A) (Maybe B)) (m :: HMK A) -> 440 | isValid (HM.mapMaybeWithKey f m) 441 | ] 442 | -- Conversions 443 | , testProperty "elems" $ 444 | \(m :: HMKI) -> List.sort (HM.elems m) === List.sort (M.elems (toOrdMap m)) 445 | , testProperty "keys" $ 446 | \(m :: HMKI) -> List.sort (HM.keys m) === List.sort (M.keys (toOrdMap m)) 447 | , testGroup "fromList" 448 | [ testProperty "model" $ 449 | \(kvs :: [(Key, Int)]) -> toOrdMap (HM.fromList kvs) === M.fromList kvs 450 | , testProperty "valid" $ 451 | \(kvs :: [(Key, Int)]) -> isValid (HM.fromList kvs) 452 | ] 453 | , testGroup "fromListWith" 454 | [ testProperty "model" $ 455 | \(kvs :: [(Key, Int)]) -> 456 | let kvsM = map (fmap Leaf) kvs 457 | in toOrdMap (HM.fromListWith Op kvsM) === M.fromListWith Op kvsM 458 | , testProperty "valid" $ 459 | \(Fn2 f) (kvs :: [(Key, A)]) -> isValid (HM.fromListWith f kvs) 460 | ] 461 | , testGroup "fromListWithKey" 462 | [ testProperty "model" $ 463 | \(kvs :: [(Key, Int)]) -> 464 | let kvsM = fmap (\(k,v) -> (Leaf (keyToInt k), Leaf v)) kvs 465 | combine k v1 v2 = Op k (Op v1 v2) 466 | in toOrdMap (HM.fromListWithKey combine kvsM) === M.fromListWithKey combine kvsM 467 | , testProperty "valid" $ 468 | \(Fn3 f) (kvs :: [(Key, A)]) -> isValid (HM.fromListWithKey f kvs) 469 | ] 470 | , testProperty "toList" $ 471 | \(m :: HMKI) -> List.sort (HM.toList m) === List.sort (M.toList (toOrdMap m)) 472 | ] 473 | -------------------------------------------------------------------------------- /tests/Properties/HashMapStrict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #define STRICT 4 | 5 | #include "HashMapLazy.hs" 6 | -------------------------------------------------------------------------------- /tests/Properties/HashSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} -- because of the Arbitrary instances 5 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- https://github.com/nick8325/quickcheck/issues/344 6 | 7 | -- | Tests for the 'Data.HashSet' module. We test functions by 8 | -- comparing them to @Set@ from @containers@. @Set@ is referred to as a 9 | -- /model/ for @HashSet@. 10 | 11 | module Properties.HashSet (tests) where 12 | 13 | import Data.Hashable (Hashable (hashWithSalt)) 14 | import Data.HashMap.Lazy (HashMap) 15 | import Data.HashSet (HashSet) 16 | import Data.Ord (comparing) 17 | import Data.Set (Set) 18 | import Test.QuickCheck (Fun, pattern Fn, (===), (==>)) 19 | import Test.Tasty (TestTree, testGroup) 20 | import Test.Tasty.QuickCheck (Arbitrary (..), testProperty) 21 | import Util.Key (Key, keyToInt) 22 | 23 | import qualified Data.Foldable as Foldable 24 | import qualified Data.HashMap.Lazy as HM 25 | import qualified Data.HashSet as HS 26 | import qualified Data.List as List 27 | import qualified Data.Set as S 28 | import qualified Test.QuickCheck as QC 29 | 30 | instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where 31 | arbitrary = HM.fromList <$> arbitrary 32 | shrink = fmap HM.fromList . shrink . HM.toList 33 | 34 | instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where 35 | arbitrary = HS.fromMap <$> arbitrary 36 | shrink = fmap HS.fromMap . shrink . HS.toMap 37 | 38 | ------------------------------------------------------------------------ 39 | -- Helpers 40 | 41 | type HSK = HashSet Key 42 | 43 | toOrdSet :: Ord a => HashSet a -> Set a 44 | toOrdSet = S.fromList . HS.toList 45 | 46 | ------------------------------------------------------------------------ 47 | -- Test list 48 | 49 | tests :: TestTree 50 | tests = testGroup "Data.HashSet" 51 | [ -- Instances 52 | testGroup "instances" 53 | [ testGroup "Eq" 54 | [ testProperty "==" $ 55 | \(x :: HSK) y -> (x == y) === (toOrdSet x == toOrdSet y) 56 | , testProperty "== permutations" $ 57 | \(xs :: [Key]) (is :: [Int]) -> 58 | let shuffle idxs = List.map snd 59 | . List.sortBy (comparing fst) 60 | . List.zip (idxs ++ [List.maximum (0:is) + 1 ..]) 61 | ys = shuffle is xs 62 | in HS.fromList xs === HS.fromList ys 63 | , testProperty "/=" $ 64 | \(x :: HSK) y -> (x /= y) === (toOrdSet x /= toOrdSet y) 65 | ] 66 | , testGroup "Ord" 67 | [ testProperty "compare reflexive" $ 68 | -- We cannot compare to `Data.Map` as ordering is different. 69 | \(x :: HSK) -> compare x x === EQ 70 | , testProperty "compare transitive" $ 71 | \(x :: HSK) y z -> case (compare x y, compare y z) of 72 | (EQ, o) -> compare x z === o 73 | (o, EQ) -> compare x z === o 74 | (LT, LT) -> compare x z === LT 75 | (GT, GT) -> compare x z === GT 76 | (LT, GT) -> QC.property True -- ys greater than xs and zs. 77 | (GT, LT) -> QC.property True 78 | , testProperty "compare antisymmetric" $ 79 | \(x :: HSK) y -> case (compare x y, compare y x) of 80 | (EQ, EQ) -> True 81 | (LT, GT) -> True 82 | (GT, LT) -> True 83 | _ -> False 84 | , testProperty "Ord => Eq" $ 85 | \(x :: HSK) y -> case (compare x y, x == y) of 86 | (EQ, True) -> True 87 | (LT, False) -> True 88 | (GT, False) -> True 89 | _ -> False 90 | ] 91 | , testProperty "Read/Show" $ 92 | \(x :: HSK) -> x === read (show x) 93 | , testProperty "Foldable" $ 94 | \(x :: HSK) -> 95 | List.sort (Foldable.foldr (:) [] x) 96 | === 97 | List.sort (Foldable.foldr (:) [] (toOrdSet x)) 98 | , testProperty "Hashable" $ 99 | \(xs :: [Key]) (is :: [Int]) salt -> 100 | let shuffle idxs = List.map snd 101 | . List.sortBy (comparing fst) 102 | . List.zip (idxs ++ [List.maximum (0:is) + 1 ..]) 103 | xs' = List.nub xs 104 | ys = shuffle is xs' 105 | x = HS.fromList xs' 106 | y = HS.fromList ys 107 | in x == y ==> hashWithSalt salt x === hashWithSalt salt y 108 | ] 109 | -- Basic interface 110 | , testProperty "size" $ 111 | \(x :: HSK) -> HS.size x === List.length (HS.toList x) 112 | , testProperty "member" $ 113 | \e (s :: HSK) -> HS.member e s === S.member e (toOrdSet s) 114 | , testProperty "insert" $ 115 | \e (s :: HSK) -> toOrdSet (HS.insert e s) === S.insert e (toOrdSet s) 116 | , testProperty "delete" $ 117 | \e (s :: HSK) -> toOrdSet (HS.delete e s) === S.delete e (toOrdSet s) 118 | -- Combine 119 | , testProperty "union" $ 120 | \(x :: HSK) y -> toOrdSet (HS.union x y) === S.union (toOrdSet x) (toOrdSet y) 121 | -- Transformations 122 | , testProperty "map" $ 123 | \(Fn f :: Fun Key Key) (s :: HSK) -> toOrdSet (HS.map f s) === S.map f (toOrdSet s) 124 | -- Folds 125 | , testProperty "foldr" $ 126 | \(s :: HSK) -> 127 | List.sort (HS.foldr (:) [] s) === List.sort (S.foldr (:) [] (toOrdSet s)) 128 | , testProperty "foldl'" $ 129 | \(s :: HSK) z0 -> 130 | let f z k = keyToInt k + z 131 | in HS.foldl' f z0 s === S.foldl' f z0 (toOrdSet s) 132 | -- Filter 133 | , testProperty "filter" $ 134 | \(Fn p) (s :: HSK) -> toOrdSet (HS.filter p s) === S.filter p (toOrdSet s) 135 | -- Conversions 136 | , testProperty "toList" $ 137 | \(xs :: [Key]) -> List.sort (HS.toList (HS.fromList xs)) === S.toAscList (S.fromList xs) 138 | ] 139 | -------------------------------------------------------------------------------- /tests/Properties/List.hs: -------------------------------------------------------------------------------- 1 | module Properties.List (tests) where 2 | 3 | import Data.HashMap.Internal.List 4 | import Data.List (nub, sort, sortBy) 5 | import Data.Ord (comparing) 6 | import Test.QuickCheck (Property, property, (===), (==>)) 7 | import Test.Tasty (TestTree, testGroup) 8 | import Test.Tasty.QuickCheck (testProperty) 9 | 10 | tests :: TestTree 11 | tests = testGroup "Data.HashMap.Internal.List" 12 | [ testProperty "isPermutationBy" pIsPermutation 13 | , testProperty "isPermutationBy of different length" pIsPermutationDiffLength 14 | , testProperty "pUnorderedCompare" pUnorderedCompare 15 | , testGroup "modelUnorderedCompare" 16 | [ testProperty "reflexive" modelUnorderedCompareRefl 17 | , testProperty "anti-symmetric" modelUnorderedCompareAntiSymm 18 | , testProperty "transitive" modelUnorderedCompareTrans 19 | ] 20 | ] 21 | 22 | pIsPermutation :: [Char] -> [Int] -> Bool 23 | pIsPermutation xs is = isPermutationBy (==) xs xs' 24 | where 25 | is' = nub is ++ [maximum (0:is) + 1 ..] 26 | xs' = map fst . sortBy (comparing snd) $ zip xs is' 27 | 28 | pIsPermutationDiffLength :: [Int] -> [Int] -> Property 29 | pIsPermutationDiffLength xs ys = 30 | length xs /= length ys ==> isPermutationBy (==) xs ys === False 31 | 32 | -- | Homogenous version of 'unorderedCompare' 33 | -- 34 | -- *Compare smallest non-equal elements of the two lists*. 35 | modelUnorderedCompare :: Ord a => [a] -> [a] -> Ordering 36 | modelUnorderedCompare as bs = compare (sort as) (sort bs) 37 | 38 | modelUnorderedCompareRefl :: [Int] -> Property 39 | modelUnorderedCompareRefl xs = modelUnorderedCompare xs xs === EQ 40 | 41 | modelUnorderedCompareAntiSymm :: [Int] -> [Int] -> Property 42 | modelUnorderedCompareAntiSymm xs ys = case a of 43 | EQ -> b === EQ 44 | LT -> b === GT 45 | GT -> b === LT 46 | where 47 | a = modelUnorderedCompare xs ys 48 | b = modelUnorderedCompare ys xs 49 | 50 | modelUnorderedCompareTrans :: [Int] -> [Int] -> [Int] -> Property 51 | modelUnorderedCompareTrans xs ys zs = 52 | case (modelUnorderedCompare xs ys, modelUnorderedCompare ys zs) of 53 | (EQ, yz) -> xz === yz 54 | (xy, EQ) -> xz === xy 55 | (LT, LT) -> xz === LT 56 | (GT, GT) -> xz === GT 57 | (LT, GT) -> property True 58 | (GT, LT) -> property True 59 | where 60 | xz = modelUnorderedCompare xs zs 61 | 62 | pUnorderedCompare :: [Int] -> [Int] -> Property 63 | pUnorderedCompare xs ys = 64 | unorderedCompare compare xs ys === modelUnorderedCompare xs ys 65 | -------------------------------------------------------------------------------- /tests/Regressions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE UnboxedTuples #-} 6 | module Regressions (tests) where 7 | 8 | import Control.Exception (evaluate) 9 | import Control.Monad (replicateM) 10 | import Data.Bits (shiftL) 11 | import Data.Hashable (Hashable (..)) 12 | import Data.List (delete) 13 | import Data.Maybe (isJust, isNothing) 14 | import GHC.Exts (touch#) 15 | import GHC.IO (IO (..)) 16 | import Numeric.Natural (Natural) 17 | import System.Mem (performGC) 18 | import System.Mem.Weak (deRefWeak, mkWeakPtr) 19 | import System.Random (randomIO) 20 | import Test.HUnit (Assertion, assert) 21 | import Test.QuickCheck 22 | import Test.Tasty (TestTree, testGroup) 23 | import Test.Tasty.HUnit (testCase) 24 | import Test.Tasty.QuickCheck (testProperty) 25 | 26 | import qualified Data.HashMap.Lazy as HML 27 | import qualified Data.HashMap.Strict as HMS 28 | import qualified Data.HashSet as HS 29 | 30 | #if MIN_VERSION_base(4,12,0) 31 | -- nothunks requires base >= 4.12 32 | #define HAVE_NOTHUNKS 33 | import qualified Data.Foldable as Foldable 34 | import NoThunks.Class (noThunksInValues) 35 | #endif 36 | 37 | issue32 :: Assertion 38 | issue32 = assert $ isJust $ HMS.lookup 7 m' 39 | where 40 | ns = [0..16] :: [Int] 41 | m = HMS.fromList (zip ns (repeat [])) 42 | m' = HMS.delete 10 m 43 | 44 | ------------------------------------------------------------------------ 45 | -- Issue #39 46 | 47 | -- First regression 48 | 49 | issue39 :: Assertion 50 | issue39 = assert $ hm1 == hm2 51 | where 52 | hm1 = HMS.fromList ([a, b] `zip` [1, 1 :: Int ..]) 53 | hm2 = HMS.fromList ([b, a] `zip` [1, 1 :: Int ..]) 54 | a = (1, -1) :: (Int, Int) 55 | b = (-1, 1) :: (Int, Int) 56 | 57 | -- Second regression 58 | 59 | newtype Keys = Keys [Int] 60 | deriving Show 61 | 62 | instance Arbitrary Keys where 63 | arbitrary = sized $ \l -> do 64 | pis <- replicateM (l+1) positiveInt 65 | return (Keys $ prefixSum pis) 66 | 67 | shrink (Keys ls) = 68 | let l = length ls 69 | in if l == 1 70 | then [] 71 | else [ Keys (dropAt i ls) | i <- [0..l-1] ] 72 | 73 | positiveInt :: Gen Int 74 | positiveInt = (+1) . abs <$> arbitrary 75 | 76 | prefixSum :: [Int] -> [Int] 77 | prefixSum = loop 0 78 | where 79 | loop _ [] = [] 80 | loop prefix (l:ls) = let n = l + prefix 81 | in n : loop n ls 82 | 83 | dropAt :: Int -> [a] -> [a] 84 | dropAt _ [] = [] 85 | dropAt i (l:ls) | i == 0 = ls 86 | | otherwise = l : dropAt (i-1) ls 87 | 88 | propEqAfterDelete :: Keys -> Bool 89 | propEqAfterDelete (Keys keys) = 90 | let keyMap = mapFromKeys keys 91 | k = head keys 92 | in HMS.delete k keyMap == mapFromKeys (delete k keys) 93 | 94 | mapFromKeys :: [Int] -> HMS.HashMap Int () 95 | mapFromKeys keys = HMS.fromList (zip keys (repeat ())) 96 | 97 | ------------------------------------------------------------------------ 98 | -- Issue #254 99 | 100 | -- Key type that always collides. 101 | newtype KC = KC Int 102 | deriving (Eq, Ord, Show) 103 | instance Hashable KC where 104 | hashWithSalt salt _ = salt 105 | 106 | touch :: a -> IO () 107 | touch a = IO (\s -> (# touch# a s, () #)) 108 | 109 | -- We want to make sure that old values in the HashMap are evicted when new values are inserted, 110 | -- even if they aren't evaluated. To do that, we use the WeakPtr trick described at 111 | -- http://simonmar.github.io/posts/2018-06-20-Finding-fixing-space-leaks.html. 112 | -- We insert a value named oldV into the HashMap, then insert over it, checking oldV is no longer reachable. 113 | -- 114 | -- To make the test robust, it's important that oldV isn't hoisted up to the top or shared. 115 | -- To do that, we generate it randomly. 116 | issue254Lazy :: Assertion 117 | issue254Lazy = do 118 | i :: Int <- randomIO 119 | let oldV = error $ "Should not be evaluated: " ++ show i 120 | weakV <- mkWeakPtr oldV Nothing -- add the ability to test whether oldV is alive 121 | mp <- evaluate $ HML.insert (KC 1) (error "Should not be evaluated") $ HML.fromList [(KC 0, "1"), (KC 1, oldV)] 122 | performGC 123 | res <- deRefWeak weakV -- gives Just if oldV is still alive 124 | touch mp -- makes sure that we didn't GC away the whole HashMap, just oldV 125 | assert $ isNothing res 126 | 127 | -- Like issue254Lazy, but using strict HashMap 128 | issue254Strict :: Assertion 129 | issue254Strict = do 130 | i :: Int <- randomIO 131 | let oldV = show i 132 | weakV <- mkWeakPtr oldV Nothing 133 | mp <- evaluate $ HMS.insert (KC 1) "3" $ HMS.fromList [(KC 0, "1"), (KC 1, oldV)] 134 | performGC 135 | res <- deRefWeak weakV 136 | touch mp 137 | assert $ isNothing res 138 | 139 | ------------------------------------------------------------------------ 140 | -- Issue #379 141 | 142 | #ifdef HAVE_NOTHUNKS 143 | 144 | issue379Union :: Assertion 145 | issue379Union = do 146 | let m0 = HMS.fromList [(KC 1, ()), (KC 2, ())] 147 | let m1 = HMS.fromList [(KC 2, ()), (KC 3, ())] 148 | let u = m0 `HMS.union` m1 149 | mThunkInfo <- noThunksInValues mempty (Foldable.toList u) 150 | assert $ isNothing mThunkInfo 151 | 152 | issue379StrictUnionWith :: Assertion 153 | issue379StrictUnionWith = do 154 | let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)] 155 | let m1 = HMS.fromList [(KC 2, 20), (KC 3, 30)] 156 | let u = HMS.unionWith (+) m0 m1 157 | mThunkInfo <- noThunksInValues mempty (Foldable.toList u) 158 | assert $ isNothing mThunkInfo 159 | 160 | issue379StrictUnionWithKey :: Assertion 161 | issue379StrictUnionWithKey = do 162 | let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)] 163 | let m1 = HMS.fromList [(KC 2, 20), (KC 3, 30)] 164 | let u = HMS.unionWithKey (\(KC i) v0 v1 -> i + v0 + v1) m0 m1 165 | mThunkInfo <- noThunksInValues mempty (Foldable.toList u) 166 | assert $ isNothing mThunkInfo 167 | 168 | #endif 169 | 170 | -- Another key type that always collides. 171 | -- 172 | -- Note (sjakobi): The KC newtype of Int somehow can't be used to demonstrate 173 | -- the space leak in issue379LazyUnionWith. This type does the trick. 174 | newtype SC = SC String 175 | deriving (Eq, Ord, Show) 176 | instance Hashable SC where 177 | hashWithSalt salt _ = salt 178 | 179 | issue379LazyUnionWith :: Assertion 180 | issue379LazyUnionWith = do 181 | i :: Int <- randomIO 182 | let k = SC (show i) 183 | weakK <- mkWeakPtr k Nothing -- add the ability to test whether k is alive 184 | let f :: Int -> Int 185 | f x = error ("Should not be evaluated " ++ show x) 186 | let m = HML.fromList [(SC "1", f 1), (SC "2", f 2), (k, f 3)] 187 | let u = HML.unionWith (+) m m 188 | Just v <- evaluate $ HML.lookup k u 189 | performGC 190 | res <- deRefWeak weakK -- gives Just if k is still alive 191 | touch v -- makes sure that we didn't GC away the combined value 192 | assert $ isNothing res 193 | 194 | ------------------------------------------------------------------------ 195 | -- Issue #381 196 | 197 | #ifdef HAVE_NOTHUNKS 198 | 199 | issue381mapMaybe :: Assertion 200 | issue381mapMaybe = do 201 | let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)] 202 | let m1 = HMS.mapMaybe (Just . (+ 1)) m0 203 | mThunkInfo <- noThunksInValues mempty (Foldable.toList m1) 204 | assert $ isNothing mThunkInfo 205 | 206 | issue381mapMaybeWithKey :: Assertion 207 | issue381mapMaybeWithKey = do 208 | let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)] 209 | let m1 = HMS.mapMaybeWithKey (\(KC k) v -> Just (k + v)) m0 210 | mThunkInfo <- noThunksInValues mempty (Foldable.toList m1) 211 | assert $ isNothing mThunkInfo 212 | 213 | #endif 214 | 215 | ------------------------------------------------------------------------ 216 | -- Issue #382 217 | 218 | issue382 :: Assertion 219 | issue382 = do 220 | i :: Int <- randomIO 221 | let k = SC (show i) 222 | weakK <- mkWeakPtr k Nothing -- add the ability to test whether k is alive 223 | let f :: Int -> Int -> Int 224 | f x = error ("Should not be evaluated " ++ show x) 225 | let m = HML.fromListWith f [(k, 1), (k, 2)] 226 | Just v <- evaluate $ HML.lookup k m 227 | performGC 228 | res <- deRefWeak weakK -- gives Just if k is still alive 229 | touch v -- makes sure that we didn't GC away the combined value 230 | assert $ isNothing res 231 | 232 | ------------------------------------------------------------------------ 233 | -- Issue #383 234 | 235 | #ifdef HAVE_NOTHUNKS 236 | 237 | -- Custom Functor to prevent interference from alterF rules 238 | newtype MyIdentity a = MyIdentity a 239 | instance Functor MyIdentity where 240 | fmap f (MyIdentity x) = MyIdentity (f x) 241 | 242 | issue383 :: Assertion 243 | issue383 = do 244 | i :: Int <- randomIO 245 | let f Nothing = MyIdentity (Just (fromIntegral @Int @Natural (abs i))) 246 | f Just{} = MyIdentity (error "Impossible") 247 | let (MyIdentity m) = HMS.alterF f () mempty 248 | mThunkInfo <- noThunksInValues mempty (Foldable.toList m) 249 | assert $ isNothing mThunkInfo 250 | 251 | #endif 252 | 253 | ------------------------------------------------------------------------ 254 | -- Issue #420 255 | 256 | issue420 :: Assertion 257 | issue420 = do 258 | let k1 :: Int = 1 `shiftL` 10 259 | let k2 :: Int = 2 `shiftL` 10 260 | let s0 = HS.fromList [k1, k2] 261 | let s1 = s0 `HS.intersection` s0 262 | assert $ k1 `HS.member` s1 263 | assert $ k2 `HS.member` s1 264 | 265 | ------------------------------------------------------------------------ 266 | -- * Test list 267 | 268 | tests :: TestTree 269 | tests = testGroup "Regression tests" 270 | [ 271 | testCase "issue32" issue32 272 | , testCase "issue39a" issue39 273 | , testProperty "issue39b" propEqAfterDelete 274 | , testCase "issue254 lazy" issue254Lazy 275 | , testCase "issue254 strict" issue254Strict 276 | , testGroup "issue379" 277 | [ testCase "Lazy.unionWith" issue379LazyUnionWith 278 | #ifdef HAVE_NOTHUNKS 279 | , testCase "union" issue379Union 280 | , testCase "Strict.unionWith" issue379StrictUnionWith 281 | , testCase "Strict.unionWithKey" issue379StrictUnionWithKey 282 | #endif 283 | ] 284 | #ifdef HAVE_NOTHUNKS 285 | , testGroup "issue381" 286 | [ testCase "mapMaybe" issue381mapMaybe 287 | , testCase "mapMaybeWithKey" issue381mapMaybeWithKey 288 | ] 289 | #endif 290 | , testCase "issue382" issue382 291 | #ifdef HAVE_NOTHUNKS 292 | , testCase "issue383" issue383 293 | #endif 294 | , testCase "issue420" issue420 295 | ] 296 | -------------------------------------------------------------------------------- /tests/Strictness.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v) 2 | 3 | module Strictness (tests) where 4 | 5 | import Control.Arrow (second) 6 | import Control.Monad (guard) 7 | import Data.Foldable (foldl') 8 | import Data.Hashable (Hashable) 9 | import Data.HashMap.Strict (HashMap) 10 | import Data.Maybe (fromMaybe, isJust) 11 | import Test.ChasingBottoms.IsBottom 12 | import Test.QuickCheck (Arbitrary (..), Property, (.&&.), (===)) 13 | import Test.QuickCheck.Function 14 | import Test.QuickCheck.Poly (A) 15 | import Test.Tasty (TestTree, testGroup) 16 | import Test.Tasty.QuickCheck (testProperty) 17 | import Text.Show.Functions () 18 | import Util.Key (Key) 19 | 20 | import qualified Data.HashMap.Strict as HM 21 | 22 | instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where 23 | arbitrary = HM.fromList <$> arbitrary 24 | shrink = fmap HM.fromList . shrink . HM.toList 25 | 26 | ------------------------------------------------------------------------ 27 | -- * Properties 28 | 29 | ------------------------------------------------------------------------ 30 | -- ** Strict module 31 | 32 | pSingletonKeyStrict :: Int -> Bool 33 | pSingletonKeyStrict v = isBottom $ HM.singleton (bottom :: Key) v 34 | 35 | pSingletonValueStrict :: Key -> Bool 36 | pSingletonValueStrict k = isBottom $ HM.singleton k (bottom :: Int) 37 | 38 | pLookupDefaultKeyStrict :: Int -> HashMap Key Int -> Bool 39 | pLookupDefaultKeyStrict def m = isBottom $ HM.lookupDefault def bottom m 40 | 41 | pFindWithDefaultKeyStrict :: Int -> HashMap Key Int -> Bool 42 | pFindWithDefaultKeyStrict def m = isBottom $ HM.findWithDefault def bottom m 43 | 44 | pAdjustKeyStrict :: (Int -> Int) -> HashMap Key Int -> Bool 45 | pAdjustKeyStrict f m = isBottom $ HM.adjust f bottom m 46 | 47 | pAdjustValueStrict :: Key -> HashMap Key Int -> Bool 48 | pAdjustValueStrict k m 49 | | k `HM.member` m = isBottom $ HM.adjust (const bottom) k m 50 | | otherwise = case HM.keys m of 51 | [] -> True 52 | (k':_) -> isBottom $ HM.adjust (const bottom) k' m 53 | 54 | pInsertKeyStrict :: Int -> HashMap Key Int -> Bool 55 | pInsertKeyStrict v m = isBottom $ HM.insert bottom v m 56 | 57 | pInsertValueStrict :: Key -> HashMap Key Int -> Bool 58 | pInsertValueStrict k m = isBottom $ HM.insert k bottom m 59 | 60 | pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> HashMap Key Int -> Bool 61 | pInsertWithKeyStrict f v m = isBottom $ HM.insertWith f bottom v m 62 | 63 | pInsertWithValueStrict :: (Int -> Int -> Int) -> Key -> Int -> HashMap Key Int 64 | -> Bool 65 | pInsertWithValueStrict f k v m 66 | | HM.member k m = isBottom $ HM.insertWith (const2 bottom) k v m 67 | | otherwise = isBottom $ HM.insertWith f k bottom m 68 | 69 | pFromListKeyStrict :: Bool 70 | pFromListKeyStrict = isBottom $ HM.fromList [(undefined :: Key, 1 :: Int)] 71 | 72 | pFromListValueStrict :: Key -> Bool 73 | pFromListValueStrict k = isBottom $ HM.fromList [(k, undefined)] 74 | 75 | pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool 76 | pFromListWithKeyStrict f = 77 | isBottom $ HM.fromListWith f [(undefined :: Key, 1 :: Int)] 78 | 79 | -- The strictness properties of 'fromListWith' are not entirely 80 | -- trivial. 81 | -- fromListWith f kvs is strict in the first value seen for each 82 | -- key, but potentially lazy in the rest: the combining function 83 | -- could be lazy in the "new" value. fromListWith must, however, 84 | -- be strict in whatever value is actually inserted into the map. 85 | -- Getting all these properties specified efficiently seems tricky. 86 | -- Since it's not hard, we verify that the converted HashMap has 87 | -- no unforced values. Rather than trying to go into detail for the 88 | -- rest, this test compares the strictness behavior of fromListWith 89 | -- to that of insertWith. The latter should be easier to specify 90 | -- and (if we choose to do so) test thoroughly. 91 | -- 92 | -- We'll fake up a representation of things that are possibly 93 | -- bottom by using Nothing to represent bottom. The combining 94 | -- (partial) function is represented by a "lazy total" function 95 | -- Maybe a -> Maybe a -> Maybe a, along with a function determining 96 | -- whether the result should be non-bottom, Maybe a -> Maybe a -> Bool, 97 | -- indicating how the combining function should behave if neither 98 | -- argument, just the first argument, just the second argument, 99 | -- or both arguments are bottom. It would be quite tempting to 100 | -- just use Maybe A -> Maybe A -> Maybe A, but that would not 101 | -- necessarily be continuous. 102 | pFromListWithValueResultStrict :: [(Key, Maybe A)] 103 | -> Fun (Maybe A, Maybe A) A 104 | -> Fun (Maybe A, Maybe A) Bool 105 | -> Property 106 | pFromListWithValueResultStrict lst comb_lazy calc_good_raw 107 | = all (all isJust) recovered .&&. (recovered === recover (fmap recover fake_map)) 108 | where 109 | recovered :: Maybe (HashMap Key (Maybe A)) 110 | recovered = recover (fmap recover real_map) 111 | -- What we get out of the conversion using insertWith 112 | fake_map = foldl' (\m (k,v) -> HM.insertWith real_comb k v m) HM.empty real_list 113 | 114 | -- A continuous version of calc_good_raw 115 | calc_good Nothing Nothing = cgr Nothing Nothing 116 | calc_good Nothing y@(Just _) = cgr Nothing Nothing || cgr Nothing y 117 | calc_good x@(Just _) Nothing = cgr Nothing Nothing || cgr x Nothing 118 | calc_good x y = cgr Nothing Nothing || cgr Nothing y || cgr x Nothing || cgr x y 119 | cgr = curry $ apply calc_good_raw 120 | 121 | -- The Maybe A -> Maybe A -> Maybe A that we're after, representing a 122 | -- potentially less total function than comb_lazy 123 | comb x y = apply comb_lazy (x, y) <$ guard (calc_good x y) 124 | 125 | -- What we get out of the conversion using fromListWith 126 | real_map = HM.fromListWith real_comb real_list 127 | 128 | -- A list that may have actual bottom values in it. 129 | real_list = map (second (fromMaybe bottom)) lst 130 | 131 | -- A genuinely partial function mirroring comb 132 | real_comb x y = fromMaybe bottom $ comb (recover x) (recover y) 133 | 134 | recover :: a -> Maybe a 135 | recover a = a <$ guard (not $ isBottom a) 136 | 137 | ------------------------------------------------------------------------ 138 | -- * Test list 139 | 140 | tests :: TestTree 141 | tests = testGroup "Strictness" 142 | [ 143 | -- Basic interface 144 | testGroup "HashMap.Strict" 145 | [ testProperty "singleton is key-strict" pSingletonKeyStrict 146 | , testProperty "singleton is value-strict" pSingletonValueStrict 147 | , testProperty "member is key-strict" $ keyStrict HM.member 148 | , testProperty "lookup is key-strict" $ keyStrict HM.lookup 149 | , testProperty "lookupDefault is key-strict" pLookupDefaultKeyStrict 150 | , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict 151 | , testProperty "! is key-strict" $ keyStrict (flip (HM.!)) 152 | , testProperty "delete is key-strict" $ keyStrict HM.delete 153 | , testProperty "adjust is key-strict" pAdjustKeyStrict 154 | , testProperty "adjust is value-strict" pAdjustValueStrict 155 | , testProperty "insert is key-strict" pInsertKeyStrict 156 | , testProperty "insert is value-strict" pInsertValueStrict 157 | , testProperty "insertWith is key-strict" pInsertWithKeyStrict 158 | , testProperty "insertWith is value-strict" pInsertWithValueStrict 159 | , testProperty "fromList is key-strict" pFromListKeyStrict 160 | , testProperty "fromList is value-strict" pFromListValueStrict 161 | , testProperty "fromListWith is key-strict" pFromListWithKeyStrict 162 | , testProperty "fromListWith is value-strict" pFromListWithValueResultStrict 163 | ] 164 | ] 165 | 166 | ------------------------------------------------------------------------ 167 | -- * Utilities 168 | 169 | keyStrict :: (Key -> HashMap Key Int -> a) -> HashMap Key Int -> Bool 170 | keyStrict f m = isBottom $ f bottom m 171 | 172 | const2 :: a -> b -> c -> a 173 | const2 x _ _ = x 174 | -------------------------------------------------------------------------------- /tests/Util/Key.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Util.Key (Key(..), keyToInt, incKey, collisionAtHash) where 6 | 7 | import Data.Bits (bit, (.&.)) 8 | import Data.Hashable (Hashable (hashWithSalt)) 9 | import Data.Word (Word16) 10 | import GHC.Generics (Generic) 11 | import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Function, Gen, Large) 12 | 13 | import qualified Test.QuickCheck as QC 14 | 15 | -- Key type that generates more hash collisions. 16 | data Key = K 17 | { hash :: !Int 18 | -- ^ The hash of the key 19 | , _x :: !SmallSum 20 | -- ^ Additional data, so we can have collisions for any hash 21 | } deriving (Eq, Ord, Read, Show, Generic, Function, CoArbitrary) 22 | 23 | instance Hashable Key where 24 | hashWithSalt _ (K h _) = h 25 | 26 | data SmallSum = A | B | C | D 27 | deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded, Function, CoArbitrary) 28 | 29 | instance Arbitrary SmallSum where 30 | arbitrary = QC.arbitraryBoundedEnum 31 | shrink = shrinkSmallSum 32 | 33 | shrinkSmallSum :: SmallSum -> [SmallSum] 34 | shrinkSmallSum A = [] 35 | shrinkSmallSum B = [A] 36 | shrinkSmallSum C = [A, B] 37 | shrinkSmallSum D = [A, B, C] 38 | 39 | instance Arbitrary Key where 40 | arbitrary = K <$> arbitraryHash <*> arbitrary 41 | shrink = QC.genericShrink 42 | 43 | arbitraryHash :: Gen Int 44 | arbitraryHash = do 45 | let gens = 46 | [ (2, fromIntegral . QC.getLarge <$> arbitrary @(Large Word16)) 47 | , (1, QC.getSmall <$> arbitrary) 48 | , (1, QC.getLarge <$> arbitrary) 49 | ] 50 | i <- QC.frequency gens 51 | moreCollisions' <- QC.elements [moreCollisions, id] 52 | pure (moreCollisions' i) 53 | 54 | -- | Mask out most bits to produce more collisions 55 | moreCollisions :: Int -> Int 56 | moreCollisions w = fromIntegral (w .&. mask) 57 | 58 | mask :: Int 59 | mask = sum [bit n | n <- [0, 3, 8, 14, 61]] 60 | 61 | keyToInt :: Key -> Int 62 | keyToInt (K h x) = h * fromEnum x 63 | 64 | incKey :: Key -> Key 65 | incKey (K h x) = K (h + 1) x 66 | 67 | -- | 4 colliding keys at a given hash. 68 | collisionAtHash :: Int -> (Key, Key, Key, Key) 69 | collisionAtHash h = (K h A, K h B, K h C, K h D) 70 | -------------------------------------------------------------------------------- /unordered-containers.cabal: -------------------------------------------------------------------------------- 1 | name: unordered-containers 2 | version: 0.2.20 3 | synopsis: Efficient hashing-based container types 4 | description: 5 | Efficient hashing-based container types. The containers have been 6 | optimized for performance critical use, both in terms of large data 7 | quantities and high speed. 8 | . 9 | The declared cost of each operation is either worst-case or 10 | amortized, but remains valid even if structures are shared. 11 | . 12 | /Security/ 13 | . 14 | This package currently provides no defenses against hash collision attacks 15 | such as HashDoS. 16 | Users who need to store input from untrusted sources are advised to use 17 | @Data.Map@ or @Data.Set@ from the @containers@ package instead. 18 | license: BSD3 19 | license-file: LICENSE 20 | author: Johan Tibell 21 | maintainer: simon.jakobi@gmail.com, David.Feuer@gmail.com 22 | Homepage: https://github.com/haskell-unordered-containers/unordered-containers 23 | bug-reports: https://github.com/haskell-unordered-containers/unordered-containers/issues 24 | copyright: 2010-2014 Johan Tibell 25 | 2010 Edward Z. Yang 26 | category: Data 27 | build-type: Simple 28 | cabal-version: >=1.10 29 | extra-source-files: CHANGES.md 30 | 31 | tested-with: 32 | GHC ==9.12.2 33 | || ==9.10.2 34 | || ==9.8.4 35 | || ==9.6.7 36 | || ==9.4.8 37 | || ==9.2.8 38 | || ==9.0.2 39 | || ==8.10.7 40 | || ==8.8.4 41 | || ==8.6.5 42 | || ==8.4.4 43 | || ==8.2.2 44 | 45 | flag debug 46 | description: Enable debug support 47 | default: False 48 | 49 | library 50 | exposed-modules: 51 | Data.HashMap.Internal 52 | Data.HashMap.Internal.Array 53 | Data.HashMap.Internal.Debug 54 | Data.HashMap.Internal.List 55 | Data.HashMap.Internal.Strict 56 | Data.HashMap.Lazy 57 | Data.HashMap.Strict 58 | Data.HashSet 59 | Data.HashSet.Internal 60 | 61 | build-depends: 62 | base >= 4.10 && < 5, 63 | deepseq >= 1.4.3, 64 | hashable >= 1.2.5 && < 1.6, 65 | template-haskell < 2.24 66 | 67 | default-language: Haskell2010 68 | 69 | other-extensions: 70 | RoleAnnotations, 71 | UnboxedTuples, 72 | ScopedTypeVariables, 73 | MagicHash, 74 | BangPatterns 75 | 76 | ghc-options: -Wall -O2 -fwarn-tabs -ferror-spans 77 | 78 | -- For dumping the generated code: 79 | -- ghc-options: -ddump-simpl -ddump-stg-final -ddump-cmm -ddump-asm -ddump-to-file 80 | -- ghc-options: -dsuppress-coercions -dsuppress-unfoldings -dsuppress-module-prefixes 81 | -- ghc-options: -dsuppress-uniques -dsuppress-timestamps 82 | 83 | if flag(debug) 84 | cpp-options: -DASSERTS 85 | 86 | test-suite unordered-containers-tests 87 | hs-source-dirs: tests 88 | main-is: Main.hs 89 | type: exitcode-stdio-1.0 90 | other-modules: 91 | Regressions 92 | Properties 93 | Properties.HashMapLazy 94 | Properties.HashMapStrict 95 | Properties.HashSet 96 | Properties.List 97 | Strictness 98 | Util.Key 99 | 100 | build-depends: 101 | base, 102 | ChasingBottoms, 103 | containers >= 0.5.8, 104 | hashable, 105 | HUnit, 106 | QuickCheck >= 2.4.0.1, 107 | random, 108 | tasty >= 1.4.0.3, 109 | tasty-hunit >= 0.10.0.3, 110 | tasty-quickcheck >= 0.10.1.2, 111 | unordered-containers 112 | 113 | if impl(ghc >= 8.6) 114 | build-depends: 115 | nothunks >= 0.1.3 116 | 117 | default-language: Haskell2010 118 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 119 | cpp-options: -DASSERTS 120 | 121 | benchmark benchmarks 122 | hs-source-dirs: benchmarks 123 | main-is: Benchmarks.hs 124 | type: exitcode-stdio-1.0 125 | 126 | other-modules: 127 | Util.ByteString 128 | Util.String 129 | Util.Int 130 | 131 | build-depends: 132 | base >= 4.8.0, 133 | bytestring >= 0.10.0.0, 134 | containers, 135 | deepseq, 136 | hashable, 137 | hashmap, 138 | mtl, 139 | random, 140 | tasty-bench >= 0.3.1, 141 | unordered-containers 142 | 143 | default-language: Haskell2010 144 | ghc-options: -Wall -O2 -rtsopts -with-rtsopts=-A32m 145 | if impl(ghc >= 8.10) 146 | ghc-options: "-with-rtsopts=-A32m --nonmoving-gc" 147 | -- cpp-options: -DBENCH_containers_Map -DBENCH_containers_IntMap -DBENCH_hashmap_Map 148 | 149 | source-repository head 150 | type: git 151 | location: https://github.com/haskell-unordered-containers/unordered-containers.git 152 | -------------------------------------------------------------------------------- /utils/Stats.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# OPTIONS_GHC -funbox-strict-fields #-} 4 | module Stats where 5 | 6 | import Data.HashMap.Internal (HashMap (..)) 7 | import Data.Semigroup 8 | 9 | import qualified Data.HashMap.Internal as HM 10 | import qualified Data.HashMap.Internal.Array as A 11 | 12 | data Histogram = H { 13 | empty :: !Int 14 | , leaf :: !Int 15 | , bitmapIndexed :: !Int 16 | , full :: !Int 17 | , collision :: !Int 18 | } deriving Show 19 | 20 | instance Semigroup Histogram where 21 | h1 <> h2 = H { 22 | empty = empty h1 + empty h2 23 | , leaf = leaf h1 + leaf h2 24 | , bitmapIndexed = bitmapIndexed h1 + bitmapIndexed h2 25 | , full = full h1 + full h2 26 | , collision = collision h1 + collision h2 27 | } 28 | 29 | instance Monoid Histogram where 30 | mempty = H 0 0 0 0 0 31 | 32 | -- | Count the number of node types at each level 33 | nodeHistogram :: HM.HashMap k v -> [Histogram] 34 | nodeHistogram Empty = [mempty { empty = 1 }] 35 | nodeHistogram (Leaf {}) = [mempty { leaf = 1 }] 36 | nodeHistogram (BitmapIndexed _ ary) = 37 | mempty { bitmapIndexed = 1 } : 38 | A.foldl' (\ xs -> zipWith_ merge xs . nodeHistogram) [] ary 39 | nodeHistogram (Full ary) = 40 | mempty { full = 1 } : 41 | A.foldl' (\ xs -> zipWith_ merge xs . nodeHistogram) [] ary 42 | nodeHistogram (Collision {}) = [mempty { collision = 1 }] 43 | 44 | merge (Just h1) (Just h2) = h1 `mappend` h2 45 | merge (Just h) Nothing = h `mappend` mempty 46 | merge Nothing (Just h) = mempty `mappend` h 47 | merge Nothing Nothing = error "impossible" 48 | 49 | zipWith_ :: (Maybe a -> Maybe b -> c) -> [a] -> [b] -> [c] 50 | zipWith_ f = go 51 | where 52 | go [] [] = [] 53 | go [] (y:ys) = let z = f Nothing (Just y) in z `seq` (z : go [] ys) 54 | go (x:xs) [] = let z = f (Just x) Nothing in z `seq` (z : go xs []) 55 | go (x:xs) (y:ys) = let z = f (Just x) (Just y) in z `seq` (z : go xs ys) 56 | {-# INLINE zipWith_ #-} 57 | 58 | ppHistogram :: [Histogram] -> String 59 | ppHistogram = go 0 60 | where 61 | go _ [] = "" 62 | go lvl ((H {..}):hs) = 63 | indent ++ "empty: " ++ show empty ++ "\n" ++ 64 | indent ++ "leaf: " ++ show leaf ++ "\n" ++ 65 | indent ++ "bitmapIndexed: " ++ show bitmapIndexed ++ "\n" ++ 66 | indent ++ "full: " ++ show full ++ "\n" ++ 67 | indent ++ "collision: " ++ show collision ++ "\n" ++ 68 | go (lvl+2) hs 69 | where indent = replicate lvl ' ' 70 | --------------------------------------------------------------------------------