├── .envrc ├── .github └── workflows │ ├── flake-ci.yml │ └── haskell.yml ├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── nonempty-containers.cabal ├── src └── Data │ ├── Containers │ └── NonEmpty.hs │ ├── IntMap │ ├── NonEmpty.hs │ └── NonEmpty │ │ └── Internal.hs │ ├── IntSet │ ├── NonEmpty.hs │ └── NonEmpty │ │ └── Internal.hs │ ├── Map │ ├── NonEmpty.hs │ └── NonEmpty │ │ └── Internal.hs │ ├── Sequence │ ├── NonEmpty.hs │ └── NonEmpty │ │ └── Internal.hs │ └── Set │ ├── NonEmpty.hs │ └── NonEmpty │ └── Internal.hs └── test ├── Spec.hs └── Tests ├── IntMap.hs ├── IntSet.hs ├── Map.hs ├── Sequence.hs ├── Set.hs └── Util.hs /.envrc: -------------------------------------------------------------------------------- 1 | nix_direnv_manual_reload 2 | watch_file ./*.cabal 3 | use flake 4 | -------------------------------------------------------------------------------- /.github/workflows/flake-ci.yml: -------------------------------------------------------------------------------- 1 | name: "Flake CI" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | checks: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - name: Free Disk Space 10 | uses: insightsengineering/free-disk-space@v1.1.0 11 | - uses: actions/checkout@v3 12 | - uses: webfactory/ssh-agent@v0.9.0 13 | with: 14 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 15 | - uses: cachix/install-nix-action@v22 16 | with: 17 | nix_path: nixpkgs=channel:nixos-unstable 18 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 19 | extra_nix_config: | 20 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 21 | allow-import-from-derivation = true 22 | auto-optimise-store = true 23 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 24 | - uses: cachix/cachix-action@v13 25 | with: 26 | name: mstksg 27 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 28 | - run: nix flake check --show-trace 29 | 30 | cache: 31 | runs-on: ubuntu-latest 32 | steps: 33 | - name: Free Disk Space 34 | uses: insightsengineering/free-disk-space@v1.1.0 35 | - uses: actions/checkout@v4.1.1 36 | - uses: webfactory/ssh-agent@v0.9.0 37 | with: 38 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 39 | - uses: cachix/install-nix-action@v22 40 | with: 41 | nix_path: nixpkgs=channel:nixos-unstable 42 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 43 | extra_nix_config: | 44 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 45 | allow-import-from-derivation = true 46 | auto-optimise-store = true 47 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 48 | - uses: cachix/cachix-action@v13 49 | with: 50 | name: mstksg 51 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 52 | - run: nix build --show-trace 53 | - run: nix develop --show-trace 54 | 55 | every-compiler: 56 | runs-on: ubuntu-latest 57 | steps: 58 | - name: Free Disk Space 59 | uses: insightsengineering/free-disk-space@v1.1.0 60 | - uses: actions/checkout@v3 61 | - uses: webfactory/ssh-agent@v0.9.0 62 | with: 63 | ssh-private-key: ${{ secrets.SSH_PRIVATE_KEY }} 64 | - uses: cachix/install-nix-action@v22 65 | with: 66 | nix_path: nixpkgs=channel:nixos-unstable 67 | github_access_token: ${{ secrets.GITHUB_TOKEN }} 68 | extra_nix_config: | 69 | trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= 70 | allow-import-from-derivation = true 71 | auto-optimise-store = true 72 | substituters = https://hydra.iohk.io https://cache.nixos.org/ https://cache.iog.io https://cache.zw3rk.com https://mstksg.cachix.org 73 | - uses: cachix/cachix-action@v13 74 | with: 75 | name: mstksg 76 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 77 | - run: nix build .#everyCompiler 78 | 79 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | # Haskell stack project Github Actions template 2 | # https://gist.github.com/mstksg/11f753d891cee5980326a8ea8c865233 3 | # 4 | # To use, mainly change the list in 'plans' and modify 'include' for 5 | # any OS package manager deps. 6 | # 7 | # Currently not working for cabal-install >= 3 8 | # 9 | # Based on https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/travis-complex.yml 10 | # 11 | # TODO: 12 | # * cache (https://github.com/actions/cache) 13 | # but this is too small. native cacheing will come soon 14 | # https://github.community/t5/GitHub-Actions/Caching-files-between-GitHub-Action-executions/m-p/30974/highlight/true#M630 15 | # so we can wait for then. 16 | # * support for cabal-install >= 3 17 | 18 | name: Haskell Stack Project CI 19 | 20 | on: 21 | push: 22 | schedule: 23 | - cron: "0 0 * * 1" 24 | 25 | jobs: 26 | build: 27 | strategy: 28 | matrix: 29 | os: [ubuntu-latest, macOS-latest] 30 | # use this to specify what resolvers and ghc to use 31 | plan: 32 | # - { build: stack, resolver: "--resolver lts-9" } # ghc-8.0.2 33 | # - { build: stack, resolver: "--resolver lts-11" } # ghc-8.2.2 34 | - { build: stack, resolver: "--resolver lts-12" } # ghc-8.4.4 35 | # - { build: stack, resolver: "--resolver lts-13" } redundant because lts-14 checks ghc-8.6 already 36 | - { build: stack, resolver: "--resolver lts-14" } # ghc-8.6.5 37 | - { build: stack, resolver: "--resolver nightly" } 38 | - { build: stack, resolver: "" } 39 | # - { build: cabal, ghc: 8.0.2, cabal-install: "2.0" } # setup-haskell only supports cabal-install 2.0 and higher 40 | - { build: cabal, ghc: 8.2.2, cabal-install: "2.0" } 41 | - { build: cabal, ghc: 8.4.4, cabal-install: "2.2" } 42 | - { build: cabal, ghc: 8.6.5, cabal-install: "2.4" } 43 | - { build: cabal, ghc: 8.8.1, cabal-install: "2.4" } # currently not working for >= 3.0 44 | # use this to include any dependencies from OS package managers 45 | include: 46 | # - os: macOS-latest 47 | # brew: anybrewdeps 48 | - os: ubuntu-latest 49 | apt-get: happy 50 | 51 | exclude: 52 | - os: macOS-latest 53 | plan: 54 | build: cabal 55 | 56 | runs-on: ${{ matrix.os }} 57 | steps: 58 | - name: Install OS Packages 59 | uses: mstksg/get-package@v1 60 | with: 61 | apt-get: ${{ matrix.apt-get }} 62 | brew: ${{ matrix.brew }} 63 | - uses: actions/checkout@v1 64 | 65 | - name: Setup stack 66 | uses: mstksg/setup-stack@v1 67 | 68 | - name: Setup cabal-install 69 | uses: actions/setup-haskell@v1 70 | with: 71 | ghc-version: ${{ matrix.plan.ghc }} 72 | cabal-version: ${{ matrix.plan.cabal-install }} 73 | if: matrix.plan.build == 'cabal' 74 | 75 | - name: Install dependencies 76 | run: | 77 | set -ex 78 | case "$BUILD" in 79 | stack) 80 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 81 | ;; 82 | cabal) 83 | cabal --version 84 | cabal update 85 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 86 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 87 | ;; 88 | esac 89 | set +ex 90 | env: 91 | ARGS: ${{ matrix.plan.resolver }} 92 | BUILD: ${{ matrix.plan.build }} 93 | 94 | - name: Build 95 | run: | 96 | set -ex 97 | case "$BUILD" in 98 | stack) 99 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 100 | ;; 101 | cabal) 102 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 103 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 104 | 105 | ORIGDIR=$(pwd) 106 | for dir in $PACKAGES 107 | do 108 | cd $dir 109 | cabal check || [ "$CABALVER" == "1.16" ] 110 | cabal sdist 111 | PKGVER=$(cabal info . | awk '{print $2;exit}') 112 | SRC_TGZ=$PKGVER.tar.gz 113 | cd dist 114 | tar zxfv "$SRC_TGZ" 115 | cd "$PKGVER" 116 | cabal configure --enable-tests --ghc-options -O0 117 | cabal build 118 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 119 | cabal test 120 | else 121 | cabal test --show-details=streaming --log=/dev/stdout 122 | fi 123 | cd $ORIGDIR 124 | done 125 | ;; 126 | esac 127 | set +ex 128 | env: 129 | ARGS: ${{ matrix.plan.resolver }} 130 | BUILD: ${{ matrix.plan.build }} 131 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | .ghc.environment.* 4 | dist-newstyle/ 5 | tags 6 | /.direnv 7 | /result 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | script: 2 | - | 3 | set -ex 4 | case "$BUILD" in 5 | stack) 6 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 7 | ;; 8 | cabal) 9 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 10 | 11 | ORIGDIR=$(pwd) 12 | for dir in $PACKAGES 13 | do 14 | cd $dir 15 | cabal check || [ "$CABALVER" == "1.16" ] 16 | cabal sdist 17 | PKGVER=$(cabal info . | awk '{print $2;exit}') 18 | SRC_TGZ=$PKGVER.tar.gz 19 | cd dist 20 | tar zxfv "$SRC_TGZ" 21 | cd "$PKGVER" 22 | cabal configure --enable-tests --ghc-options -O0 23 | cabal build 24 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 25 | cabal test 26 | else 27 | cabal test --show-details=streaming --log=/dev/stdout 28 | fi 29 | cd $ORIGDIR 30 | done 31 | ;; 32 | esac 33 | set +ex 34 | matrix: 35 | include: 36 | - env: BUILD=cabal GHCVER=8.4.4 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7 37 | addons: 38 | apt: 39 | sources: 40 | - hvr-ghc 41 | packages: 42 | - cabal-install-2.2 43 | - ghc-8.4.4 44 | - happy-1.19.5 45 | - alex-3.1.7 46 | compiler: ': #GHC 8.4.4' 47 | - env: BUILD=cabal GHCVER=8.6.5 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7 48 | addons: 49 | apt: 50 | sources: 51 | - hvr-ghc 52 | packages: 53 | - cabal-install-2.4 54 | - ghc-8.6.5 55 | - happy-1.19.5 56 | - alex-3.1.7 57 | compiler: ': #GHC 8.6.5' 58 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 59 | addons: 60 | apt: 61 | sources: 62 | - hvr-ghc 63 | packages: 64 | - cabal-install-head 65 | - ghc-head 66 | - happy-1.19.5 67 | - alex-3.1.7 68 | compiler: ': #GHC HEAD' 69 | - env: BUILD=stack ARGS="" 70 | addons: 71 | apt: 72 | packages: 73 | - libgmp-dev 74 | compiler: ': #stack default' 75 | - env: BUILD=stack ARGS="--resolver lts-12" 76 | addons: 77 | apt: 78 | packages: 79 | - libgmp-dev 80 | compiler: ': #stack 8.4.4' 81 | - env: BUILD=stack ARGS="--resolver lts-14" 82 | addons: 83 | apt: 84 | packages: 85 | - libgmp-dev 86 | compiler: ': #stack 8.6.5' 87 | - env: BUILD=stack ARGS="--resolver nightly" 88 | addons: 89 | apt: 90 | packages: 91 | - libgmp-dev 92 | compiler: ': #stack nightly' 93 | - env: BUILD=stack ARGS="" 94 | os: osx 95 | compiler: ': #stack default osx' 96 | - env: BUILD=stack ARGS="--resolver lts-12" 97 | os: osx 98 | compiler: ': #stack 8.4.4 osx' 99 | - env: BUILD=stack ARGS="--resolver lts-14" 100 | os: osx 101 | compiler: ': #stack 8.6.5 osx' 102 | - env: BUILD=stack ARGS="--resolver nightly" 103 | os: osx 104 | compiler: ': #stack nightly osx' 105 | allow_failures: 106 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 107 | - env: BUILD=stack ARGS="--resolver nightly" 108 | install: 109 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo 110 | '?')]" 111 | - if [ -f configure.ac ]; then autoreconf -i; fi 112 | - | 113 | set -ex 114 | case "$BUILD" in 115 | stack) 116 | # Add in extra-deps for older snapshots, as necessary 117 | # 118 | # This is disabled by default, as relying on the solver like this can 119 | # make builds unreliable. Instead, if you have this situation, it's 120 | # recommended that you maintain multiple stack-lts-X.yaml files. 121 | 122 | #stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ 123 | # stack --no-terminal $ARGS build cabal-install && \ 124 | # stack --no-terminal $ARGS solver --update-config) 125 | 126 | # Build the dependencies 127 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 128 | ;; 129 | cabal) 130 | cabal --version 131 | travis_retry cabal update 132 | 133 | # Get the list of packages from the stack.yaml file. Note that 134 | # this will also implicitly run hpack as necessary to generate 135 | # the .cabal files needed by cabal-install. 136 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 137 | 138 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 139 | ;; 140 | esac 141 | set +ex 142 | cache: 143 | directories: 144 | - $HOME/.ghc 145 | - $HOME/.cabal 146 | - $HOME/.stack 147 | - $TRAVIS_BUILD_DIR/.stack-work 148 | before_install: 149 | - unset CC 150 | - CABALARGS="" 151 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 152 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 153 | - mkdir -p ~/.local/bin 154 | - | 155 | if [ `uname` = "Darwin" ] 156 | then 157 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 158 | else 159 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 160 | fi 161 | 162 | # Use the more reliable S3 mirror of Hackage 163 | mkdir -p $HOME/.cabal 164 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 165 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 166 | language: generic 167 | sudo: false 168 | 169 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Changelog 2 | ========= 3 | 4 | Version 0.3.5.0 5 | --------------- 6 | 7 | *May 20, 2025* 8 | 9 | 10 | 11 | * Support *containers* 0.8 and drop support for *containers* < 0.6.3.1 12 | (@jonathanknowles) 13 | 14 | Version 0.3.4.x 15 | --------------- 16 | 17 | * **0.3.4.0**: `ToJSON` and `FromJSON` instances (*August 4, 2020*) 18 | * **0.3.4.1**: `Ord` instance to `NESeq` (@mitchelwrosen) (*August 22, 2020*) 19 | * **0.3.4.2**: Compatibility with GHC 9 (@andremarianiello) (*August 25, 2021*) 20 | * **0.3.4.3**: (*August 25, 2021*) 21 | * Fix `intersperse` for singleton non-empty sequences. (@eddiemundo) 22 | * Fix `deleteMax` for singleton containers. 23 | * **0.3.4.4**: (*September 25, 2021*) 24 | * `Alt` instances for `NEMap` and `NEIntMap` 25 | * `Invariant` instance for `NEMap`, `NEIntMap`, and `NESeq`. 26 | * **0.3.4.5**: Future-proof against Prelude exporting `foldl'` (@Bodgrim) (*December 6, 2023*) 27 | 28 | Version 0.3.3.0 29 | --------------- 30 | 31 | *December 3, 2019* 32 | 33 | 34 | 35 | * Add `overNonEmpty` and `onNonEmpty` in *Data.Containers.NonEmpty*. 36 | 37 | Version 0.3.2.0 38 | --------------- 39 | 40 | *October 21, 2019* 41 | 42 | 43 | 44 | * Add `HasNonEmpty` instance for *nonempty-vector* 45 | * Changed `splitLookup` to use `These` instead of a tuple of `Maybe`s. 46 | 47 | Version 0.3.1.0 48 | --------------- 49 | 50 | *June 13, 2019* 51 | 52 | 53 | 54 | * Add `absurdNEMap` to *Data.Map.NonEmpty*. This is the only type that would 55 | benefit from such a specialized function, whereas all other types would do 56 | just as well with `absurd . fold1 :: Foldable1 f => f Void -> a`. 57 | 58 | Version 0.3.0.0 59 | --------------- 60 | 61 | *June 10, 2019* 62 | 63 | 64 | 65 | * Switch back from *data-or* to *these*, due to changes in the organization 66 | of *these* that get rid of the high dependency footprint. 67 | 68 | Version 0.2.0.0 69 | --------------- 70 | 71 | *May 14, 2019* 72 | 73 | 74 | 75 | * ([#2][]) Switch from *these* to *data-or*, for lighter dependency footprint. Much 76 | thanks to @fosskers for putting in the heavy work. 77 | 78 | [#2]: https://github.com/mstksg/nonempty-containers/pull/2 79 | 80 | Version 0.1.1.0 81 | --------------- 82 | 83 | *December 8, 2018* 84 | 85 | 86 | 87 | * `Comonad` instances added for `Map k` and `IntMap`, based on [Faucelme's 88 | suggestion][comonad] 89 | 90 | [comonad]: https://www.reddit.com/r/haskell/comments/a1qjcy/nonemptycontainers_nonempty_variants_of/eat5r4h/ 91 | 92 | Version 0.1.0.0 93 | --------------- 94 | 95 | 96 | 97 | * Initial release 98 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Justin Le (c) 2018 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 Justin Le 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 | # [nonempty-containers][] 2 | 3 | [nonempty-containers]: http://hackage.haskell.org/package/nonempty-containers 4 | 5 | Efficient and optimized non-empty (by construction) versions of types from 6 | *[containers][]*. Inspired by *[non-empty-containers][]* library, except 7 | attempting a more faithful port (with under-the-hood optimizations) of the full 8 | *containers* API. Also contains a convenient typeclass abstraction for 9 | converting between non-empty and possibly-empty variants, as well as pattern 10 | synonym-based conversion methods. 11 | 12 | [containers]: http://hackage.haskell.org/package/containers 13 | [non-empty-containers]: http://hackage.haskell.org/package/non-empty-containers 14 | 15 | Non-empty *by construction* means that the data type is implemented using a 16 | data structure where it is structurally impossible to represent an empty 17 | collection. 18 | 19 | Unlike similar packages (see below), this package is defined to be a 20 | *drop-in replacement* for the *containers* API in most situations. More or 21 | less every single function is implemented with the same asymptotics and 22 | typeclass constraints. An extensive test suite (with 457 total tests) is 23 | provided to ensure that the behavior of functions are identical to their 24 | original *containers* counterparts. 25 | 26 | Care is also taken to modify the interface of specific functions to reflect 27 | non-emptiness and emptiness as concepts, including: 28 | 29 | 1. Functions that might return empty results (like `delete`, `filter`) return 30 | possibly-empty variants instead. 31 | 32 | 2. Functions that totally partition a non-empty collection (like `partition`, 33 | `splitAt`, `span`) would previously return a tuple of either halves: 34 | 35 | ```haskell 36 | mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c) 37 | ``` 38 | 39 | The final result is always a total partition (every item in the original 40 | map is represented in the result), so, to reflect this, [`These`][these] is 41 | returned instead: 42 | 43 | ```haskell 44 | data These a b = This a 45 | | That b 46 | | These a b 47 | 48 | mapEither :: (a -> Either b c) -> NEMap k a -> These (NEMap k b) (NEMap k c) 49 | ``` 50 | 51 | This preserves the invariance of non-emptiness: either we have a non-empty 52 | map in the first camp (containing all original values), a non-empty map in 53 | the second camp (containing all original values), or a split between two 54 | non-empty maps in either camp. 55 | 56 | [these]: https://hackage.haskell.org/package/these 57 | 58 | 3. Typeclass-polymorphic functions are made more general (or have more general 59 | variants provided) whenever possible. This means that functions like 60 | `foldMapWithKey` are written for all `Semigroup m` instead of only `Monoid 61 | m`, and `traverseWithKey1` is provided to work for all `Apply f` instances 62 | (instead of only `Applicative f` instances). 63 | 64 | `Foldable1` and `Traversable1` instances are also provided, to provide 65 | `foldMap1` and `traverse1`. 66 | 67 | 4. Functions that can "potentially delete" (like `alter` and `updateAt`) 68 | return possibly-empty variants. However, alternatives are offered 69 | (whenever not already present) with variants that disallow deletion, 70 | allowing for guaranteed non-empty maps to be returned. 71 | 72 | Contains non-empty versions for: 73 | 74 | * `Map` 75 | * `IntMap` 76 | * `Set` 77 | * `IntSet` 78 | * `Sequence` 79 | 80 | A typeclass abstraction (in *Data.Containers.NonEmpty*) is provided to allow 81 | for easy conversions between non-empty and possibly-empty variants. Note that 82 | `Tree`, from *Data.Tree*, is already non-empty by construction. 83 | 84 | Similar packages include: 85 | 86 | * [non-empty-containers][]: Similar approach with similar data types, but API 87 | is limited to a few choice functions. 88 | * [nonemptymap][]: Another similar approach, but is limited only to `Map`, 89 | and is also not a complete API port. 90 | * [non-empty-sequence][]: Similar to *nonemptymap*, but for `Seq`. Also not 91 | a complete API port. 92 | * [non-empty][]: Similar approach with similar data types, but is meant to be 93 | more general and work for a variety of more data types. 94 | * [nonempty-alternative][]: Similar approach, but is instead a generalized 95 | data type for all `Alternative` instances. 96 | 97 | [nonemptymap]: https://hackage.haskell.org/package/nonemptymap 98 | [non-empty-sequence]: https://hackage.haskell.org/package/non-empty-sequence 99 | [non-empty]: https://hackage.haskell.org/package/non-empty 100 | [nonempty-alternative]: https://hackage.haskell.org/package/nonempty-alternative 101 | 102 | Currently not implemented: 103 | 104 | * Extended merging functions. However, there aren't too many benefits to be 105 | gained from lifting extended merging functions, because their 106 | emptiness/non-emptiness guarantees are difficult to statically conclude. 107 | * Strict variants of Map functions. This is something that I wouldn't mind, 108 | and might add in the future. PR's are welcomed! 109 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "HTTP": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1451647621, 7 | "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", 8 | "owner": "phadej", 9 | "repo": "HTTP", 10 | "rev": "9bc0996d412fef1787449d841277ef663ad9a915", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "phadej", 15 | "repo": "HTTP", 16 | "type": "github" 17 | } 18 | }, 19 | "cabal-32": { 20 | "flake": false, 21 | "locked": { 22 | "lastModified": 1603716527, 23 | "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", 24 | "owner": "haskell", 25 | "repo": "cabal", 26 | "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", 27 | "type": "github" 28 | }, 29 | "original": { 30 | "owner": "haskell", 31 | "ref": "3.2", 32 | "repo": "cabal", 33 | "type": "github" 34 | } 35 | }, 36 | "cabal-34": { 37 | "flake": false, 38 | "locked": { 39 | "lastModified": 1645834128, 40 | "narHash": "sha256-wG3d+dOt14z8+ydz4SL7pwGfe7SiimxcD/LOuPCV6xM=", 41 | "owner": "haskell", 42 | "repo": "cabal", 43 | "rev": "5ff598c67f53f7c4f48e31d722ba37172230c462", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "haskell", 48 | "ref": "3.4", 49 | "repo": "cabal", 50 | "type": "github" 51 | } 52 | }, 53 | "cabal-36": { 54 | "flake": false, 55 | "locked": { 56 | "lastModified": 1669081697, 57 | "narHash": "sha256-I5or+V7LZvMxfbYgZATU4awzkicBwwok4mVoje+sGmU=", 58 | "owner": "haskell", 59 | "repo": "cabal", 60 | "rev": "8fd619e33d34924a94e691c5fea2c42f0fc7f144", 61 | "type": "github" 62 | }, 63 | "original": { 64 | "owner": "haskell", 65 | "ref": "3.6", 66 | "repo": "cabal", 67 | "type": "github" 68 | } 69 | }, 70 | "cardano-shell": { 71 | "flake": false, 72 | "locked": { 73 | "lastModified": 1608537748, 74 | "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", 75 | "owner": "input-output-hk", 76 | "repo": "cardano-shell", 77 | "rev": "9392c75087cb9a3d453998f4230930dea3a95725", 78 | "type": "github" 79 | }, 80 | "original": { 81 | "owner": "input-output-hk", 82 | "repo": "cardano-shell", 83 | "type": "github" 84 | } 85 | }, 86 | "flake-compat": { 87 | "flake": false, 88 | "locked": { 89 | "lastModified": 1672831974, 90 | "narHash": "sha256-z9k3MfslLjWQfnjBtEtJZdq3H7kyi2kQtUThfTgdRk0=", 91 | "owner": "input-output-hk", 92 | "repo": "flake-compat", 93 | "rev": "45f2638735f8cdc40fe302742b79f248d23eb368", 94 | "type": "github" 95 | }, 96 | "original": { 97 | "owner": "input-output-hk", 98 | "ref": "hkm/gitlab-fix", 99 | "repo": "flake-compat", 100 | "type": "github" 101 | } 102 | }, 103 | "flake-utils": { 104 | "inputs": { 105 | "systems": "systems" 106 | }, 107 | "locked": { 108 | "lastModified": 1731533236, 109 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 110 | "owner": "numtide", 111 | "repo": "flake-utils", 112 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 113 | "type": "github" 114 | }, 115 | "original": { 116 | "id": "flake-utils", 117 | "type": "indirect" 118 | } 119 | }, 120 | "flake-utils_2": { 121 | "inputs": { 122 | "systems": "systems_2" 123 | }, 124 | "locked": { 125 | "lastModified": 1731533236, 126 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 127 | "owner": "numtide", 128 | "repo": "flake-utils", 129 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 130 | "type": "github" 131 | }, 132 | "original": { 133 | "owner": "numtide", 134 | "repo": "flake-utils", 135 | "type": "github" 136 | } 137 | }, 138 | "ghc-8.6.5-iohk": { 139 | "flake": false, 140 | "locked": { 141 | "lastModified": 1600920045, 142 | "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", 143 | "owner": "input-output-hk", 144 | "repo": "ghc", 145 | "rev": "95713a6ecce4551240da7c96b6176f980af75cae", 146 | "type": "github" 147 | }, 148 | "original": { 149 | "owner": "input-output-hk", 150 | "ref": "release/8.6.5-iohk", 151 | "repo": "ghc", 152 | "type": "github" 153 | } 154 | }, 155 | "hackage": { 156 | "flake": false, 157 | "locked": { 158 | "lastModified": 1747614461, 159 | "narHash": "sha256-+drer9yLVngRdK4sn15MRaWKF/xsc5z0FGA0rtz7eR0=", 160 | "owner": "input-output-hk", 161 | "repo": "hackage.nix", 162 | "rev": "9d06a43210da4d699de567a0e1a2d2933887d023", 163 | "type": "github" 164 | }, 165 | "original": { 166 | "owner": "input-output-hk", 167 | "repo": "hackage.nix", 168 | "type": "github" 169 | } 170 | }, 171 | "hackage-for-stackage": { 172 | "flake": false, 173 | "locked": { 174 | "lastModified": 1747614450, 175 | "narHash": "sha256-v6BR/vgC7ps3Owt/dLIjxd6KDFb8wqPJQETjLGKfbDE=", 176 | "owner": "input-output-hk", 177 | "repo": "hackage.nix", 178 | "rev": "fbe2dd8d394fea9ba0a3e095f0ac56d8037d0d3f", 179 | "type": "github" 180 | }, 181 | "original": { 182 | "owner": "input-output-hk", 183 | "ref": "for-stackage", 184 | "repo": "hackage.nix", 185 | "type": "github" 186 | } 187 | }, 188 | "haskellNix": { 189 | "inputs": { 190 | "HTTP": "HTTP", 191 | "cabal-32": "cabal-32", 192 | "cabal-34": "cabal-34", 193 | "cabal-36": "cabal-36", 194 | "cardano-shell": "cardano-shell", 195 | "flake-compat": "flake-compat", 196 | "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", 197 | "hackage": "hackage", 198 | "hackage-for-stackage": "hackage-for-stackage", 199 | "hls": "hls", 200 | "hls-1.10": "hls-1.10", 201 | "hls-2.0": "hls-2.0", 202 | "hls-2.10": "hls-2.10", 203 | "hls-2.2": "hls-2.2", 204 | "hls-2.3": "hls-2.3", 205 | "hls-2.4": "hls-2.4", 206 | "hls-2.5": "hls-2.5", 207 | "hls-2.6": "hls-2.6", 208 | "hls-2.7": "hls-2.7", 209 | "hls-2.8": "hls-2.8", 210 | "hls-2.9": "hls-2.9", 211 | "hpc-coveralls": "hpc-coveralls", 212 | "iserv-proxy": "iserv-proxy", 213 | "nixpkgs": [ 214 | "haskellProjectFlake", 215 | "haskellNix", 216 | "nixpkgs-unstable" 217 | ], 218 | "nixpkgs-2305": "nixpkgs-2305", 219 | "nixpkgs-2311": "nixpkgs-2311", 220 | "nixpkgs-2405": "nixpkgs-2405", 221 | "nixpkgs-2411": "nixpkgs-2411", 222 | "nixpkgs-unstable": "nixpkgs-unstable", 223 | "old-ghc-nix": "old-ghc-nix", 224 | "stackage": "stackage" 225 | }, 226 | "locked": { 227 | "lastModified": 1747615950, 228 | "narHash": "sha256-9hLyUMiV3rQx9N8B5yljasqygsON6X6kNlr/vqIIV9U=", 229 | "owner": "input-output-hk", 230 | "repo": "haskell.nix", 231 | "rev": "6e14de042d2a63ccfc4bb45ff4c171ee2593c9ea", 232 | "type": "github" 233 | }, 234 | "original": { 235 | "owner": "input-output-hk", 236 | "repo": "haskell.nix", 237 | "type": "github" 238 | } 239 | }, 240 | "haskellProjectFlake": { 241 | "inputs": { 242 | "flake-utils": "flake-utils_2", 243 | "haskellNix": "haskellNix", 244 | "nixpkgs": [ 245 | "haskellProjectFlake", 246 | "haskellNix", 247 | "nixpkgs-unstable" 248 | ] 249 | }, 250 | "locked": { 251 | "lastModified": 1747771074, 252 | "narHash": "sha256-Ux9M9R2Z0vP7Mr0mZtux/t+Or+fJ7aSCZxowVJx7rl0=", 253 | "owner": "mstksg", 254 | "repo": "haskell-project-flake", 255 | "rev": "8c5ef8438d7b416bc49b76007ad7deafebd00e02", 256 | "type": "github" 257 | }, 258 | "original": { 259 | "owner": "mstksg", 260 | "repo": "haskell-project-flake", 261 | "type": "github" 262 | } 263 | }, 264 | "hls": { 265 | "flake": false, 266 | "locked": { 267 | "lastModified": 1741604408, 268 | "narHash": "sha256-tuq3+Ip70yu89GswZ7DSINBpwRprnWnl6xDYnS4GOsc=", 269 | "owner": "haskell", 270 | "repo": "haskell-language-server", 271 | "rev": "682d6894c94087da5e566771f25311c47e145359", 272 | "type": "github" 273 | }, 274 | "original": { 275 | "owner": "haskell", 276 | "repo": "haskell-language-server", 277 | "type": "github" 278 | } 279 | }, 280 | "hls-1.10": { 281 | "flake": false, 282 | "locked": { 283 | "lastModified": 1680000865, 284 | "narHash": "sha256-rc7iiUAcrHxwRM/s0ErEsSPxOR3u8t7DvFeWlMycWgo=", 285 | "owner": "haskell", 286 | "repo": "haskell-language-server", 287 | "rev": "b08691db779f7a35ff322b71e72a12f6e3376fd9", 288 | "type": "github" 289 | }, 290 | "original": { 291 | "owner": "haskell", 292 | "ref": "1.10.0.0", 293 | "repo": "haskell-language-server", 294 | "type": "github" 295 | } 296 | }, 297 | "hls-2.0": { 298 | "flake": false, 299 | "locked": { 300 | "lastModified": 1687698105, 301 | "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", 302 | "owner": "haskell", 303 | "repo": "haskell-language-server", 304 | "rev": "783905f211ac63edf982dd1889c671653327e441", 305 | "type": "github" 306 | }, 307 | "original": { 308 | "owner": "haskell", 309 | "ref": "2.0.0.1", 310 | "repo": "haskell-language-server", 311 | "type": "github" 312 | } 313 | }, 314 | "hls-2.10": { 315 | "flake": false, 316 | "locked": { 317 | "lastModified": 1743069404, 318 | "narHash": "sha256-q4kDFyJDDeoGqfEtrZRx4iqMVEC2MOzCToWsFY+TOzY=", 319 | "owner": "haskell", 320 | "repo": "haskell-language-server", 321 | "rev": "2318c61db3a01e03700bd4b05665662929b7fe8b", 322 | "type": "github" 323 | }, 324 | "original": { 325 | "owner": "haskell", 326 | "ref": "2.10.0.0", 327 | "repo": "haskell-language-server", 328 | "type": "github" 329 | } 330 | }, 331 | "hls-2.2": { 332 | "flake": false, 333 | "locked": { 334 | "lastModified": 1693064058, 335 | "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", 336 | "owner": "haskell", 337 | "repo": "haskell-language-server", 338 | "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", 339 | "type": "github" 340 | }, 341 | "original": { 342 | "owner": "haskell", 343 | "ref": "2.2.0.0", 344 | "repo": "haskell-language-server", 345 | "type": "github" 346 | } 347 | }, 348 | "hls-2.3": { 349 | "flake": false, 350 | "locked": { 351 | "lastModified": 1695910642, 352 | "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", 353 | "owner": "haskell", 354 | "repo": "haskell-language-server", 355 | "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", 356 | "type": "github" 357 | }, 358 | "original": { 359 | "owner": "haskell", 360 | "ref": "2.3.0.0", 361 | "repo": "haskell-language-server", 362 | "type": "github" 363 | } 364 | }, 365 | "hls-2.4": { 366 | "flake": false, 367 | "locked": { 368 | "lastModified": 1699862708, 369 | "narHash": "sha256-YHXSkdz53zd0fYGIYOgLt6HrA0eaRJi9mXVqDgmvrjk=", 370 | "owner": "haskell", 371 | "repo": "haskell-language-server", 372 | "rev": "54507ef7e85fa8e9d0eb9a669832a3287ffccd57", 373 | "type": "github" 374 | }, 375 | "original": { 376 | "owner": "haskell", 377 | "ref": "2.4.0.1", 378 | "repo": "haskell-language-server", 379 | "type": "github" 380 | } 381 | }, 382 | "hls-2.5": { 383 | "flake": false, 384 | "locked": { 385 | "lastModified": 1701080174, 386 | "narHash": "sha256-fyiR9TaHGJIIR0UmcCb73Xv9TJq3ht2ioxQ2mT7kVdc=", 387 | "owner": "haskell", 388 | "repo": "haskell-language-server", 389 | "rev": "27f8c3d3892e38edaef5bea3870161815c4d014c", 390 | "type": "github" 391 | }, 392 | "original": { 393 | "owner": "haskell", 394 | "ref": "2.5.0.0", 395 | "repo": "haskell-language-server", 396 | "type": "github" 397 | } 398 | }, 399 | "hls-2.6": { 400 | "flake": false, 401 | "locked": { 402 | "lastModified": 1705325287, 403 | "narHash": "sha256-+P87oLdlPyMw8Mgoul7HMWdEvWP/fNlo8jyNtwME8E8=", 404 | "owner": "haskell", 405 | "repo": "haskell-language-server", 406 | "rev": "6e0b342fa0327e628610f2711f8c3e4eaaa08b1e", 407 | "type": "github" 408 | }, 409 | "original": { 410 | "owner": "haskell", 411 | "ref": "2.6.0.0", 412 | "repo": "haskell-language-server", 413 | "type": "github" 414 | } 415 | }, 416 | "hls-2.7": { 417 | "flake": false, 418 | "locked": { 419 | "lastModified": 1708965829, 420 | "narHash": "sha256-LfJ+TBcBFq/XKoiNI7pc4VoHg4WmuzsFxYJ3Fu+Jf+M=", 421 | "owner": "haskell", 422 | "repo": "haskell-language-server", 423 | "rev": "50322b0a4aefb27adc5ec42f5055aaa8f8e38001", 424 | "type": "github" 425 | }, 426 | "original": { 427 | "owner": "haskell", 428 | "ref": "2.7.0.0", 429 | "repo": "haskell-language-server", 430 | "type": "github" 431 | } 432 | }, 433 | "hls-2.8": { 434 | "flake": false, 435 | "locked": { 436 | "lastModified": 1715153580, 437 | "narHash": "sha256-Vi/iUt2pWyUJlo9VrYgTcbRviWE0cFO6rmGi9rmALw0=", 438 | "owner": "haskell", 439 | "repo": "haskell-language-server", 440 | "rev": "dd1be1beb16700de59e0d6801957290bcf956a0a", 441 | "type": "github" 442 | }, 443 | "original": { 444 | "owner": "haskell", 445 | "ref": "2.8.0.0", 446 | "repo": "haskell-language-server", 447 | "type": "github" 448 | } 449 | }, 450 | "hls-2.9": { 451 | "flake": false, 452 | "locked": { 453 | "lastModified": 1719993701, 454 | "narHash": "sha256-wy348++MiMm/xwtI9M3vVpqj2qfGgnDcZIGXw8sF1sA=", 455 | "owner": "haskell", 456 | "repo": "haskell-language-server", 457 | "rev": "90319a7e62ab93ab65a95f8f2bcf537e34dae76a", 458 | "type": "github" 459 | }, 460 | "original": { 461 | "owner": "haskell", 462 | "ref": "2.9.0.1", 463 | "repo": "haskell-language-server", 464 | "type": "github" 465 | } 466 | }, 467 | "hpc-coveralls": { 468 | "flake": false, 469 | "locked": { 470 | "lastModified": 1607498076, 471 | "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", 472 | "owner": "sevanspowell", 473 | "repo": "hpc-coveralls", 474 | "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", 475 | "type": "github" 476 | }, 477 | "original": { 478 | "owner": "sevanspowell", 479 | "repo": "hpc-coveralls", 480 | "type": "github" 481 | } 482 | }, 483 | "iserv-proxy": { 484 | "flake": false, 485 | "locked": { 486 | "lastModified": 1747047742, 487 | "narHash": "sha256-PCDULyZSIPdDdF8Lanbcy+Dl6AJ5z6H2ng3sRsv+gwc=", 488 | "owner": "stable-haskell", 489 | "repo": "iserv-proxy", 490 | "rev": "dea34de4bde325aca22472c18d659bee7800b477", 491 | "type": "github" 492 | }, 493 | "original": { 494 | "owner": "stable-haskell", 495 | "ref": "iserv-syms", 496 | "repo": "iserv-proxy", 497 | "type": "github" 498 | } 499 | }, 500 | "nixpkgs-2305": { 501 | "locked": { 502 | "lastModified": 1705033721, 503 | "narHash": "sha256-K5eJHmL1/kev6WuqyqqbS1cdNnSidIZ3jeqJ7GbrYnQ=", 504 | "owner": "NixOS", 505 | "repo": "nixpkgs", 506 | "rev": "a1982c92d8980a0114372973cbdfe0a307f1bdea", 507 | "type": "github" 508 | }, 509 | "original": { 510 | "owner": "NixOS", 511 | "ref": "nixpkgs-23.05-darwin", 512 | "repo": "nixpkgs", 513 | "type": "github" 514 | } 515 | }, 516 | "nixpkgs-2311": { 517 | "locked": { 518 | "lastModified": 1719957072, 519 | "narHash": "sha256-gvFhEf5nszouwLAkT9nWsDzocUTqLWHuL++dvNjMp9I=", 520 | "owner": "NixOS", 521 | "repo": "nixpkgs", 522 | "rev": "7144d6241f02d171d25fba3edeaf15e0f2592105", 523 | "type": "github" 524 | }, 525 | "original": { 526 | "owner": "NixOS", 527 | "ref": "nixpkgs-23.11-darwin", 528 | "repo": "nixpkgs", 529 | "type": "github" 530 | } 531 | }, 532 | "nixpkgs-2405": { 533 | "locked": { 534 | "lastModified": 1735564410, 535 | "narHash": "sha256-HB/FA0+1gpSs8+/boEavrGJH+Eq08/R2wWNph1sM1Dg=", 536 | "owner": "NixOS", 537 | "repo": "nixpkgs", 538 | "rev": "1e7a8f391f1a490460760065fa0630b5520f9cf8", 539 | "type": "github" 540 | }, 541 | "original": { 542 | "owner": "NixOS", 543 | "ref": "nixpkgs-24.05-darwin", 544 | "repo": "nixpkgs", 545 | "type": "github" 546 | } 547 | }, 548 | "nixpkgs-2411": { 549 | "locked": { 550 | "lastModified": 1746566971, 551 | "narHash": "sha256-I40weT0FZWth1IEjgR5a0zC9LLyrPwTC0DAQcejtTJE=", 552 | "owner": "NixOS", 553 | "repo": "nixpkgs", 554 | "rev": "209c5b3b0f5cf5b5a7e12ddea59bf19699f97e75", 555 | "type": "github" 556 | }, 557 | "original": { 558 | "owner": "NixOS", 559 | "ref": "nixpkgs-24.11-darwin", 560 | "repo": "nixpkgs", 561 | "type": "github" 562 | } 563 | }, 564 | "nixpkgs-unstable": { 565 | "locked": { 566 | "lastModified": 1746576598, 567 | "narHash": "sha256-FshoQvr6Aor5SnORVvh/ZdJ1Sa2U4ZrIMwKBX5k2wu0=", 568 | "owner": "NixOS", 569 | "repo": "nixpkgs", 570 | "rev": "b3582c75c7f21ce0b429898980eddbbf05c68e55", 571 | "type": "github" 572 | }, 573 | "original": { 574 | "owner": "NixOS", 575 | "ref": "nixpkgs-unstable", 576 | "repo": "nixpkgs", 577 | "type": "github" 578 | } 579 | }, 580 | "old-ghc-nix": { 581 | "flake": false, 582 | "locked": { 583 | "lastModified": 1631092763, 584 | "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", 585 | "owner": "angerman", 586 | "repo": "old-ghc-nix", 587 | "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", 588 | "type": "github" 589 | }, 590 | "original": { 591 | "owner": "angerman", 592 | "ref": "master", 593 | "repo": "old-ghc-nix", 594 | "type": "github" 595 | } 596 | }, 597 | "root": { 598 | "inputs": { 599 | "flake-utils": "flake-utils", 600 | "haskellProjectFlake": "haskellProjectFlake", 601 | "nixpkgs": [ 602 | "haskellProjectFlake", 603 | "nixpkgs" 604 | ] 605 | } 606 | }, 607 | "stackage": { 608 | "flake": false, 609 | "locked": { 610 | "lastModified": 1747613623, 611 | "narHash": "sha256-DfAqKYWYissAfgvdwmbP/+bRQLGEpgQrzJeB1lC9sOA=", 612 | "owner": "input-output-hk", 613 | "repo": "stackage.nix", 614 | "rev": "01559292d5425e6d32fa067a4557b69199f412cf", 615 | "type": "github" 616 | }, 617 | "original": { 618 | "owner": "input-output-hk", 619 | "repo": "stackage.nix", 620 | "type": "github" 621 | } 622 | }, 623 | "systems": { 624 | "locked": { 625 | "lastModified": 1681028828, 626 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 627 | "owner": "nix-systems", 628 | "repo": "default", 629 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 630 | "type": "github" 631 | }, 632 | "original": { 633 | "owner": "nix-systems", 634 | "repo": "default", 635 | "type": "github" 636 | } 637 | }, 638 | "systems_2": { 639 | "locked": { 640 | "lastModified": 1681028828, 641 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 642 | "owner": "nix-systems", 643 | "repo": "default", 644 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 645 | "type": "github" 646 | }, 647 | "original": { 648 | "owner": "nix-systems", 649 | "repo": "default", 650 | "type": "github" 651 | } 652 | } 653 | }, 654 | "root": "root", 655 | "version": 7 656 | } 657 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Basic Haskell Project Flake"; 3 | inputs = { 4 | haskellProjectFlake.url = "github:mstksg/haskell-project-flake"; 5 | nixpkgs.follows = "haskellProjectFlake/nixpkgs"; 6 | }; 7 | outputs = 8 | { self 9 | , nixpkgs 10 | , flake-utils 11 | , haskellProjectFlake 12 | }: 13 | flake-utils.lib.eachDefaultSystem (system: 14 | let 15 | name = "nonempty-containers"; 16 | pkgs = import nixpkgs { 17 | inherit system; 18 | overlays = [ haskellProjectFlake.overlays."${system}".default ]; 19 | }; 20 | project-flake = pkgs.haskell-project-flake 21 | { 22 | inherit name; 23 | src = ./.; 24 | excludeCompilerMajors = [ "ghc94" "ghc913" ]; 25 | defaultCompiler = "ghc984"; 26 | }; 27 | in 28 | { 29 | packages = project-flake.packages; 30 | apps = project-flake.apps; 31 | checks = project-flake.checks; 32 | devShells = project-flake.devShells; 33 | legacyPackages."${name}" = project-flake; 34 | } 35 | ); 36 | } 37 | 38 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | column-limit: 100 2 | comma-style: leading 3 | fixities: [] 4 | function-arrows: trailing 5 | haddock-style: single-line 6 | haddock-style-module: null 7 | import-export-style: diff-friendly 8 | in-style: right-align 9 | indent-wheres: true 10 | indentation: 2 11 | let-style: inline 12 | newlines-between-decls: 1 13 | record-break-space: true 14 | reexports: [] 15 | respectful: true 16 | single-constraint-parens: never 17 | unicode: detect 18 | -------------------------------------------------------------------------------- /nonempty-containers.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.36.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: nonempty-containers 8 | version: 0.3.5.0 9 | synopsis: Non-empty variants of containers data types, with full API 10 | description: 11 | Efficient and optimized non-empty versions of types from /containers/. 12 | Inspired by /non-empty-containers/ library, except attempting a more 13 | faithful port (with under-the-hood optimizations) of the full /containers/ 14 | API. Also contains a convenient typeclass abstraction for converting 15 | betwewen non-empty and possibly-empty variants. See README.md for more 16 | information. 17 | 18 | category: Data Structures 19 | homepage: https://github.com/mstksg/nonempty-containers#readme 20 | bug-reports: https://github.com/mstksg/nonempty-containers/issues 21 | author: Justin Le 22 | maintainer: justin@jle.im 23 | copyright: (c) Justin Le 2018 24 | license: BSD3 25 | license-file: LICENSE 26 | build-type: Simple 27 | tested-with: GHC >=8.10 28 | extra-source-files: 29 | CHANGELOG.md 30 | README.md 31 | 32 | source-repository head 33 | type: git 34 | location: https://github.com/mstksg/nonempty-containers 35 | 36 | library 37 | exposed-modules: 38 | Data.Containers.NonEmpty 39 | Data.IntMap.NonEmpty 40 | Data.IntMap.NonEmpty.Internal 41 | Data.IntSet.NonEmpty 42 | Data.IntSet.NonEmpty.Internal 43 | Data.Map.NonEmpty 44 | Data.Map.NonEmpty.Internal 45 | Data.Sequence.NonEmpty 46 | Data.Sequence.NonEmpty.Internal 47 | Data.Set.NonEmpty 48 | Data.Set.NonEmpty.Internal 49 | 50 | other-modules: Paths_nonempty_containers 51 | hs-source-dirs: src 52 | ghc-options: -Wall -Wcompat -Wredundant-constraints 53 | build-depends: 54 | aeson 55 | , base >=4.9 && <5 56 | , comonad 57 | , containers >=0.6.3.1 && <0.9 58 | , deepseq 59 | , invariant 60 | , nonempty-vector 61 | , semigroupoids 62 | , these 63 | , vector 64 | 65 | default-language: Haskell2010 66 | 67 | test-suite nonempty-containers-test 68 | type: exitcode-stdio-1.0 69 | main-is: Spec.hs 70 | other-modules: 71 | Paths_nonempty_containers 72 | Tests.IntMap 73 | Tests.IntSet 74 | Tests.Map 75 | Tests.Sequence 76 | Tests.Set 77 | Tests.Util 78 | 79 | hs-source-dirs: test 80 | ghc-options: 81 | -Wall -Wcompat -Wredundant-constraints -threaded -rtsopts 82 | -with-rtsopts=-N 83 | 84 | build-depends: 85 | base >=4.9 && <5 86 | , comonad 87 | , containers >=0.6.3.1 && <0.9 88 | , hedgehog >=1.0 89 | , hedgehog-fn >=1.0 90 | , invariant 91 | , nonempty-containers 92 | , nonempty-vector 93 | , semigroupoids 94 | , tasty 95 | , tasty-hedgehog >=1.0 96 | , text 97 | , these 98 | , vector 99 | 100 | default-language: Haskell2010 101 | -------------------------------------------------------------------------------- /src/Data/Containers/NonEmpty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE TypeFamilyDependencies #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | -- | 7 | -- Module : Data.Containers.NonEmpty 8 | -- Copyright : (c) Justin Le 2018 9 | -- License : BSD3 10 | -- 11 | -- Maintainer : justin@jle.im 12 | -- Stability : experimental 13 | -- Portability : non-portable 14 | -- 15 | -- = Non-Empty Typeclass 16 | -- 17 | -- Provides the typeclass 'HasNonEmpty', which abstracts over different 18 | -- types which have a "non-empty" variant. 19 | -- 20 | -- Used to convert between and in between possibly-empty and non-empty 21 | -- types. Instances are provided for all modules in this package, as well 22 | -- as for 'NonEmpty' in /base/ and 'NonEmptyVector'. 23 | module Data.Containers.NonEmpty ( 24 | HasNonEmpty (..), 25 | pattern IsNonEmpty, 26 | pattern IsEmpty, 27 | overNonEmpty, 28 | onNonEmpty, 29 | ) where 30 | 31 | import Data.IntMap (IntMap) 32 | import qualified Data.IntMap as IM 33 | import Data.IntMap.NonEmpty (NEIntMap) 34 | import qualified Data.IntMap.NonEmpty as NEIM 35 | import Data.IntSet (IntSet) 36 | import qualified Data.IntSet as IS 37 | import Data.IntSet.NonEmpty (NEIntSet) 38 | import qualified Data.IntSet.NonEmpty as NEIS 39 | import Data.List.NonEmpty (NonEmpty (..)) 40 | import qualified Data.List.NonEmpty as NE 41 | import Data.Map (Map) 42 | import qualified Data.Map as M 43 | import Data.Map.NonEmpty (NEMap) 44 | import qualified Data.Map.NonEmpty as NEM 45 | import Data.Maybe 46 | import Data.Sequence (Seq (..)) 47 | import qualified Data.Sequence as Seq 48 | import Data.Sequence.NonEmpty (NESeq (..)) 49 | import qualified Data.Sequence.NonEmpty as NESeq 50 | import Data.Set (Set) 51 | import qualified Data.Set as S 52 | import Data.Set.NonEmpty (NESet) 53 | import qualified Data.Set.NonEmpty as NES 54 | import Data.Vector (Vector) 55 | import qualified Data.Vector as V 56 | import Data.Vector.NonEmpty (NonEmptyVector) 57 | import qualified Data.Vector.NonEmpty as NEV 58 | 59 | -- | If @s@ is an instance of @HasNonEmpty@, it means that there is 60 | -- a corresponding "non-empty" version of @s@, @'NE' s@. 61 | -- 62 | -- In order for things to be well-behaved, we expect that 'nonEmpty' and 63 | -- @maybe 'empty' 'fromNonEmpty'@ should form an isomorphism (or that 64 | -- @'withNonEmpty' 'empty' 'fromNonEmpty' == id@. In addition, 65 | -- the following properties should hold for most exectations: 66 | -- 67 | -- * @(x == empty) ==> isEmpty x@ 68 | -- * @(x == empty) ==> isNothing (nonEmpty x)@ 69 | -- * @isEmpty x ==> isNothing (nonEmpty x)@ 70 | -- * @unsafeToNonEmpty x == fromJust (nonEmpty x)@ 71 | -- * Usually, @not (isEmpty x) ==> isJust (nonEmpty x)@, but this isn't 72 | -- necessary. 73 | class HasNonEmpty s where 74 | {-# MINIMAL (nonEmpty | withNonEmpty), fromNonEmpty, empty #-} 75 | 76 | -- | @'NE' s@ is the "non-empty" version of @s@. 77 | type NE s = t | t -> s 78 | 79 | -- | "Smart constructor" for @'NE' s@ given a (potentailly empty) @s@. 80 | -- Will return 'Nothing' if the @s@ was empty, and @'Just' n@ if the 81 | -- @s@ was not empty, with @n :: 'NE' s@. 82 | -- 83 | -- Should form an isomorphism with @'maybe' 'empty' 'fromNonEmpty'@. 84 | nonEmpty :: s -> Maybe (NE s) 85 | nonEmpty = withNonEmpty Nothing Just 86 | 87 | -- | Convert a @'NE' s@ (non-empty @s@) back into an @s@, "obscuring" 88 | -- its non-emptiness from its type. 89 | fromNonEmpty :: NE s -> s 90 | 91 | -- | Continuation-based version of 'nonEmpty', which can be more 92 | -- efficient in certain situations. 93 | -- 94 | -- @'withNonEmpty' 'empty' 'fromNonEmpty'@ should be @id@. 95 | withNonEmpty :: r -> (NE s -> r) -> s -> r 96 | withNonEmpty def f = maybe def f . nonEmpty 97 | 98 | -- | An empty @s@. 99 | empty :: s 100 | 101 | -- | Check if an @s@ is empty. 102 | isEmpty :: s -> Bool 103 | isEmpty = isNothing . nonEmpty 104 | 105 | -- | Unsafely coerce an @s@ into an @'NE' s@ (non-empty @s@). Is 106 | -- undefined (throws a runtime exception when evaluation is attempted) 107 | -- when the @s@ is empty. 108 | unsafeToNonEmpty :: s -> NE s 109 | unsafeToNonEmpty = fromMaybe e . nonEmpty 110 | where 111 | e = errorWithoutStackTrace "unsafeToNonEmpty: empty input provided" 112 | 113 | -- | Useful function for mapping over the "non-empty" representation of 114 | -- a type. 115 | -- 116 | -- @since 0.3.3.0 117 | overNonEmpty :: (HasNonEmpty s, HasNonEmpty t) => (NE s -> NE t) -> s -> t 118 | overNonEmpty f = withNonEmpty empty (fromNonEmpty . f) 119 | 120 | -- | Useful function for applying a function on the "non-empty" 121 | -- representation of a type. 122 | -- 123 | -- If you want a continuation taking @'NE' s -> 'Maybe r'@, you can 124 | -- use @'withNonEmpty' 'Nothing'@. 125 | -- 126 | -- @since 0.3.3.0 127 | onNonEmpty :: HasNonEmpty s => (NE s -> r) -> s -> Maybe r 128 | onNonEmpty f = withNonEmpty Nothing (Just . f) 129 | 130 | instance HasNonEmpty [a] where 131 | type NE [a] = NonEmpty a 132 | nonEmpty = NE.nonEmpty 133 | fromNonEmpty = NE.toList 134 | withNonEmpty def f = \case 135 | [] -> def 136 | x : xs -> f (x :| xs) 137 | empty = [] 138 | isEmpty = null 139 | unsafeToNonEmpty = NE.fromList 140 | 141 | instance HasNonEmpty (Map k a) where 142 | type NE (Map k a) = NEMap k a 143 | nonEmpty = NEM.nonEmptyMap 144 | fromNonEmpty = NEM.toMap 145 | withNonEmpty = NEM.withNonEmpty 146 | empty = M.empty 147 | isEmpty = M.null 148 | unsafeToNonEmpty = NEM.unsafeFromMap 149 | 150 | instance HasNonEmpty (IntMap a) where 151 | type NE (IntMap a) = NEIntMap a 152 | nonEmpty = NEIM.nonEmptyMap 153 | fromNonEmpty = NEIM.toMap 154 | withNonEmpty = NEIM.withNonEmpty 155 | empty = IM.empty 156 | isEmpty = IM.null 157 | unsafeToNonEmpty = NEIM.unsafeFromMap 158 | 159 | instance HasNonEmpty (Set a) where 160 | type NE (Set a) = NESet a 161 | nonEmpty = NES.nonEmptySet 162 | fromNonEmpty = NES.toSet 163 | withNonEmpty = NES.withNonEmpty 164 | empty = S.empty 165 | isEmpty = S.null 166 | unsafeToNonEmpty = NES.unsafeFromSet 167 | 168 | instance HasNonEmpty IntSet where 169 | type NE IntSet = NEIntSet 170 | nonEmpty = NEIS.nonEmptySet 171 | fromNonEmpty = NEIS.toSet 172 | withNonEmpty = NEIS.withNonEmpty 173 | empty = IS.empty 174 | isEmpty = IS.null 175 | unsafeToNonEmpty = NEIS.unsafeFromSet 176 | 177 | instance HasNonEmpty (Seq a) where 178 | type NE (Seq a) = NESeq a 179 | nonEmpty = NESeq.nonEmptySeq 180 | fromNonEmpty = NESeq.toSeq 181 | withNonEmpty = NESeq.withNonEmpty 182 | empty = Seq.empty 183 | isEmpty = Seq.null 184 | unsafeToNonEmpty = NESeq.unsafeFromSeq 185 | 186 | instance HasNonEmpty (Vector a) where 187 | type NE (Vector a) = NonEmptyVector a 188 | nonEmpty = NEV.fromVector 189 | fromNonEmpty = NEV.toVector 190 | empty = V.empty 191 | isEmpty = V.null 192 | 193 | -- | The 'IsNonEmpty' and 'IsEmpty' patterns allow you to treat a @s@ as 194 | -- if it were either a @'IsNonEmpty' n@ (where @n@ is a non-empty version 195 | -- of @s@, type @'NE' s@) or an 'IsEmpty'. 196 | -- 197 | -- For example, you can pattern match on a list to get a 'NonEmpty' 198 | -- (non-empty list): 199 | -- 200 | -- @ 201 | -- safeHead :: [Int] -> Int 202 | -- safeHead ('IsNonEmpty' (x :| _)) = x -- here, the list was not empty 203 | -- safehead 'IsEmpty' = 0 -- here, the list was empty 204 | -- @ 205 | -- 206 | -- Matching on @'IsNonEmpty' n@ means that the original input was /not/ 207 | -- empty, and you have a verified-non-empty @n :: 'NE' s@ to use. 208 | -- 209 | -- Note that because of the way coverage checking works for polymorphic 210 | -- pattern synonyms, you will unfortunatelly still get incomplete pattern 211 | -- match warnings if you match on both 'IsNonEmpty' and 'NonEmpty', even 212 | -- though the two are meant to provide complete coverage. However, many 213 | -- instances of 'HasNonEmpty' (like 'NEMap', 'NEIntMap', 'NESet', 214 | -- 'NEIntSet') will provide their own monomorphic versions of these 215 | -- patterns that can be verified as complete covers by GHC. 216 | -- 217 | -- This is a bidirectional pattern, so you can use 'IsNonEmpty' to convert 218 | -- a @'NE' s@ back into an @s@, "obscuring" its non-emptiness (see 219 | -- 'fromNonEmpty'). 220 | pattern IsNonEmpty :: HasNonEmpty s => NE s -> s 221 | pattern IsNonEmpty n <- (nonEmpty -> Just n) 222 | where 223 | IsNonEmpty n = fromNonEmpty n 224 | 225 | -- | The 'IsNonEmpty' and 'IsEmpty' patterns allow you to treat a @s@ as 226 | -- if it were either a @'IsNonEmpty' n@ (where @n@ is a non-empty version 227 | -- of @s@, type @'NE' s@) or an 'IsEmpty'. 228 | -- 229 | -- Matching on 'IsEmpty' means that the original item was empty. 230 | -- 231 | -- This is a bidirectional pattern, so you can use 'IsEmpty' as an 232 | -- expression, and it will be interpreted as 'empty'. 233 | -- 234 | -- Note that because of the way coverage checking works for polymorphic 235 | -- pattern synonyms, you will unfortunatelly still get incomplete pattern 236 | -- match warnings if you match on both 'IsNonEmpty' and 'NonEmpty', even 237 | -- though the two are meant to provide complete coverage. However, many 238 | -- instances of 'HasNonEmpty' (like 'NEMap', 'NEIntMap', 'NESet', 239 | -- 'NEIntSet') will provide their own monomorphic versions of these 240 | -- patterns that can be verified as complete covers by GHC. 241 | -- 242 | -- See 'IsNonEmpty' for more information. 243 | pattern IsEmpty :: HasNonEmpty s => s 244 | pattern IsEmpty <- (isEmpty -> True) 245 | where 246 | IsEmpty = empty 247 | -------------------------------------------------------------------------------- /src/Data/IntSet/NonEmpty/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | 5 | -- | 6 | -- Module : Data.IntSet.NonEmpty.Internal 7 | -- Copyright : (c) Justin Le 2018 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : justin@jle.im 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | -- Unsafe internal-use functions used in the implementation of 15 | -- "Data.IntSet.NonEmpty". These functions can potentially be used to break 16 | -- the abstraction of 'NEIntSet' and produce unsound sets, so be wary! 17 | module Data.IntSet.NonEmpty.Internal ( 18 | NEIntSet (..), 19 | Key, 20 | nonEmptySet, 21 | withNonEmpty, 22 | toSet, 23 | singleton, 24 | fromList, 25 | toList, 26 | union, 27 | unions, 28 | valid, 29 | insertMinSet, 30 | insertMaxSet, 31 | ) where 32 | 33 | import Control.DeepSeq 34 | import Control.Monad 35 | import qualified Data.Aeson as A 36 | import Data.Data 37 | import qualified Data.Foldable as F 38 | import Data.Function 39 | import qualified Data.IntSet as S 40 | import Data.IntSet.Internal (IntSet (..), Key) 41 | import Data.List.NonEmpty (NonEmpty (..)) 42 | import Data.Semigroup 43 | import Data.Semigroup.Foldable (Foldable1) 44 | import qualified Data.Semigroup.Foldable as F1 45 | import Text.Read 46 | 47 | -- | A non-empty (by construction) set of integers. At least one value 48 | -- exists in an @'NEIntSet' a@ at all times. 49 | -- 50 | -- Functions that /take/ an 'NEIntSet' can safely operate on it with the 51 | -- assumption that it has at least one item. 52 | -- 53 | -- Functions that /return/ an 'NEIntSet' provide an assurance that the 54 | -- result has at least one item. 55 | -- 56 | -- "Data.IntSet.NonEmpty" re-exports the API of "Data.IntSet", faithfully 57 | -- reproducing asymptotics, typeclass constraints, and semantics. 58 | -- Functions that ensure that input and output sets are both non-empty 59 | -- (like 'Data.IntSet.NonEmpty.insert') return 'NEIntSet', but functions that 60 | -- might potentially return an empty map (like 'Data.IntSet.NonEmpty.delete') 61 | -- return a 'IntSet' instead. 62 | -- 63 | -- You can directly construct an 'NEIntSet' with the API from 64 | -- "Data.IntSet.NonEmpty"; it's more or less the same as constructing a normal 65 | -- 'IntSet', except you don't have access to 'Data.IntSet.empty'. There are also 66 | -- a few ways to construct an 'NEIntSet' from a 'IntSet': 67 | -- 68 | -- 1. The 'nonEmptySet' smart constructor will convert a @'IntSet' a@ into 69 | -- a @'Maybe' ('NEIntSet' a)@, returning 'Nothing' if the original 'IntSet' 70 | -- was empty. 71 | -- 2. You can use the 'Data.IntSet.NonEmpty.insertIntSet' family of functions to 72 | -- insert a value into a 'IntSet' to create a guaranteed 'NEIntSet'. 73 | -- 3. You can use the 'Data.IntSet.NonEmpty.IsNonEmpty' and 74 | -- 'Data.IntSet.NonEmpty.IsEmpty' patterns to "pattern match" on a 'IntSet' 75 | -- to reveal it as either containing a 'NEIntSet' or an empty map. 76 | -- 4. 'withNonEmpty' offers a continuation-based interface 77 | -- for deconstructing a 'IntSet' and treating it as if it were an 'NEIntSet'. 78 | -- 79 | -- You can convert an 'NEIntSet' into a 'IntSet' with 'toSet' or 80 | -- 'Data.IntSet.NonEmpty.IsNonEmpty', essentially "obscuring" the non-empty 81 | -- property from the type. 82 | data NEIntSet 83 | = NEIntSet 84 | { neisV0 :: !Key 85 | -- ^ invariant: must be smaller than smallest value in set 86 | , neisIntSet :: !IntSet 87 | } 88 | deriving (Typeable) 89 | 90 | instance Eq NEIntSet where 91 | t1 == t2 = 92 | S.size (neisIntSet t1) == S.size (neisIntSet t2) 93 | && toList t1 == toList t2 94 | 95 | instance Ord NEIntSet where 96 | compare = compare `on` toList 97 | (<) = (<) `on` toList 98 | (>) = (>) `on` toList 99 | (<=) = (<=) `on` toList 100 | (>=) = (>=) `on` toList 101 | 102 | instance Show NEIntSet where 103 | showsPrec p xs = 104 | showParen (p > 10) $ 105 | showString "fromList (" . shows (toList xs) . showString ")" 106 | 107 | instance Read NEIntSet where 108 | readPrec = parens $ prec 10 $ do 109 | Ident "fromList" <- lexP 110 | xs <- parens . prec 10 $ readPrec 111 | return (fromList xs) 112 | 113 | readListPrec = readListPrecDefault 114 | 115 | instance NFData NEIntSet where 116 | rnf (NEIntSet x s) = rnf x `seq` rnf s 117 | 118 | -- Data instance code from Data.IntSet.Internal 119 | -- 120 | -- Copyright : (c) Daan Leijen 2002 121 | -- (c) Joachim Breitner 2011 122 | instance Data NEIntSet where 123 | gfoldl f z is = z fromList `f` toList is 124 | toConstr _ = fromListConstr 125 | gunfold k z c = case constrIndex c of 126 | 1 -> k (z fromList) 127 | _ -> error "gunfold" 128 | dataTypeOf _ = intSetDataType 129 | 130 | fromListConstr :: Constr 131 | fromListConstr = mkConstr intSetDataType "fromList" [] Prefix 132 | 133 | intSetDataType :: DataType 134 | intSetDataType = mkDataType "Data.IntSet.NonEmpty.Internal.NEIntSet" [fromListConstr] 135 | 136 | instance A.ToJSON NEIntSet where 137 | toJSON = A.toJSON . toSet 138 | toEncoding = A.toEncoding . toSet 139 | 140 | instance A.FromJSON NEIntSet where 141 | parseJSON = 142 | withNonEmpty (fail err) pure 143 | <=< A.parseJSON 144 | where 145 | err = "NEIntSet: Non-empty set expected, but empty set found" 146 | 147 | -- | /O(log n)/. Smart constructor for an 'NEIntSet' from a 'IntSet'. Returns 148 | -- 'Nothing' if the 'IntSet' was originally actually empty, and @'Just' n@ 149 | -- with an 'NEIntSet', if the 'IntSet' was not empty. 150 | -- 151 | -- 'nonEmptySet' and @'maybe' 'Data.IntSet.empty' 'toSet'@ form an 152 | -- isomorphism: they are perfect structure-preserving inverses of 153 | -- eachother. 154 | -- 155 | -- See 'Data.IntSet.NonEmpty.IsNonEmpty' for a pattern synonym that lets you 156 | -- "match on" the possiblity of a 'IntSet' being an 'NEIntSet'. 157 | -- 158 | -- > nonEmptySet (Data.IntSet.fromList [3,5]) == Just (fromList (3:|[5])) 159 | nonEmptySet :: IntSet -> Maybe NEIntSet 160 | nonEmptySet = (fmap . uncurry) NEIntSet . S.minView 161 | {-# INLINE nonEmptySet #-} 162 | 163 | -- | /O(log n)/. A general continuation-based way to consume a 'IntSet' as if 164 | -- it were an 'NEIntSet'. @'withNonEmpty' def f@ will take a 'IntSet'. If set is 165 | -- empty, it will evaluate to @def@. Otherwise, a non-empty set 'NEIntSet' 166 | -- will be fed to the function @f@ instead. 167 | -- 168 | -- @'nonEmptySet' == 'withNonEmpty' 'Nothing' 'Just'@ 169 | withNonEmpty :: 170 | -- | value to return if set is empty 171 | r -> 172 | -- | function to apply if set is not empty 173 | (NEIntSet -> r) -> 174 | IntSet -> 175 | r 176 | withNonEmpty def f = maybe def f . nonEmptySet 177 | {-# INLINE withNonEmpty #-} 178 | 179 | -- | /O(log n)/. 180 | -- Convert a non-empty set back into a normal possibly-empty map, for usage 181 | -- with functions that expect 'IntSet'. 182 | -- 183 | -- Can be thought of as "obscuring" the non-emptiness of the set in its 184 | -- type. See the 'Data.IntSet.NonEmpty.IsNotEmpty' pattern. 185 | -- 186 | -- 'nonEmptySet' and @'maybe' 'Data.IntSet.empty' 'toSet'@ form an 187 | -- isomorphism: they are perfect structure-preserving inverses of 188 | -- eachother. 189 | -- 190 | -- > toSet (fromList ((3,"a") :| [(5,"b")])) == Data.IntSet.fromList [(3,"a"), (5,"b")] 191 | toSet :: NEIntSet -> IntSet 192 | toSet (NEIntSet x s) = insertMinSet x s 193 | {-# INLINE toSet #-} 194 | 195 | -- | /O(1)/. Create a singleton set. 196 | singleton :: Key -> NEIntSet 197 | singleton x = NEIntSet x S.empty 198 | {-# INLINE singleton #-} 199 | 200 | -- | /O(n*log n)/. Create a set from a list of elements. 201 | 202 | -- TODO: write manually and optimize to be equivalent to 203 | -- 'fromDistinctAscList' if items are ordered, just like the actual 204 | -- 'S.fromList'. 205 | fromList :: NonEmpty Key -> NEIntSet 206 | fromList (x :| s) = 207 | withNonEmpty (singleton x) (<> singleton x) 208 | . S.fromList 209 | $ s 210 | {-# INLINE fromList #-} 211 | 212 | -- | /O(n)/. Convert the set to a non-empty list of elements. 213 | toList :: NEIntSet -> NonEmpty Key 214 | toList (NEIntSet x s) = x :| S.toList s 215 | {-# INLINE toList #-} 216 | 217 | -- | /O(m*log(n\/m + 1)), m <= n/. The union of two sets, preferring the first set when 218 | -- equal elements are encountered. 219 | union :: 220 | NEIntSet -> 221 | NEIntSet -> 222 | NEIntSet 223 | union n1@(NEIntSet x1 s1) n2@(NEIntSet x2 s2) = case compare x1 x2 of 224 | LT -> NEIntSet x1 . S.union s1 . toSet $ n2 225 | EQ -> NEIntSet x1 . S.union s1 $ s2 226 | GT -> NEIntSet x2 . S.union (toSet n1) $ s2 227 | {-# INLINE union #-} 228 | 229 | -- | The union of a non-empty list of sets 230 | unions :: 231 | Foldable1 f => 232 | f NEIntSet -> 233 | NEIntSet 234 | unions (F1.toNonEmpty -> (s :| ss)) = F.foldl' union s ss 235 | {-# INLINE unions #-} 236 | 237 | -- | Left-biased union 238 | instance Semigroup NEIntSet where 239 | (<>) = union 240 | {-# INLINE (<>) #-} 241 | sconcat = unions 242 | {-# INLINE sconcat #-} 243 | 244 | -- | /O(n)/. Test if the internal set structure is valid. 245 | valid :: NEIntSet -> Bool 246 | valid (NEIntSet x s) = all ((x <) . fst) (S.minView s) 247 | 248 | -- | /O(log n)/. Insert new value into a set where values are 249 | -- /strictly greater than/ the new values That is, the new value must be 250 | -- /strictly less than/ all values present in the 'IntSet'. /The precondition 251 | -- is not checked./ 252 | -- 253 | -- At the moment this is simply an alias for @Data.IntSet.insert@, but it's 254 | -- left here as a placeholder in case this eventually gets implemented in 255 | -- a more efficient way. 256 | 257 | -- TODO: implementation 258 | insertMinSet :: Key -> IntSet -> IntSet 259 | insertMinSet = S.insert 260 | {-# INLINEABLE insertMinSet #-} 261 | 262 | -- | /O(log n)/. Insert new value into a set where values are /strictly 263 | -- less than/ the new value. That is, the new value must be /strictly 264 | -- greater than/ all values present in the 'IntSet'. /The precondition is not 265 | -- checked./ 266 | -- 267 | -- At the moment this is simply an alias for @Data.IntSet.insert@, but it's 268 | -- left here as a placeholder in case this eventually gets implemented in 269 | -- a more efficient way. 270 | 271 | -- TODO: implementation 272 | insertMaxSet :: Key -> IntSet -> IntSet 273 | insertMaxSet = S.insert 274 | {-# INLINEABLE insertMaxSet #-} 275 | -------------------------------------------------------------------------------- /src/Data/Map/NonEmpty/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | {-# OPTIONS_HADDOCK not-home #-} 7 | 8 | -- | 9 | -- Module : Data.Map.NonEmpty.Internal 10 | -- Copyright : (c) Justin Le 2018 11 | -- License : BSD3 12 | -- 13 | -- Maintainer : justin@jle.im 14 | -- Stability : experimental 15 | -- Portability : non-portable 16 | -- 17 | -- Unsafe internal-use functions used in the implementation of 18 | -- "Data.Map.NonEmpty". These functions can potentially be used to break 19 | -- the abstraction of 'NEMap' and produce unsound maps, so be wary! 20 | module Data.Map.NonEmpty.Internal ( 21 | -- * Non-Empty Map type 22 | NEMap (..), 23 | singleton, 24 | nonEmptyMap, 25 | withNonEmpty, 26 | fromList, 27 | toList, 28 | map, 29 | insertWith, 30 | union, 31 | unions, 32 | elems, 33 | size, 34 | toMap, 35 | 36 | -- * Folds 37 | foldr, 38 | foldr', 39 | foldr1, 40 | foldl, 41 | foldl', 42 | foldl1, 43 | 44 | -- * Traversals 45 | traverseWithKey, 46 | traverseWithKey1, 47 | foldMapWithKey, 48 | 49 | -- * Unsafe Map Functions 50 | insertMinMap, 51 | insertMaxMap, 52 | 53 | -- * Debug 54 | valid, 55 | ) where 56 | 57 | import Control.Applicative 58 | import Control.Comonad 59 | import Control.DeepSeq 60 | import Control.Monad 61 | import qualified Data.Aeson as A 62 | import Data.Coerce 63 | import Data.Data 64 | import qualified Data.Foldable as F 65 | import Data.Function 66 | import Data.Functor.Alt 67 | import Data.Functor.Classes 68 | import Data.Functor.Invariant 69 | import Data.List.NonEmpty (NonEmpty (..)) 70 | import qualified Data.Map as M 71 | import Data.Map.Internal (Map (..)) 72 | import qualified Data.Map.Internal as M 73 | import Data.Maybe 74 | import Data.Semigroup 75 | import Data.Semigroup.Foldable (Foldable1 (fold1)) 76 | import qualified Data.Semigroup.Foldable as F1 77 | import Data.Semigroup.Traversable (Traversable1 (..)) 78 | import Text.Read 79 | import Prelude hiding (Foldable (..), map) 80 | 81 | -- | A non-empty (by construction) map from keys @k@ to values @a@. At 82 | -- least one key-value pair exists in an @'NEMap' k v@ at all times. 83 | -- 84 | -- Functions that /take/ an 'NEMap' can safely operate on it with the 85 | -- assumption that it has at least one key-value pair. 86 | -- 87 | -- Functions that /return/ an 'NEMap' provide an assurance that the result 88 | -- has at least one key-value pair. 89 | -- 90 | -- "Data.Map.NonEmpty" re-exports the API of "Data.Map", faithfully 91 | -- reproducing asymptotics, typeclass constraints, and semantics. 92 | -- Functions that ensure that input and output maps are both non-empty 93 | -- (like 'Data.Map.NonEmpty.insert') return 'NEMap', but functions that 94 | -- might potentially return an empty map (like 'Data.Map.NonEmpty.delete') 95 | -- return a 'Map' instead. 96 | -- 97 | -- You can directly construct an 'NEMap' with the API from 98 | -- "Data.Map.NonEmpty"; it's more or less the same as constructing a normal 99 | -- 'Map', except you don't have access to 'Data.Map.empty'. There are also 100 | -- a few ways to construct an 'NEMap' from a 'Map': 101 | -- 102 | -- 1. The 'nonEmptyMap' smart constructor will convert a @'Map' k a@ into 103 | -- a @'Maybe' ('NEMap' k a)@, returning 'Nothing' if the original 'Map' 104 | -- was empty. 105 | -- 2. You can use the 'Data.Map.NonEmpty.insertMap' family of functions to 106 | -- insert a value into a 'Map' to create a guaranteed 'NEMap'. 107 | -- 3. You can use the 'Data.Map.NonEmpty.IsNonEmpty' and 108 | -- 'Data.Map.NonEmpty.IsEmpty' patterns to "pattern match" on a 'Map' 109 | -- to reveal it as either containing a 'NEMap' or an empty map. 110 | -- 4. 'withNonEmpty' offers a continuation-based interface for 111 | -- deconstructing a 'Map' and treating it as if it were an 'NEMap'. 112 | -- 113 | -- You can convert an 'NEMap' into a 'Map' with 'toMap' or 114 | -- 'Data.Map.NonEmpty.IsNonEmpty', essentially "obscuring" the non-empty 115 | -- property from the type. 116 | data NEMap k a 117 | = NEMap 118 | { nemK0 :: !k 119 | -- ^ invariant: must be smaller than smallest key in map 120 | , nemV0 :: a 121 | , nemMap :: !(Map k a) 122 | } 123 | deriving (Typeable) 124 | 125 | instance (Eq k, Eq a) => Eq (NEMap k a) where 126 | t1 == t2 = 127 | M.size (nemMap t1) == M.size (nemMap t2) 128 | && toList t1 == toList t2 129 | 130 | instance (Ord k, Ord a) => Ord (NEMap k a) where 131 | compare = compare `on` toList 132 | (<) = (<) `on` toList 133 | (>) = (>) `on` toList 134 | (<=) = (<=) `on` toList 135 | (>=) = (>=) `on` toList 136 | 137 | instance Eq2 NEMap where 138 | liftEq2 eqk eqv m n = 139 | size m == size n && liftEq (liftEq2 eqk eqv) (toList m) (toList n) 140 | 141 | instance Eq k => Eq1 (NEMap k) where 142 | liftEq = liftEq2 (==) 143 | 144 | instance Ord2 NEMap where 145 | liftCompare2 cmpk cmpv m n = 146 | liftCompare (liftCompare2 cmpk cmpv) (toList m) (toList n) 147 | 148 | instance Ord k => Ord1 (NEMap k) where 149 | liftCompare = liftCompare2 compare 150 | 151 | instance Show2 NEMap where 152 | liftShowsPrec2 spk slk spv slv d m = 153 | showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) 154 | where 155 | sp = liftShowsPrec2 spk slk spv slv 156 | sl = liftShowList2 spk slk spv slv 157 | 158 | instance Show k => Show1 (NEMap k) where 159 | liftShowsPrec = liftShowsPrec2 showsPrec showList 160 | 161 | instance (Ord k, Read k) => Read1 (NEMap k) where 162 | liftReadsPrec rp rl = 163 | readsData $ 164 | readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList 165 | where 166 | rp' = liftReadsPrec rp rl 167 | rl' = liftReadList rp rl 168 | 169 | instance (Ord k, Read k, Read e) => Read (NEMap k e) where 170 | readPrec = parens $ prec 10 $ do 171 | Ident "fromList" <- lexP 172 | xs <- parens . prec 10 $ readPrec 173 | return (fromList xs) 174 | readListPrec = readListPrecDefault 175 | 176 | instance (Show k, Show a) => Show (NEMap k a) where 177 | showsPrec d m = 178 | showParen (d > 10) $ 179 | showString "fromList (" . shows (toList m) . showString ")" 180 | 181 | instance (NFData k, NFData a) => NFData (NEMap k a) where 182 | rnf (NEMap k v a) = rnf k `seq` rnf v `seq` rnf a 183 | 184 | -- Data instance code from Data.Map.Internal 185 | -- 186 | -- Copyright : (c) Daan Leijen 2002 187 | -- (c) Andriy Palamarchuk 2008 188 | #if MIN_VERSION_base(4,16,0) 189 | instance (Data k, Data a, Ord k) => Data (NEMap k a) where 190 | gfoldl f z m = z fromList `f` toList m 191 | toConstr _ = fromListConstr 192 | gunfold k z c = case constrIndex c of 193 | 1 -> k (z fromList) 194 | _ -> error "gunfold" 195 | dataTypeOf _ = mapDataType 196 | dataCast2 = gcast2 197 | #else 198 | #ifndef __HLINT__ 199 | instance (Data k, Data a, Ord k) => Data (NEMap k a) where 200 | gfoldl f z m = z fromList `f` toList m 201 | toConstr _ = fromListConstr 202 | gunfold k z c = case constrIndex c of 203 | 1 -> k (z fromList) 204 | _ -> error "gunfold" 205 | dataTypeOf _ = mapDataType 206 | dataCast2 f = gcast2 f 207 | #endif 208 | #endif 209 | 210 | fromListConstr :: Constr 211 | fromListConstr = mkConstr mapDataType "fromList" [] Prefix 212 | 213 | mapDataType :: DataType 214 | mapDataType = mkDataType "Data.Map.NonEmpty.NonEmpty.Internal.NEMap" [fromListConstr] 215 | 216 | instance (A.ToJSONKey k, A.ToJSON a) => A.ToJSON (NEMap k a) where 217 | toJSON = A.toJSON . toMap 218 | toEncoding = A.toEncoding . toMap 219 | 220 | instance (A.FromJSONKey k, Ord k, A.FromJSON a) => A.FromJSON (NEMap k a) where 221 | parseJSON = 222 | withNonEmpty (fail err) pure 223 | <=< A.parseJSON 224 | where 225 | err = "NEMap: Non-empty map expected, but empty map found" 226 | 227 | -- | @since 0.3.4.4 228 | instance Ord k => Alt (NEMap k) where 229 | () = union 230 | {-# INLINE () #-} 231 | 232 | -- | /O(n)/. Fold the values in the map using the given right-associative 233 | -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. 234 | -- 235 | -- > elemsList map = foldr (:) [] map 236 | -- 237 | -- > let f a len = len + (length a) 238 | -- > foldr f 0 (fromList ((5,"a") :| [(3,"bbb")])) == 4 239 | foldr :: (a -> b -> b) -> b -> NEMap k a -> b 240 | foldr f z (NEMap _ v m) = v `f` M.foldr f z m 241 | {-# INLINE foldr #-} 242 | 243 | -- | /O(n)/. A strict version of 'foldr'. Each application of the operator 244 | -- is evaluated before using the result in the next application. This 245 | -- function is strict in the starting value. 246 | foldr' :: (a -> b -> b) -> b -> NEMap k a -> b 247 | foldr' f z (NEMap _ v m) = v `f` y 248 | where 249 | !y = M.foldr' f z m 250 | {-# INLINE foldr' #-} 251 | 252 | -- | /O(n)/. A version of 'foldr' that uses the value at the maximal key in 253 | -- the map as the starting value. 254 | -- 255 | -- Note that, unlike 'Data.Foldable.foldr1' for 'Map', this function is 256 | -- total if the input function is total. 257 | foldr1 :: (a -> a -> a) -> NEMap k a -> a 258 | foldr1 f (NEMap _ v m) = 259 | maybe v (f v . uncurry (M.foldr f)) 260 | . M.maxView 261 | $ m 262 | {-# INLINE foldr1 #-} 263 | 264 | -- | /O(n)/. Fold the values in the map using the given left-associative 265 | -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. 266 | -- 267 | -- > elemsList = reverse . foldl (flip (:)) [] 268 | -- 269 | -- > let f len a = len + (length a) 270 | -- > foldl f 0 (fromList ((5,"a") :| [(3,"bbb")])) == 4 271 | foldl :: (a -> b -> a) -> a -> NEMap k b -> a 272 | foldl f z (NEMap _ v m) = M.foldl f (f z v) m 273 | {-# INLINE foldl #-} 274 | 275 | -- | /O(n)/. A strict version of 'foldl'. Each application of the operator 276 | -- is evaluated before using the result in the next application. This 277 | -- function is strict in the starting value. 278 | foldl' :: (a -> b -> a) -> a -> NEMap k b -> a 279 | foldl' f z (NEMap _ v m) = M.foldl' f x m 280 | where 281 | !x = f z v 282 | {-# INLINE foldl' #-} 283 | 284 | -- | /O(n)/. A version of 'foldl' that uses the value at the minimal key in 285 | -- the map as the starting value. 286 | -- 287 | -- Note that, unlike 'Data.Foldable.foldl1' for 'Map', this function is 288 | -- total if the input function is total. 289 | foldl1 :: (a -> a -> a) -> NEMap k a -> a 290 | foldl1 f (NEMap _ v m) = M.foldl f v m 291 | {-# INLINE foldl1 #-} 292 | 293 | -- | /O(n)/. Fold the keys and values in the map using the given semigroup, 294 | -- such that 295 | -- 296 | -- @'foldMapWithKey' f = 'Data.Semigroup.Foldable.fold1' . 'Data.Map.NonEmpty.mapWithKey' f@ 297 | -- 298 | -- This can be an asymptotically faster than 299 | -- 'Data.Map.NonEmpty.foldrWithKey' or 'Data.Map.NonEmpty.foldlWithKey' for 300 | -- some monoids. 301 | 302 | -- TODO: benchmark against maxView method 303 | foldMapWithKey :: 304 | Semigroup m => 305 | (k -> a -> m) -> 306 | NEMap k a -> 307 | m 308 | #if MIN_VERSION_base(4,11,0) 309 | foldMapWithKey f (NEMap k0 v m) = maybe (f k0 v) (f k0 v <>) 310 | . M.foldMapWithKey (\k -> Just . f k) 311 | $ m 312 | #else 313 | foldMapWithKey f (NEMap k0 v m) = option (f k0 v) (f k0 v <>) 314 | . M.foldMapWithKey (\k -> Option . Just . f k) 315 | $ m 316 | #endif 317 | {-# INLINE foldMapWithKey #-} 318 | 319 | -- | /O(n)/. Map a function over all values in the map. 320 | -- 321 | -- > map (++ "x") (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "bx") :| [(5, "ax")]) 322 | map :: (a -> b) -> NEMap k a -> NEMap k b 323 | map f (NEMap k0 v m) = NEMap k0 (f v) (M.map f m) 324 | {-# NOINLINE [1] map #-} 325 | 326 | {-# RULES 327 | "map/map" forall f g xs. map f (map g xs) = map (f . g) xs 328 | #-} 329 | {-# RULES 330 | "map/coerce" map coerce = coerce 331 | #-} 332 | 333 | -- | /O(m*log(n\/m + 1)), m <= n/. 334 | -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and 335 | -- @t2@. It prefers @t1@ when duplicate keys are encountered, i.e. 336 | -- (@'union' == 'Data.Map.NonEmpty.unionWith' 'const'@). 337 | -- 338 | -- > union (fromList ((5, "a") :| [(3, "b")])) (fromList ((5, "A") :| [(7, "C")])) == fromList ((3, "b") :| [(5, "a"), (7, "C")]) 339 | union :: 340 | Ord k => 341 | NEMap k a -> 342 | NEMap k a -> 343 | NEMap k a 344 | union n1@(NEMap k1 v1 m1) n2@(NEMap k2 v2 m2) = case compare k1 k2 of 345 | LT -> NEMap k1 v1 . M.union m1 . toMap $ n2 346 | EQ -> NEMap k1 v1 . M.union m1 $ m2 347 | GT -> NEMap k2 v2 . M.union (toMap n1) $ m2 348 | {-# INLINE union #-} 349 | 350 | -- | The left-biased union of a non-empty list of maps. 351 | -- 352 | -- > unions (fromList ((5, "a") :| [(3, "b")]) :| [fromList ((5, "A") :| [(7, "C")]), fromList ((5, "A3") :| [(3, "B3")])]) 353 | -- > == fromList [(3, "b"), (5, "a"), (7, "C")] 354 | -- > unions (fromList ((5, "A3") :| [(3, "B3")]) :| [fromList ((5, "A") :| [(7, "C")]), fromList ((5, "a") :| [(3, "b")])]) 355 | -- > == fromList ((3, "B3") :| [(5, "A3"), (7, "C")]) 356 | unions :: 357 | (Foldable1 f, Ord k) => 358 | f (NEMap k a) -> 359 | NEMap k a 360 | unions (F1.toNonEmpty -> (m :| ms)) = F.foldl' union m ms 361 | {-# INLINE unions #-} 362 | 363 | -- | /O(n)/. 364 | -- Return all elements of the map in the ascending order of their keys. 365 | -- 366 | -- > elems (fromList ((5,"a") :| [(3,"b")])) == ("b" :| ["a"]) 367 | elems :: NEMap k a -> NonEmpty a 368 | elems (NEMap _ v m) = v :| M.elems m 369 | {-# INLINE elems #-} 370 | 371 | -- | /O(1)/. The number of elements in the map. Guaranteed to be greater 372 | -- than zero. 373 | -- 374 | -- > size (singleton 1 'a') == 1 375 | -- > size (fromList ((1,'a') :| [(2,'c'), (3,'b')])) == 3 376 | size :: NEMap k a -> Int 377 | size (NEMap _ _ m) = 1 + M.size m 378 | {-# INLINE size #-} 379 | 380 | -- | /O(log n)/. 381 | -- Convert a non-empty map back into a normal possibly-empty map, for usage 382 | -- with functions that expect 'Map'. 383 | -- 384 | -- Can be thought of as "obscuring" the non-emptiness of the map in its 385 | -- type. See the 'Data.Map.NonEmpty.IsNotEmpty' pattern. 386 | -- 387 | -- 'nonEmptyMap' and @'maybe' 'Data.Map.empty' 'toMap'@ form an isomorphism: they 388 | -- are perfect structure-preserving inverses of eachother. 389 | -- 390 | -- > toMap (fromList ((3,"a") :| [(5,"b")])) == Data.Map.fromList [(3,"a"), (5,"b")] 391 | toMap :: NEMap k a -> Map k a 392 | toMap (NEMap k v m) = insertMinMap k v m 393 | {-# INLINE toMap #-} 394 | 395 | -- | /O(n)/. 396 | -- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ 397 | -- That is, behaves exactly like a regular 'traverse' except that the traversing 398 | -- function also has access to the key associated with a value. 399 | -- 400 | -- /Use 'traverseWithKey1'/ whenever possible (if your 'Applicative' 401 | -- also has 'Apply' instance). This version is provided only for types 402 | -- that do not have 'Apply' instance, since 'Apply' is not at the moment 403 | -- (and might not ever be) an official superclass of 'Applicative'. 404 | -- 405 | -- @ 406 | -- 'traverseWithKey' f = 'unwrapApplicative' . 'traverseWithKey1' (\\k -> WrapApplicative . f k) 407 | -- @ 408 | traverseWithKey :: 409 | Applicative t => 410 | (k -> a -> t b) -> 411 | NEMap k a -> 412 | t (NEMap k b) 413 | traverseWithKey f (NEMap k v m0) = NEMap k <$> f k v <*> M.traverseWithKey f m0 414 | {-# INLINE traverseWithKey #-} 415 | 416 | -- | /O(n)/. 417 | -- @'traverseWithKey1' f m == 'fromList' <$> 'traverse1' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ 418 | -- 419 | -- That is, behaves exactly like a regular 'traverse1' except that the traversing 420 | -- function also has access to the key associated with a value. 421 | -- 422 | -- Is more general than 'traverseWithKey', since works with all 'Apply', 423 | -- and not just 'Applicative'. 424 | 425 | -- TODO: benchmark against maxView-based methods 426 | traverseWithKey1 :: 427 | Apply t => 428 | (k -> a -> t b) -> 429 | NEMap k a -> 430 | t (NEMap k b) 431 | traverseWithKey1 f (NEMap k0 v m0) = case runMaybeApply m1 of 432 | Left m2 -> NEMap k0 <$> f k0 v <.> m2 433 | Right m2 -> flip (NEMap k0) m2 <$> f k0 v 434 | where 435 | m1 = M.traverseWithKey (\k -> MaybeApply . Left . f k) m0 436 | {-# INLINEABLE traverseWithKey1 #-} 437 | 438 | -- | /O(n)/. Convert the map to a non-empty list of key\/value pairs. 439 | -- 440 | -- > toList (fromList ((5,"a") :| [(3,"b")])) == ((3,"b") :| [(5,"a")]) 441 | toList :: NEMap k a -> NonEmpty (k, a) 442 | toList (NEMap k v m) = (k, v) :| M.toList m 443 | {-# INLINE toList #-} 444 | 445 | -- | /O(log n)/. Smart constructor for an 'NEMap' from a 'Map'. Returns 446 | -- 'Nothing' if the 'Map' was originally actually empty, and @'Just' n@ 447 | -- with an 'NEMap', if the 'Map' was not empty. 448 | -- 449 | -- 'nonEmptyMap' and @'maybe' 'Data.Map.empty' 'toMap'@ form an 450 | -- isomorphism: they are perfect structure-preserving inverses of 451 | -- eachother. 452 | -- 453 | -- See 'Data.Map.NonEmpty.IsNonEmpty' for a pattern synonym that lets you 454 | -- "match on" the possiblity of a 'Map' being an 'NEMap'. 455 | -- 456 | -- > nonEmptyMap (Data.Map.fromList [(3,"a"), (5,"b")]) == Just (fromList ((3,"a") :| [(5,"b")])) 457 | nonEmptyMap :: Map k a -> Maybe (NEMap k a) 458 | nonEmptyMap = (fmap . uncurry . uncurry) NEMap . M.minViewWithKey 459 | {-# INLINE nonEmptyMap #-} 460 | 461 | -- | /O(log n)/. A general continuation-based way to consume a 'Map' as if 462 | -- it were an 'NEMap'. @'withNonEmpty' def f@ will take a 'Map'. If map is 463 | -- empty, it will evaluate to @def@. Otherwise, a non-empty map 'NEMap' 464 | -- will be fed to the function @f@ instead. 465 | -- 466 | -- @'nonEmptyMap' == 'withNonEmpty' 'Nothing' 'Just'@ 467 | withNonEmpty :: 468 | -- | value to return if map is empty 469 | r -> 470 | -- | function to apply if map is not empty 471 | (NEMap k a -> r) -> 472 | Map k a -> 473 | r 474 | withNonEmpty def f = maybe def f . nonEmptyMap 475 | {-# INLINE withNonEmpty #-} 476 | 477 | -- | /O(n*log n)/. Build a non-empty map from a non-empty list of 478 | -- key\/value pairs. See also 'Data.Map.NonEmpty.fromAscList'. If the list 479 | -- contains more than one value for the same key, the last value for the 480 | -- key is retained. 481 | -- 482 | -- > fromList ((5,"a") :| [(3,"b"), (5, "c")]) == fromList ((5,"c") :| [(3,"b")]) 483 | -- > fromList ((5,"c") :| [(3,"b"), (5, "a")]) == fromList ((5,"a") :| [(3,"b")]) 484 | 485 | -- TODO: write manually and optimize to be equivalent to 486 | -- 'fromDistinctAscList' if items are ordered, just like the actual 487 | -- 'M.fromList'. 488 | fromList :: Ord k => NonEmpty (k, a) -> NEMap k a 489 | fromList ((k, v) :| xs) = 490 | withNonEmpty (singleton k v) (insertWith (const id) k v) 491 | . M.fromList 492 | $ xs 493 | {-# INLINE fromList #-} 494 | 495 | -- | /O(1)/. A map with a single element. 496 | -- 497 | -- > singleton 1 'a' == fromList ((1, 'a') :| []) 498 | -- > size (singleton 1 'a') == 1 499 | singleton :: k -> a -> NEMap k a 500 | singleton k v = NEMap k v M.empty 501 | {-# INLINE singleton #-} 502 | 503 | -- | /O(log n)/. Insert with a function, combining new value and old value. 504 | -- @'insertWith' f key value mp@ will insert the pair (key, value) into 505 | -- @mp@ if key does not exist in the map. If the key does exist, the 506 | -- function will insert the pair @(key, f new_value old_value)@. 507 | -- 508 | -- See 'Data.Map.NonEmpty.insertMapWith' for a version where the first 509 | -- argument is a 'Map'. 510 | -- 511 | -- > insertWith (++) 5 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "xxxa")]) 512 | -- > insertWith (++) 7 "xxx" (fromList ((5,"a") :| [(3,"b")])) == fromList ((3, "b") :| [(5, "a"), (7, "xxx")]) 513 | insertWith :: 514 | Ord k => 515 | (a -> a -> a) -> 516 | k -> 517 | a -> 518 | NEMap k a -> 519 | NEMap k a 520 | insertWith f k v n@(NEMap k0 v0 m) = case compare k k0 of 521 | LT -> NEMap k v . toMap $ n 522 | EQ -> NEMap k (f v v0) m 523 | GT -> NEMap k0 v0 $ M.insertWith f k v m 524 | {-# INLINE insertWith #-} 525 | 526 | -- | Left-biased union 527 | instance Ord k => Semigroup (NEMap k a) where 528 | (<>) = union 529 | {-# INLINE (<>) #-} 530 | sconcat = unions 531 | {-# INLINE sconcat #-} 532 | 533 | instance Functor (NEMap k) where 534 | fmap = map 535 | {-# INLINE fmap #-} 536 | x <$ NEMap k _ m = NEMap k x (x <$ m) 537 | {-# INLINE (<$) #-} 538 | 539 | -- | @since 0.3.4.4 540 | instance Invariant (NEMap k) where 541 | invmap f _ = fmap f 542 | {-# INLINE invmap #-} 543 | 544 | -- | Traverses elements in order of ascending keys 545 | -- 546 | -- 'Data.Foldable.foldr1', 'Data.Foldable.foldl1', 'Data.Foldable.minimum', 547 | -- 'Data.Foldable.maximum' are all total. 548 | #if MIN_VERSION_base(4,11,0) 549 | instance F.Foldable (NEMap k) where 550 | fold (NEMap _ v m) = v <> F.fold m 551 | {-# INLINE fold #-} 552 | foldMap f (NEMap _ v m) = f v <> F.foldMap f m 553 | {-# INLINE foldMap #-} 554 | foldr = foldr 555 | {-# INLINE foldr #-} 556 | foldr' = foldr' 557 | {-# INLINE foldr' #-} 558 | foldr1 = foldr1 559 | {-# INLINE foldr1 #-} 560 | foldl = foldl 561 | {-# INLINE foldl #-} 562 | foldl' = foldl' 563 | {-# INLINE foldl' #-} 564 | foldl1 = foldl1 565 | {-# INLINE foldl1 #-} 566 | null _ = False 567 | {-# INLINE null #-} 568 | length = size 569 | {-# INLINE length #-} 570 | elem x (NEMap _ v m) = F.elem x m 571 | || x == v 572 | {-# INLINE elem #-} 573 | -- TODO: use build 574 | toList = F.toList . elems 575 | {-# INLINE toList #-} 576 | #else 577 | instance F.Foldable (NEMap k) where 578 | fold (NEMap _ v m) = v `mappend` F.fold m 579 | {-# INLINE fold #-} 580 | foldMap f (NEMap _ v m) = f v `mappend` F.foldMap f m 581 | {-# INLINE foldMap #-} 582 | foldr = foldr 583 | {-# INLINE foldr #-} 584 | foldr' = foldr' 585 | {-# INLINE foldr' #-} 586 | foldr1 = foldr1 587 | {-# INLINE foldr1 #-} 588 | foldl = foldl 589 | {-# INLINE foldl #-} 590 | foldl' = foldl' 591 | {-# INLINE foldl' #-} 592 | foldl1 = foldl1 593 | {-# INLINE foldl1 #-} 594 | null _ = False 595 | {-# INLINE null #-} 596 | length = size 597 | {-# INLINE length #-} 598 | elem x (NEMap _ v m) = F.elem x m 599 | || x == v 600 | {-# INLINE elem #-} 601 | -- TODO: use build 602 | toList = F.toList . elems 603 | {-# INLINE toList #-} 604 | #endif 605 | 606 | -- | Traverses elements in order of ascending keys 607 | instance Traversable (NEMap k) where 608 | traverse f (NEMap k v m) = NEMap k <$> f v <*> traverse f m 609 | {-# INLINE traverse #-} 610 | sequenceA (NEMap k v m) = NEMap k <$> v <*> sequenceA m 611 | {-# INLINE sequenceA #-} 612 | 613 | -- | Traverses elements in order of ascending keys 614 | #if MIN_VERSION_base(4,11,0) 615 | instance Foldable1 (NEMap k) where 616 | fold1 (NEMap _ v m) = maybe v (v <>) 617 | . F.foldMap Just 618 | $ m 619 | {-# INLINE fold1 #-} 620 | foldMap1 f = foldMapWithKey (const f) 621 | {-# INLINE foldMap1 #-} 622 | toNonEmpty = elems 623 | {-# INLINE toNonEmpty #-} 624 | #else 625 | instance Foldable1 (NEMap k) where 626 | fold1 (NEMap _ v m) = option v (v <>) 627 | . F.foldMap (Option . Just) 628 | $ m 629 | {-# INLINE fold1 #-} 630 | foldMap1 f = foldMapWithKey (const f) 631 | {-# INLINE foldMap1 #-} 632 | toNonEmpty = elems 633 | {-# INLINE toNonEmpty #-} 634 | #endif 635 | 636 | -- | Traverses elements in order of ascending keys 637 | instance Traversable1 (NEMap k) where 638 | traverse1 f = traverseWithKey1 (const f) 639 | {-# INLINE traverse1 #-} 640 | sequence1 (NEMap k v m0) = case runMaybeApply m1 of 641 | Left m2 -> NEMap k <$> v <.> m2 642 | Right m2 -> flip (NEMap k) m2 <$> v 643 | where 644 | m1 = traverse (MaybeApply . Left) m0 645 | {-# INLINEABLE sequence1 #-} 646 | 647 | -- | 'extract' gets the value at the minimal key, and 'duplicate' produces 648 | -- a map of maps comprised of all keys from the original map greater than 649 | -- or equal to the current key. 650 | -- 651 | -- @since 0.1.1.0 652 | instance Comonad (NEMap k) where 653 | extract = nemV0 654 | {-# INLINE extract #-} 655 | duplicate n0@(NEMap k0 _ m0) = 656 | NEMap k0 n0 657 | . snd 658 | . M.mapAccumWithKey go m0 659 | $ m0 660 | where 661 | go m k v = (m', NEMap k v m') 662 | where 663 | !m' = M.deleteMin m 664 | {-# INLINE duplicate #-} 665 | 666 | -- | /O(n)/. Test if the internal map structure is valid. 667 | valid :: Ord k => NEMap k a -> Bool 668 | valid (NEMap k _ m) = 669 | M.valid m 670 | && all ((k <) . fst . fst) (M.minViewWithKey m) 671 | 672 | -- | /O(log n)/. Insert new key and value into a map where keys are 673 | -- /strictly greater than/ the new key. That is, the new key must be 674 | -- /strictly less than/ all keys present in the 'Map'. /The precondition 675 | -- is not checked./ 676 | -- 677 | -- While this has the same asymptotics as @Data.Map.insert@, it saves 678 | -- a constant factor for key comparison (so may be helpful if comparison is 679 | -- expensive) and also does not require an 'Ord' instance for the key type. 680 | insertMinMap :: k -> a -> Map k a -> Map k a 681 | insertMinMap kx x = \case 682 | Tip -> M.singleton kx x 683 | Bin _ ky y l r -> M.balanceL ky y (insertMinMap kx x l) r 684 | {-# INLINEABLE insertMinMap #-} 685 | 686 | -- | /O(log n)/. Insert new key and value into a map where keys are 687 | -- /strictly less than/ the new key. That is, the new key must be 688 | -- /strictly greater than/ all keys present in the 'Map'. /The 689 | -- precondition is not checked./ 690 | -- 691 | -- While this has the same asymptotics as @Data.Map.insert@, it saves 692 | -- a constant factor for key comparison (so may be helpful if comparison is 693 | -- expensive) and also does not require an 'Ord' instance for the key type. 694 | insertMaxMap :: k -> a -> Map k a -> Map k a 695 | insertMaxMap kx x = \case 696 | Tip -> M.singleton kx x 697 | Bin _ ky y l r -> M.balanceR ky y l (insertMaxMap kx x r) 698 | {-# INLINEABLE insertMaxMap #-} 699 | -------------------------------------------------------------------------------- /src/Data/Sequence/NonEmpty/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveTraversable #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | {-# OPTIONS_HADDOCK not-home #-} 9 | 10 | -- | 11 | -- Module : Data.Sequence.NonEmpty.Internal 12 | -- Copyright : (c) Justin Le 2018 13 | -- License : BSD3 14 | -- 15 | -- Maintainer : justin@jle.im 16 | -- Stability : experimental 17 | -- Portability : non-portable 18 | -- 19 | -- Unsafe internal-use functions used in the implementation of 20 | -- "Data.Sequence.NonEmpty". These functions can potentially be used to 21 | -- break the abstraction of 'NESeq' and produce unsound sequences, so be 22 | -- wary! 23 | module Data.Sequence.NonEmpty.Internal ( 24 | NESeq (..), 25 | pattern (:<||), 26 | pattern (:||>), 27 | withNonEmpty, 28 | toSeq, 29 | singleton, 30 | length, 31 | fromList, 32 | fromFunction, 33 | replicate, 34 | index, 35 | (<|), 36 | (><), 37 | (|><), 38 | map, 39 | foldMapWithIndex, 40 | traverseWithIndex1, 41 | tails, 42 | zip, 43 | zipWith, 44 | unzip, 45 | ) where 46 | 47 | import Control.Comonad 48 | import Control.DeepSeq 49 | import Control.Monad 50 | import Control.Monad.Fix 51 | import Control.Monad.Zip 52 | import qualified Data.Aeson as A 53 | import Data.Bifunctor 54 | import Data.Coerce 55 | import Data.Data 56 | import qualified Data.Foldable as F 57 | import Data.Functor.Alt 58 | import Data.Functor.Bind 59 | import Data.Functor.Classes 60 | import Data.Functor.Extend 61 | import Data.Functor.Invariant 62 | import Data.List.NonEmpty (NonEmpty (..)) 63 | import Data.Semigroup 64 | import Data.Semigroup.Foldable 65 | import Data.Semigroup.Traversable 66 | import Data.Sequence (Seq (..)) 67 | import qualified Data.Sequence as Seq 68 | import Text.Read 69 | import Prelude hiding (length, map, replicate, unzip, zip, zipWith) 70 | 71 | {-# ANN module "HLint: ignore Avoid NonEmpty.unzip" #-} 72 | 73 | -- | A general-purpose non-empty (by construction) finite sequence type. 74 | -- 75 | -- Non-emptiness means that: 76 | -- 77 | -- * Functions that /take/ an 'NESeq' can safely operate on it with the 78 | -- assumption that it has at least value. 79 | -- * Functions that /return/ an 'NESeq' provide an assurance that the 80 | -- result has at least one value. 81 | -- 82 | -- "Data.Sequence.NonEmpty" re-exports the API of "Data.Sequence", 83 | -- faithfully reproducing asymptotics, typeclass constraints, and 84 | -- semantics. Functions that ensure that input and output maps are both 85 | -- non-empty (like 'Data.Sequence.NonEmpty.<|') return 'NESeq', but 86 | -- functions that might potentially return an empty map (like 87 | -- 'Data.Sequence.NonEmpty.tail') return a 'Seq' instead. 88 | -- 89 | -- You can directly construct an 'NESeq' with the API from 90 | -- "Data.Sequence.NonEmpty"; it's more or less the same as constructing 91 | -- a normal 'Seq', except you don't have access to 'Data.Seq.empty'. There 92 | -- are also a few ways to construct an 'NESeq' from a 'Seq': 93 | -- 94 | -- 1. The 'Data.Sequence.NonEmpty.nonEmptySeq' smart constructor will 95 | -- convert a @'Seq' a@ into a @'Maybe' ('NESeq' a)@, returning 'Nothing' if 96 | -- the original 'Seq' was empty. 97 | -- 2. You can use 'Data.Sequence.NonEmpty.:<||', 98 | -- 'Data.Sequence.NonEmpty.:||>', and 99 | -- 'Data.Sequence.NonEmpty.insertSeqAt' to insert a value into a 'Seq' 100 | -- to create a guaranteed 'NESeq'. 101 | -- 3. You can use the 'Data.Sequence.NonEmpty.IsNonEmpty' and 102 | -- 'Data.Sequence.NonEmpty.IsEmpty' patterns to "pattern match" on 103 | -- a 'Seq' to reveal it as either containing a 'NESeq' or an empty 104 | -- sequence. 105 | -- 4. 'Data.Sequence.NonEmpty.withNonEmpty' offers a continuation-based 106 | -- interface for deconstructing a 'Seq' and treating it as if it were an 107 | -- 'NESeq'. 108 | -- 109 | -- You can convert an 'NESeq' into a 'Seq' with 'toSeq' or 110 | -- 'Data.Sequence.NonEmpty.IsNonEmpty', essentially "obscuring" the 111 | -- non-empty property from the type. 112 | data NESeq a = NESeq 113 | { nesHead :: a 114 | , nesTail :: !(Seq a) 115 | } 116 | deriving (Traversable, Typeable) 117 | 118 | -- | /O(1)/. An abstract constructor for an 'NESeq' that consists of 119 | -- a "head" @a@ and a "tail" @'Seq' a@. Similar to ':|' for 'NonEmpty'. 120 | -- 121 | -- Can be used to match on the head and tail of an 'NESeq', and also used 122 | -- to /construct/ an 'NESeq' by consing an item to the beginnong of 123 | -- a 'Seq', ensuring that the result is non-empty. 124 | pattern (:<||) :: a -> Seq a -> NESeq a 125 | pattern x :<|| xs = NESeq x xs 126 | 127 | {-# COMPLETE (:<||) #-} 128 | 129 | unsnoc :: NESeq a -> (Seq a, a) 130 | unsnoc (x :<|| (xs :|> y)) = (x :<| xs, y) 131 | unsnoc (x :<|| Empty) = (Empty, x) 132 | {-# INLINE unsnoc #-} 133 | 134 | -- | /O(1)/. An abstract constructor for an 'NESeq' that consists of 135 | -- a "init" @'Seq' a@ and a "last" @a@. Similar to ':|' for 'NonEmpty', 136 | -- but at the end of the list instead of at the beginning. 137 | -- 138 | -- Can be used to match on the init and last of an 'NESeq', and also used 139 | -- to /construct/ an 'NESeq' by snocing an item to the end of a 'Seq', 140 | -- ensuring that the result is non-empty. 141 | pattern (:||>) :: Seq a -> a -> NESeq a 142 | pattern xs :||> x <- (unsnoc -> (!xs, x)) 143 | where 144 | (x :<| xs) :||> y = x :<|| (xs :|> y) 145 | Empty :||> y = y :<|| Empty 146 | 147 | {-# COMPLETE (:||>) #-} 148 | 149 | infixr 5 `NESeq` 150 | infixr 5 :<|| 151 | infixl 5 :||> 152 | 153 | instance Show a => Show (NESeq a) where 154 | showsPrec p xs = 155 | showParen (p > 10) $ 156 | showString "fromList (" . shows (toNonEmpty xs) . showString ")" 157 | 158 | instance Read a => Read (NESeq a) where 159 | readPrec = parens $ prec 10 $ do 160 | Ident "fromList" <- lexP 161 | xs <- parens . prec 10 $ readPrec 162 | return (fromList xs) 163 | readListPrec = readListPrecDefault 164 | 165 | instance Eq a => Eq (NESeq a) where 166 | xs == ys = 167 | length xs == length ys 168 | && toNonEmpty xs == toNonEmpty ys 169 | 170 | instance Ord a => Ord (NESeq a) where 171 | compare xs ys = compare (F.toList xs) (F.toList ys) 172 | 173 | instance Show1 NESeq where 174 | liftShowsPrec sp sl d m = 175 | showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toNonEmpty m) 176 | 177 | instance Read1 NESeq where 178 | liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do 179 | ("fromList", s) <- lex r 180 | (xs, t) <- liftReadsPrec _rp readLst 10 s 181 | pure (fromList xs, t) 182 | 183 | instance Eq1 NESeq where 184 | liftEq eq xs ys = length xs == length ys && liftEq eq (toNonEmpty xs) (toNonEmpty ys) 185 | 186 | instance Ord1 NESeq where 187 | liftCompare cmp xs ys = liftCompare cmp (toNonEmpty xs) (toNonEmpty ys) 188 | 189 | #if MIN_VERSION_base(4,16,0) 190 | instance Data a => Data (NESeq a) where 191 | gfoldl f z (x :<|| xs) = z (:<||) `f` x `f` xs 192 | gunfold k z _ = k (k (z (:<||))) 193 | toConstr _ = consConstr 194 | dataTypeOf _ = seqDataType 195 | dataCast1 = gcast1 196 | #else 197 | #ifndef __HLINT__ 198 | instance Data a => Data (NESeq a) where 199 | gfoldl f z (x :<|| xs) = z (:<||) `f` x `f` xs 200 | gunfold k z _ = k (k (z (:<||))) 201 | toConstr _ = consConstr 202 | dataTypeOf _ = seqDataType 203 | dataCast1 f = gcast1 f 204 | #endif 205 | #endif 206 | 207 | consConstr :: Constr 208 | consConstr = mkConstr seqDataType ":<||" [] Infix 209 | 210 | seqDataType :: DataType 211 | seqDataType = mkDataType "Data.Sequence.NonEmpty.Internal.NESeq" [consConstr] 212 | 213 | instance A.ToJSON a => A.ToJSON (NESeq a) where 214 | toJSON = A.toJSON . toSeq 215 | toEncoding = A.toEncoding . toSeq 216 | 217 | instance A.FromJSON a => A.FromJSON (NESeq a) where 218 | parseJSON = 219 | withNonEmpty (fail err) pure 220 | <=< A.parseJSON 221 | where 222 | err = "NESeq: Non-empty sequence expected, but empty sequence found" 223 | 224 | -- | /O(log n)/. A general continuation-based way to consume a 'Seq' as if 225 | -- it were an 'NESeq'. @'withNonEmpty' def f@ will take a 'Seq'. If map is 226 | -- empty, it will evaluate to @def@. Otherwise, a non-empty map 'NESeq' 227 | -- will be fed to the function @f@ instead. 228 | -- 229 | -- @'Data.Sequence.NonEmpty.nonEmptySeq' == 'withNonEmpty' 'Nothing' 'Just'@ 230 | withNonEmpty :: r -> (NESeq a -> r) -> Seq a -> r 231 | withNonEmpty def f = \case 232 | x :<| xs -> f (x :<|| xs) 233 | Empty -> def 234 | {-# INLINE withNonEmpty #-} 235 | 236 | -- | /O(1)/. 237 | -- Convert a non-empty sequence back into a normal possibly-empty sequence, 238 | -- for usage with functions that expect 'Seq'. 239 | -- 240 | -- Can be thought of as "obscuring" the non-emptiness of the map in its 241 | -- type. See the 'Data.Sequence.NonEmpty.IsNotEmpty' pattern. 242 | -- 243 | -- 'Data.Sequence.NonEmpty.nonEmptySeq' and @'maybe' 'Data.Seq.empty' 244 | -- 'toSeq'@ form an isomorphism: they are perfect structure-preserving 245 | -- inverses of eachother. 246 | toSeq :: NESeq a -> Seq a 247 | toSeq (x :<|| xs) = x :<| xs 248 | {-# INLINE toSeq #-} 249 | 250 | -- | \( O(1) \). A singleton sequence. 251 | singleton :: a -> NESeq a 252 | singleton = (:<|| Seq.empty) 253 | {-# INLINE singleton #-} 254 | 255 | -- | \( O(1) \). The number of elements in the sequence. 256 | length :: NESeq a -> Int 257 | length (_ :<|| xs) = 1 + Seq.length xs 258 | {-# INLINE length #-} 259 | 260 | -- | \( O(n) \). Create a sequence from a finite list of elements. There 261 | -- is a function 'toNonEmpty' in the opposite direction for all instances 262 | -- of the 'Foldable1' class, including 'NESeq'. 263 | fromList :: NonEmpty a -> NESeq a 264 | fromList (x :| xs) = x :<|| Seq.fromList xs 265 | {-# INLINE fromList #-} 266 | 267 | -- | \( O(n) \). Convert a given sequence length and a function representing that 268 | -- sequence into a sequence. 269 | fromFunction :: Int -> (Int -> a) -> NESeq a 270 | fromFunction n f 271 | | n < 1 = error "NESeq.fromFunction: must take a positive integer argument" 272 | | otherwise = f 0 :<|| Seq.fromFunction (n - 1) (f . (+ 1)) 273 | 274 | -- | \( O(\log n) \). @replicate n x@ is a sequence consisting of @n@ 275 | -- copies of @x@. Is only defined when @n@ is positive. 276 | replicate :: Int -> a -> NESeq a 277 | replicate n x 278 | | n < 1 = error "NESeq.replicate: must take a positive integer argument" 279 | | otherwise = x :<|| Seq.replicate (n - 1) x 280 | {-# INLINE replicate #-} 281 | 282 | -- | \( O(\log(\min(i,n-i))) \). The element at the specified position, 283 | -- counting from 0. The argument should thus be a non-negative 284 | -- integer less than the size of the sequence. 285 | -- If the position is out of range, 'index' fails with an error. 286 | -- 287 | -- prop> xs `index` i = toList xs !! i 288 | -- 289 | -- Caution: 'index' necessarily delays retrieving the requested 290 | -- element until the result is forced. It can therefore lead to a space 291 | -- leak if the result is stored, unforced, in another structure. To retrieve 292 | -- an element immediately without forcing it, use 'lookup' or '(!?)'. 293 | index :: NESeq a -> Int -> a 294 | index (x :<|| _) 0 = x 295 | index (_ :<|| xs) i = xs `Seq.index` (i - 1) 296 | {-# INLINE index #-} 297 | 298 | -- | \( O(1) \). Add an element to the left end of a non-empty sequence. 299 | -- Mnemonic: a triangle with the single element at the pointy end. 300 | (<|) :: a -> NESeq a -> NESeq a 301 | x <| xs = x :<|| toSeq xs 302 | {-# INLINE (<|) #-} 303 | 304 | -- | \( O(\log(\min(n_1,n_2))) \). Concatenate two non-empty sequences. 305 | (><) :: NESeq a -> NESeq a -> NESeq a 306 | (x :<|| xs) >< ys = x :<|| (xs Seq.>< toSeq ys) 307 | {-# INLINE (><) #-} 308 | 309 | -- | \( O(\log(\min(n_1,n_2))) \). Concatenate a non-empty sequence with 310 | -- a potentially empty sequence ('Seq'), to produce a guaranteed non-empty 311 | -- sequence. Mnemonic: like '><', but a pipe for the guarunteed non-empty 312 | -- side. 313 | (|><) :: NESeq a -> Seq a -> NESeq a 314 | (x :<|| xs) |>< ys = x :<|| (xs Seq.>< ys) 315 | {-# INLINE (|><) #-} 316 | 317 | infixr 5 <| 318 | infixr 5 >< 319 | infixr 5 |>< 320 | 321 | -- | Defined here but hidden; intended for use with RULES pragma. 322 | map :: (a -> b) -> NESeq a -> NESeq b 323 | map f (x :<|| xs) = f x :<|| fmap f xs 324 | {-# NOINLINE [1] map #-} 325 | 326 | {-# RULES 327 | "map/map" forall f g xs. map f (map g xs) = map (f . g) xs 328 | #-} 329 | {-# RULES 330 | "map/coerce" map coerce = coerce 331 | #-} 332 | 333 | -- | /O(n)/. A generalization of 'foldMap1', 'foldMapWithIndex' takes 334 | -- a folding function that also depends on the element's index, and applies 335 | -- it to every element in the sequence. 336 | foldMapWithIndex :: Semigroup m => (Int -> a -> m) -> NESeq a -> m 337 | #if MIN_VERSION_base(4,11,0) 338 | foldMapWithIndex f (x :<|| xs) = maybe (f 0 x) (f 0 x <>) 339 | . Seq.foldMapWithIndex (\i -> Just . f (i + 1)) 340 | $ xs 341 | #else 342 | foldMapWithIndex f (x :<|| xs) = option (f 0 x) (f 0 x <>) 343 | . Seq.foldMapWithIndex (\i -> Option . Just . f (i + 1)) 344 | $ xs 345 | #endif 346 | {-# INLINE foldMapWithIndex #-} 347 | 348 | -- | /O(n)/. 'traverseWithIndex1' is a version of 'traverse1' that also 349 | -- offers access to the index of each element. 350 | traverseWithIndex1 :: Apply f => (Int -> a -> f b) -> NESeq a -> f (NESeq b) 351 | traverseWithIndex1 f (x :<|| xs) = case runMaybeApply xs' of 352 | Left ys -> (:<||) <$> f 0 x <.> ys 353 | Right ys -> (:<|| ys) <$> f 0 x 354 | where 355 | xs' = Seq.traverseWithIndex (\i -> MaybeApply . Left . f (i + 1)) xs 356 | {-# INLINEABLE traverseWithIndex1 #-} 357 | 358 | -- | \( O(n) \). Returns a sequence of all non-empty suffixes of this 359 | -- sequence, longest first. For example, 360 | -- 361 | -- > tails (fromList (1:|[2,3])) = fromList (fromList (1:|[2,3]) :| [fromList (2:|[3]), fromList (3:|[])]) 362 | -- 363 | -- Evaluating the \( i \)th suffix takes \( O(\log(\min(i, n-i))) \), but evaluating 364 | -- every suffix in the sequence takes \( O(n) \) due to sharing. 365 | 366 | -- TODO: is this true? 367 | tails :: NESeq a -> NESeq (NESeq a) 368 | tails xs@(_ :<|| ys) = withNonEmpty (singleton xs) ((xs <|) . tails) ys 369 | {-# INLINEABLE tails #-} 370 | 371 | -- | \( O(\min(n_1,n_2)) \). 'zip' takes two sequences and returns 372 | -- a sequence of corresponding pairs. If one input is short, excess 373 | -- elements are discarded from the right end of the longer sequence. 374 | zip :: NESeq a -> NESeq b -> NESeq (a, b) 375 | zip (x :<|| xs) (y :<|| ys) = (x, y) :<|| Seq.zip xs ys 376 | {-# INLINE zip #-} 377 | 378 | -- | \( O(\min(n_1,n_2)) \). 'zipWith' generalizes 'zip' by zipping with the 379 | -- function given as the first argument, instead of a tupling function. 380 | -- For example, @zipWith (+)@ is applied to two sequences to take the 381 | -- sequence of corresponding sums. 382 | zipWith :: (a -> b -> c) -> NESeq a -> NESeq b -> NESeq c 383 | zipWith f (x :<|| xs) (y :<|| ys) = f x y :<|| Seq.zipWith f xs ys 384 | {-# INLINE zipWith #-} 385 | 386 | -- | Unzip a sequence of pairs. 387 | -- 388 | -- @ 389 | -- unzip ps = ps ``seq`` ('fmap' 'fst' ps) ('fmap' 'snd' ps) 390 | -- @ 391 | -- 392 | -- Example: 393 | -- 394 | -- @ 395 | -- unzip $ fromList ((1,"a") :| [(2,"b"), (3,"c")]) = 396 | -- (fromList (1:|[2,3]), fromList ("a":|["b","c"])) 397 | -- @ 398 | -- 399 | -- See the note about efficiency at 'Data.Sequence.NonEmpty.unzipWith'. 400 | unzip :: NESeq (a, b) -> (NESeq a, NESeq b) 401 | unzip ((x, y) :<|| xys) = bimap (x :<||) (y :<||) . Seq.unzip $ xys 402 | {-# INLINE unzip #-} 403 | 404 | instance Semigroup (NESeq a) where 405 | (<>) = (><) 406 | {-# INLINE (<>) #-} 407 | 408 | instance Functor NESeq where 409 | fmap = map 410 | {-# INLINE fmap #-} 411 | x <$ xs = replicate (length xs) x 412 | {-# INLINE (<$) #-} 413 | 414 | -- | @since 0.3.4.4 415 | instance Invariant NESeq where 416 | invmap f _ = fmap f 417 | {-# INLINE invmap #-} 418 | 419 | instance Apply NESeq where 420 | (f :<|| fs) <.> xs = fxs |>< fsxs 421 | where 422 | fxs = f <$> xs 423 | fsxs = fs <.> toSeq xs 424 | {-# INLINEABLE (<.>) #-} 425 | 426 | instance Applicative NESeq where 427 | pure = singleton 428 | {-# INLINE pure #-} 429 | (<*>) = (<.>) 430 | {-# INLINEABLE (<*>) #-} 431 | 432 | instance Alt NESeq where 433 | () = (><) 434 | {-# INLINE () #-} 435 | 436 | instance Bind NESeq where 437 | NESeq x xs >>- f = withNonEmpty (f x) ((f x ><) . (>>- f)) xs 438 | {-# INLINEABLE (>>-) #-} 439 | 440 | instance Monad NESeq where 441 | return = pure 442 | {-# INLINE return #-} 443 | (>>=) = (>>-) 444 | {-# INLINEABLE (>>=) #-} 445 | 446 | instance Extend NESeq where 447 | duplicated = tails 448 | {-# INLINE duplicated #-} 449 | extended f xs0@(_ :<|| xs) = 450 | withNonEmpty 451 | (singleton (f xs0)) 452 | ((f xs0 <|) . extend f) 453 | xs 454 | {-# INLINE extended #-} 455 | 456 | instance Comonad NESeq where 457 | extract (x :<|| _) = x 458 | {-# INLINE extract #-} 459 | duplicate = duplicated 460 | {-# INLINE duplicate #-} 461 | extend = extended 462 | {-# INLINE extend #-} 463 | 464 | -- | 'foldr1', 'foldl1', 'maximum', and 'minimum' are all total, unlike for 465 | -- 'Seq'. 466 | #if MIN_VERSION_base(4,11,0) 467 | instance Foldable NESeq where 468 | fold (x :<|| xs) = x <> F.fold xs 469 | {-# INLINE fold #-} 470 | foldMap f (x :<|| xs) = f x <> F.foldMap f xs 471 | {-# INLINE foldMap #-} 472 | foldr f z (x :<|| xs) = x `f` foldr f z xs 473 | {-# INLINE foldr #-} 474 | foldr' f z (xs :||> x) = F.foldr' f y xs 475 | where 476 | !y = f x z 477 | {-# INLINE foldr' #-} 478 | foldl f z (xs :||> x) = foldl f z xs `f` x 479 | {-# INLINE foldl #-} 480 | foldl' f z (x :<|| xs) = F.foldl' f y xs 481 | where 482 | !y = f z x 483 | {-# INLINE foldl' #-} 484 | foldr1 f (xs :||> x) = foldr f x xs 485 | {-# INLINE foldr1 #-} 486 | foldl1 f (x :<|| xs) = foldl f x xs 487 | {-# INLINE foldl1 #-} 488 | null _ = False 489 | {-# INLINE null #-} 490 | length = length 491 | {-# INLINE length #-} 492 | #else 493 | instance Foldable NESeq where 494 | fold (x :<|| xs) = x `mappend` F.fold xs 495 | {-# INLINE fold #-} 496 | foldMap f (x :<|| xs) = f x `mappend` F.foldMap f xs 497 | {-# INLINE foldMap #-} 498 | foldr f z (x :<|| xs) = x `f` foldr f z xs 499 | {-# INLINE foldr #-} 500 | foldr' f z (xs :||> x) = F.foldr' f y xs 501 | where 502 | !y = f x z 503 | {-# INLINE foldr' #-} 504 | foldl f z (xs :||> x) = foldl f z xs `f` x 505 | {-# INLINE foldl #-} 506 | foldl' f z (x :<|| xs) = F.foldl' f y xs 507 | where 508 | !y = f z x 509 | {-# INLINE foldl' #-} 510 | foldr1 f (xs :||> x) = foldr f x xs 511 | {-# INLINE foldr1 #-} 512 | foldl1 f (x :<|| xs) = foldl f x xs 513 | {-# INLINE foldl1 #-} 514 | null _ = False 515 | {-# INLINE null #-} 516 | length = length 517 | {-# INLINE length #-} 518 | #endif 519 | 520 | #if MIN_VERSION_base(4,11,0) 521 | instance Foldable1 NESeq where 522 | fold1 (x :<|| xs) = maybe x (x <>) 523 | . F.foldMap Just 524 | $ xs 525 | {-# INLINE fold1 #-} 526 | foldMap1 f = foldMapWithIndex (const f) 527 | {-# INLINE foldMap1 #-} 528 | -- TODO: use build 529 | toNonEmpty (x :<|| xs) = x :| F.toList xs 530 | {-# INLINE toNonEmpty #-} 531 | #else 532 | instance Foldable1 NESeq where 533 | fold1 (x :<|| xs) = option x (x <>) 534 | . F.foldMap (Option . Just) 535 | $ xs 536 | {-# INLINE fold1 #-} 537 | foldMap1 f = foldMapWithIndex (const f) 538 | {-# INLINE foldMap1 #-} 539 | -- TODO: use build 540 | toNonEmpty (x :<|| xs) = x :| F.toList xs 541 | {-# INLINE toNonEmpty #-} 542 | #endif 543 | 544 | instance Traversable1 NESeq where 545 | traverse1 f = traverseWithIndex1 (const f) 546 | {-# INLINE traverse1 #-} 547 | sequence1 (x :<|| xs) = case runMaybeApply xs' of 548 | Left ys -> (:<||) <$> x <.> ys 549 | Right ys -> (:<|| ys) <$> x 550 | where 551 | xs' = traverse (MaybeApply . Left) xs 552 | {-# INLINEABLE sequence1 #-} 553 | 554 | -- | @mzipWith = zipWith@ 555 | -- 556 | -- @munzip = unzip@ 557 | instance MonadZip NESeq where 558 | mzipWith = zipWith 559 | munzip = unzip 560 | 561 | instance MonadFix NESeq where 562 | mfix = mfixSeq 563 | 564 | mfixSeq :: (a -> NESeq a) -> NESeq a 565 | mfixSeq f = fromFunction (length (f err)) (\k -> fix (\xk -> f xk `index` k)) 566 | where 567 | err = error "mfix for Data.Sequence.NonEmpty.NESeq applied to strict function" 568 | 569 | instance NFData a => NFData (NESeq a) where 570 | rnf (x :<|| xs) = rnf x `seq` rnf xs 571 | -------------------------------------------------------------------------------- /src/Data/Set/NonEmpty/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | {-# OPTIONS_HADDOCK not-home #-} 7 | 8 | -- | 9 | -- Module : Data.Set.NonEmpty.Internal 10 | -- Copyright : (c) Justin Le 2018 11 | -- License : BSD3 12 | -- 13 | -- Maintainer : justin@jle.im 14 | -- Stability : experimental 15 | -- Portability : non-portable 16 | -- 17 | -- Unsafe internal-use functions used in the implementation of 18 | -- "Data.Set.NonEmpty". These functions can potentially be used to break 19 | -- the abstraction of 'NESet' and produce unsound sets, so be wary! 20 | module Data.Set.NonEmpty.Internal ( 21 | NESet (..), 22 | nonEmptySet, 23 | withNonEmpty, 24 | toSet, 25 | singleton, 26 | fromList, 27 | toList, 28 | size, 29 | union, 30 | unions, 31 | foldr, 32 | foldl, 33 | foldr', 34 | foldl', 35 | MergeNESet (..), 36 | merge, 37 | valid, 38 | insertMinSet, 39 | insertMaxSet, 40 | ) where 41 | 42 | import Control.DeepSeq 43 | import Control.Monad 44 | import qualified Data.Aeson as A 45 | import Data.Data 46 | import qualified Data.Foldable as F 47 | import Data.Function 48 | import Data.Functor.Classes 49 | import Data.List.NonEmpty (NonEmpty (..)) 50 | import Data.Semigroup 51 | import Data.Semigroup.Foldable (Foldable1) 52 | import qualified Data.Semigroup.Foldable as F1 53 | import qualified Data.Set as S 54 | import Data.Set.Internal (Set (..)) 55 | import qualified Data.Set.Internal as S 56 | import Text.Read 57 | import Prelude hiding (Foldable (..)) 58 | 59 | -- | A non-empty (by construction) set of values @a@. At least one value 60 | -- exists in an @'NESet' a@ at all times. 61 | -- 62 | -- Functions that /take/ an 'NESet' can safely operate on it with the 63 | -- assumption that it has at least one item. 64 | -- 65 | -- Functions that /return/ an 'NESet' provide an assurance that the result 66 | -- has at least one item. 67 | -- 68 | -- "Data.Set.NonEmpty" re-exports the API of "Data.Set", faithfully 69 | -- reproducing asymptotics, typeclass constraints, and semantics. 70 | -- Functions that ensure that input and output sets are both non-empty 71 | -- (like 'Data.Set.NonEmpty.insert') return 'NESet', but functions that 72 | -- might potentially return an empty map (like 'Data.Set.NonEmpty.delete') 73 | -- return a 'Set' instead. 74 | -- 75 | -- You can directly construct an 'NESet' with the API from 76 | -- "Data.Set.NonEmpty"; it's more or less the same as constructing a normal 77 | -- 'Set', except you don't have access to 'Data.Set.empty'. There are also 78 | -- a few ways to construct an 'NESet' from a 'Set': 79 | -- 80 | -- 1. The 'nonEmptySet' smart constructor will convert a @'Set' a@ into 81 | -- a @'Maybe' ('NESet' a)@, returning 'Nothing' if the original 'Set' 82 | -- was empty. 83 | -- 2. You can use the 'Data.Set.NonEmpty.insertSet' family of functions to 84 | -- insert a value into a 'Set' to create a guaranteed 'NESet'. 85 | -- 3. You can use the 'Data.Set.NonEmpty.IsNonEmpty' and 86 | -- 'Data.Set.NonEmpty.IsEmpty' patterns to "pattern match" on a 'Set' 87 | -- to reveal it as either containing a 'NESet' or an empty map. 88 | -- 4. 'withNonEmpty' offers a continuation-based interface for 89 | -- deconstructing a 'Set' and treating it as if it were an 'NESet'. 90 | -- 91 | -- You can convert an 'NESet' into a 'Set' with 'toSet' or 92 | -- 'Data.Set.NonEmpty.IsNonEmpty', essentially "obscuring" the non-empty 93 | -- property from the type. 94 | data NESet a 95 | = NESet 96 | { nesV0 :: !a 97 | -- ^ invariant: must be smaller than smallest value in set 98 | , nesSet :: !(Set a) 99 | } 100 | deriving (Typeable) 101 | 102 | instance Eq a => Eq (NESet a) where 103 | t1 == t2 = 104 | S.size (nesSet t1) == S.size (nesSet t2) 105 | && toList t1 == toList t2 106 | 107 | instance Ord a => Ord (NESet a) where 108 | compare = compare `on` toList 109 | (<) = (<) `on` toList 110 | (>) = (>) `on` toList 111 | (<=) = (<=) `on` toList 112 | (>=) = (>=) `on` toList 113 | 114 | instance Show a => Show (NESet a) where 115 | showsPrec p xs = 116 | showParen (p > 10) $ 117 | showString "fromList (" . shows (toList xs) . showString ")" 118 | 119 | instance (Read a, Ord a) => Read (NESet a) where 120 | readPrec = parens $ prec 10 $ do 121 | Ident "fromList" <- lexP 122 | xs <- parens . prec 10 $ readPrec 123 | return (fromList xs) 124 | 125 | readListPrec = readListPrecDefault 126 | 127 | instance Eq1 NESet where 128 | liftEq eq m n = 129 | size m == size n && liftEq eq (toList m) (toList n) 130 | 131 | instance Ord1 NESet where 132 | liftCompare cmp m n = 133 | liftCompare cmp (toList m) (toList n) 134 | 135 | instance Show1 NESet where 136 | liftShowsPrec sp sl d m = 137 | showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) 138 | 139 | instance NFData a => NFData (NESet a) where 140 | rnf (NESet x s) = rnf x `seq` rnf s 141 | 142 | -- Data instance code from Data.Set.Internal 143 | -- 144 | -- Copyright : (c) Daan Leijen 2002 145 | #if MIN_VERSION_base(4,16,0) 146 | instance (Data a, Ord a) => Data (NESet a) where 147 | gfoldl f z set = z fromList `f` toList set 148 | toConstr _ = fromListConstr 149 | gunfold k z c = case constrIndex c of 150 | 1 -> k (z fromList) 151 | _ -> error "gunfold" 152 | dataTypeOf _ = setDataType 153 | dataCast1 = gcast1 154 | #else 155 | #ifndef __HLINT__ 156 | instance (Data a, Ord a) => Data (NESet a) where 157 | gfoldl f z set = z fromList `f` toList set 158 | toConstr _ = fromListConstr 159 | gunfold k z c = case constrIndex c of 160 | 1 -> k (z fromList) 161 | _ -> error "gunfold" 162 | dataTypeOf _ = setDataType 163 | dataCast1 f = gcast1 f 164 | #endif 165 | #endif 166 | 167 | fromListConstr :: Constr 168 | fromListConstr = mkConstr setDataType "fromList" [] Prefix 169 | 170 | setDataType :: DataType 171 | setDataType = mkDataType "Data.Set.NonEmpty.Internal.NESet" [fromListConstr] 172 | 173 | instance A.ToJSON a => A.ToJSON (NESet a) where 174 | toJSON = A.toJSON . toSet 175 | toEncoding = A.toEncoding . toSet 176 | 177 | instance (A.FromJSON a, Ord a) => A.FromJSON (NESet a) where 178 | parseJSON = 179 | withNonEmpty (fail err) pure 180 | <=< A.parseJSON 181 | where 182 | err = "NESet: Non-empty set expected, but empty set found" 183 | 184 | -- | /O(log n)/. Smart constructor for an 'NESet' from a 'Set'. Returns 185 | -- 'Nothing' if the 'Set' was originally actually empty, and @'Just' n@ 186 | -- with an 'NESet', if the 'Set' was not empty. 187 | -- 188 | -- 'nonEmptySet' and @'maybe' 'Data.Set.empty' 'toSet'@ form an 189 | -- isomorphism: they are perfect structure-preserving inverses of 190 | -- eachother. 191 | -- 192 | -- See 'Data.Set.NonEmpty.IsNonEmpty' for a pattern synonym that lets you 193 | -- "match on" the possiblity of a 'Set' being an 'NESet'. 194 | -- 195 | -- > nonEmptySet (Data.Set.fromList [3,5]) == Just (fromList (3:|[5])) 196 | nonEmptySet :: Set a -> Maybe (NESet a) 197 | nonEmptySet = (fmap . uncurry) NESet . S.minView 198 | {-# INLINE nonEmptySet #-} 199 | 200 | -- | /O(log n)/. A general continuation-based way to consume a 'Set' as if 201 | -- it were an 'NESet'. @'withNonEmpty' def f@ will take a 'Set'. If set is 202 | -- empty, it will evaluate to @def@. Otherwise, a non-empty set 'NESet' 203 | -- will be fed to the function @f@ instead. 204 | -- 205 | -- @'nonEmptySet' == 'withNonEmpty' 'Nothing' 'Just'@ 206 | withNonEmpty :: 207 | -- | value to return if set is empty 208 | r -> 209 | -- | function to apply if set is not empty 210 | (NESet a -> r) -> 211 | Set a -> 212 | r 213 | withNonEmpty def f = maybe def f . nonEmptySet 214 | {-# INLINE withNonEmpty #-} 215 | 216 | -- | /O(log n)/. 217 | -- Convert a non-empty set back into a normal possibly-empty map, for usage 218 | -- with functions that expect 'Set'. 219 | -- 220 | -- Can be thought of as "obscuring" the non-emptiness of the set in its 221 | -- type. See the 'Data.Set.NonEmpty.IsNotEmpty' pattern. 222 | -- 223 | -- 'nonEmptySet' and @'maybe' 'Data.Set.empty' 'toSet'@ form an 224 | -- isomorphism: they are perfect structure-preserving inverses of 225 | -- eachother. 226 | -- 227 | -- > toSet (fromList ((3,"a") :| [(5,"b")])) == Data.Set.fromList [(3,"a"), (5,"b")] 228 | toSet :: NESet a -> Set a 229 | toSet (NESet x s) = insertMinSet x s 230 | {-# INLINE toSet #-} 231 | 232 | -- | /O(1)/. Create a singleton set. 233 | singleton :: a -> NESet a 234 | singleton x = NESet x S.empty 235 | {-# INLINE singleton #-} 236 | 237 | -- | /O(n*log n)/. Create a set from a list of elements. 238 | 239 | -- TODO: write manually and optimize to be equivalent to 240 | -- 'fromDistinctAscList' if items are ordered, just like the actual 241 | -- 'S.fromList'. 242 | fromList :: Ord a => NonEmpty a -> NESet a 243 | fromList (x :| s) = 244 | withNonEmpty (singleton x) (<> singleton x) 245 | . S.fromList 246 | $ s 247 | {-# INLINE fromList #-} 248 | 249 | -- | /O(n)/. Convert the set to a non-empty list of elements. 250 | toList :: NESet a -> NonEmpty a 251 | toList (NESet x s) = x :| S.toList s 252 | {-# INLINE toList #-} 253 | 254 | -- | /O(1)/. The number of elements in the set. Guaranteed to be greater 255 | -- than zero. 256 | size :: NESet a -> Int 257 | size (NESet _ s) = 1 + S.size s 258 | {-# INLINE size #-} 259 | 260 | -- | /O(n)/. Fold the elements in the set using the given right-associative 261 | -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'Data.Set.NonEmpty.toAscList'@. 262 | -- 263 | -- For example, 264 | -- 265 | -- > elemsList set = foldr (:) [] set 266 | foldr :: (a -> b -> b) -> b -> NESet a -> b 267 | foldr f z (NESet x s) = x `f` S.foldr f z s 268 | {-# INLINE foldr #-} 269 | 270 | -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is 271 | -- evaluated before using the result in the next application. This 272 | -- function is strict in the starting value. 273 | foldr' :: (a -> b -> b) -> b -> NESet a -> b 274 | foldr' f z (NESet x s) = x `f` y 275 | where 276 | !y = S.foldr' f z s 277 | {-# INLINE foldr' #-} 278 | 279 | -- | /O(n)/. A version of 'foldr' that uses the value at the maximal value 280 | -- in the set as the starting value. 281 | -- 282 | -- Note that, unlike 'Data.Foldable.foldr1' for 'Set', this function is 283 | -- total if the input function is total. 284 | foldr1 :: (a -> a -> a) -> NESet a -> a 285 | foldr1 f (NESet x s) = 286 | maybe x (f x . uncurry (S.foldr f)) 287 | . S.maxView 288 | $ s 289 | {-# INLINE foldr1 #-} 290 | 291 | -- | /O(n)/. Fold the elements in the set using the given left-associative 292 | -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'Data.Set.NonEmpty.toAscList'@. 293 | -- 294 | -- For example, 295 | -- 296 | -- > descElemsList set = foldl (flip (:)) [] set 297 | foldl :: (a -> b -> a) -> a -> NESet b -> a 298 | foldl f z (NESet x s) = S.foldl f (f z x) s 299 | {-# INLINE foldl #-} 300 | 301 | -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is 302 | -- evaluated before using the result in the next application. This 303 | -- function is strict in the starting value. 304 | foldl' :: (a -> b -> a) -> a -> NESet b -> a 305 | foldl' f z (NESet x s) = S.foldl' f y s 306 | where 307 | !y = f z x 308 | {-# INLINE foldl' #-} 309 | 310 | -- | /O(n)/. A version of 'foldl' that uses the value at the minimal value 311 | -- in the set as the starting value. 312 | -- 313 | -- Note that, unlike 'Data.Foldable.foldl1' for 'Set', this function is 314 | -- total if the input function is total. 315 | foldl1 :: (a -> a -> a) -> NESet a -> a 316 | foldl1 f (NESet x s) = S.foldl f x s 317 | {-# INLINE foldl1 #-} 318 | 319 | -- | /O(m*log(n\/m + 1)), m <= n/. The union of two sets, preferring the first set when 320 | -- equal elements are encountered. 321 | union :: 322 | Ord a => 323 | NESet a -> 324 | NESet a -> 325 | NESet a 326 | union n1@(NESet x1 s1) n2@(NESet x2 s2) = case compare x1 x2 of 327 | LT -> NESet x1 . S.union s1 . toSet $ n2 328 | EQ -> NESet x1 . S.union s1 $ s2 329 | GT -> NESet x2 . S.union (toSet n1) $ s2 330 | {-# INLINE union #-} 331 | 332 | -- | The union of a non-empty list of sets 333 | unions :: 334 | (Foldable1 f, Ord a) => 335 | f (NESet a) -> 336 | NESet a 337 | unions (F1.toNonEmpty -> (s :| ss)) = F.foldl' union s ss 338 | {-# INLINE unions #-} 339 | 340 | -- | Left-biased union 341 | instance Ord a => Semigroup (NESet a) where 342 | (<>) = union 343 | {-# INLINE (<>) #-} 344 | sconcat = unions 345 | {-# INLINE sconcat #-} 346 | 347 | -- | Traverses elements in ascending order 348 | -- 349 | -- 'Data.Foldable.foldr1', 'Data.Foldable.foldl1', 'Data.Foldable.minimum', 350 | -- 'Data.Foldable.maximum' are all total. 351 | #if MIN_VERSION_base(4,11,0) 352 | instance F.Foldable NESet where 353 | fold (NESet x s) = x <> F.fold s 354 | {-# INLINE fold #-} 355 | foldMap f (NESet x s) = f x <> F.foldMap f s 356 | {-# INLINE foldMap #-} 357 | foldr = foldr 358 | {-# INLINE foldr #-} 359 | foldr' = foldr' 360 | {-# INLINE foldr' #-} 361 | foldr1 = foldr1 362 | {-# INLINE foldr1 #-} 363 | foldl = foldl 364 | {-# INLINE foldl #-} 365 | foldl' = foldl' 366 | {-# INLINE foldl' #-} 367 | foldl1 = foldl1 368 | {-# INLINE foldl1 #-} 369 | null _ = False 370 | {-# INLINE null #-} 371 | length = size 372 | {-# INLINE length #-} 373 | elem x (NESet x0 s) = 374 | F.elem x s 375 | || x == x0 376 | {-# INLINE elem #-} 377 | minimum (NESet x _) = x 378 | {-# INLINE minimum #-} 379 | maximum (NESet x s) = maybe x fst . S.maxView $ s 380 | {-# INLINE maximum #-} 381 | 382 | -- TODO: use build 383 | toList = F.toList . toList 384 | {-# INLINE toList #-} 385 | #else 386 | instance F.Foldable NESet where 387 | fold (NESet x s) = x `mappend` F.fold s 388 | {-# INLINE fold #-} 389 | foldMap f (NESet x s) = f x `mappend` F.foldMap f s 390 | {-# INLINE foldMap #-} 391 | foldr = foldr 392 | {-# INLINE foldr #-} 393 | foldr' = foldr' 394 | {-# INLINE foldr' #-} 395 | foldr1 = foldr1 396 | {-# INLINE foldr1 #-} 397 | foldl = foldl 398 | {-# INLINE foldl #-} 399 | foldl' = foldl' 400 | {-# INLINE foldl' #-} 401 | foldl1 = foldl1 402 | {-# INLINE foldl1 #-} 403 | null _ = False 404 | {-# INLINE null #-} 405 | length = size 406 | {-# INLINE length #-} 407 | elem x (NESet x0 s) = 408 | F.elem x s 409 | || x == x0 410 | {-# INLINE elem #-} 411 | minimum (NESet x _) = x 412 | {-# INLINE minimum #-} 413 | maximum (NESet x s) = maybe x fst . S.maxView $ s 414 | {-# INLINE maximum #-} 415 | 416 | -- TODO: use build 417 | toList = F.toList . toList 418 | {-# INLINE toList #-} 419 | #endif 420 | 421 | -- | Traverses elements in ascending order 422 | #if MIN_VERSION_base(4,11,0) 423 | instance Foldable1 NESet where 424 | fold1 (NESet x s) = maybe x (x <>) 425 | . F.foldMap Just 426 | $ s 427 | {-# INLINE fold1 #-} 428 | -- TODO: benchmark against maxView-based method 429 | foldMap1 f (NESet x s) = maybe (f x) (f x <>) 430 | . F.foldMap (Just . f) 431 | $ s 432 | {-# INLINE foldMap1 #-} 433 | toNonEmpty = toList 434 | {-# INLINE toNonEmpty #-} 435 | #else 436 | instance Foldable1 NESet where 437 | fold1 (NESet x s) = option x (x <>) 438 | . F.foldMap (Option . Just) 439 | $ s 440 | {-# INLINE fold1 #-} 441 | -- TODO: benchmark against maxView-based method 442 | foldMap1 f (NESet x s) = option (f x) (f x <>) 443 | . F.foldMap (Option . Just . f) 444 | $ s 445 | {-# INLINE foldMap1 #-} 446 | toNonEmpty = toList 447 | {-# INLINE toNonEmpty #-} 448 | #endif 449 | 450 | -- | Used for 'Data.Set.NonEmpty.cartesianProduct' 451 | newtype MergeNESet a = MergeNESet {getMergeNESet :: NESet a} 452 | 453 | instance Semigroup (MergeNESet a) where 454 | MergeNESet n1 <> MergeNESet n2 = MergeNESet (merge n1 n2) 455 | {-# INLINE (<>) #-} 456 | 457 | -- | Unsafely merge two disjoint sets. Only legal if all items in the 458 | -- first set are less than all items in the second set 459 | merge :: NESet a -> NESet a -> NESet a 460 | merge (NESet x1 s1) n2 = NESet x1 $ s1 `S.merge` toSet n2 461 | 462 | -- | /O(n)/. Test if the internal set structure is valid. 463 | valid :: Ord a => NESet a -> Bool 464 | valid (NESet x s) = 465 | S.valid s 466 | && all ((x <) . fst) (S.minView s) 467 | 468 | -- | /O(log n)/. Insert new value into a set where values are 469 | -- /strictly greater than/ the new values That is, the new value must be 470 | -- /strictly less than/ all values present in the 'Set'. /The precondition 471 | -- is not checked./ 472 | -- 473 | -- While this has the same asymptotics as @Data.Set.insert@, it saves 474 | -- a constant factor for value comparison (so may be helpful if comparison 475 | -- is expensive) and also does not require an 'Ord' instance for the value 476 | -- type. 477 | insertMinSet :: a -> Set a -> Set a 478 | insertMinSet x = \case 479 | Tip -> S.singleton x 480 | Bin _ y l r -> balanceL y (insertMinSet x l) r 481 | {-# INLINEABLE insertMinSet #-} 482 | 483 | -- | /O(log n)/. Insert new value into a set where values are /strictly 484 | -- less than/ the new value. That is, the new value must be /strictly 485 | -- greater than/ all values present in the 'Set'. /The precondition is not 486 | -- checked./ 487 | -- 488 | -- While this has the same asymptotics as @Data.Set.insert@, it saves 489 | -- a constant factor for value comparison (so may be helpful if comparison 490 | -- is expensive) and also does not require an 'Ord' instance for the value 491 | -- type. 492 | insertMaxSet :: a -> Set a -> Set a 493 | insertMaxSet x = \case 494 | Tip -> S.singleton x 495 | Bin _ y l r -> balanceR y l (insertMaxSet x r) 496 | {-# INLINEABLE insertMaxSet #-} 497 | 498 | -- ------------------------------------------ 499 | 500 | -- | Unexported code from "Data.Set.Internal" 501 | -- ------------------------------------------ 502 | balanceR :: a -> Set a -> Set a -> Set a 503 | balanceR x l r = case l of 504 | Tip -> case r of 505 | Tip -> Bin 1 x Tip Tip 506 | Bin _ _ Tip Tip -> Bin 2 x Tip r 507 | Bin _ rx Tip rr@Bin{} -> Bin 3 rx (Bin 1 x Tip Tip) rr 508 | Bin _ rx (Bin _ rlx _ _) Tip -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip) 509 | Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _) 510 | | rls < ratio * rrs -> Bin (1 + rs) rx (Bin (1 + rls) x Tip rl) rr 511 | | otherwise -> 512 | Bin (1 + rs) rlx (Bin (1 + S.size rll) x Tip rll) (Bin (1 + rrs + S.size rlr) rx rlr rr) 513 | Bin ls _ _ _ -> case r of 514 | Tip -> Bin (1 + ls) x l Tip 515 | Bin rs rx rl rr 516 | | rs > delta * ls -> case (rl, rr) of 517 | (Bin rls rlx rll rlr, Bin rrs _ _ _) 518 | | rls < ratio * rrs -> Bin (1 + ls + rs) rx (Bin (1 + ls + rls) x l rl) rr 519 | | otherwise -> 520 | Bin (1 + ls + rs) rlx (Bin (1 + ls + S.size rll) x l rll) (Bin (1 + rrs + S.size rlr) rx rlr rr) 521 | (_, _) -> error "Failure in Data.Map.balanceR" 522 | | otherwise -> Bin (1 + ls + rs) x l r 523 | {-# NOINLINE balanceR #-} 524 | 525 | balanceL :: a -> Set a -> Set a -> Set a 526 | balanceL x l r = case r of 527 | Tip -> case l of 528 | Tip -> Bin 1 x Tip Tip 529 | Bin _ _ Tip Tip -> Bin 2 x l Tip 530 | Bin _ lx Tip (Bin _ lrx _ _) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip) 531 | Bin _ lx ll@Bin{} Tip -> Bin 3 lx ll (Bin 1 x Tip Tip) 532 | Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr) 533 | | lrs < ratio * lls -> Bin (1 + ls) lx ll (Bin (1 + lrs) x lr Tip) 534 | | otherwise -> 535 | Bin (1 + ls) lrx (Bin (1 + lls + S.size lrl) lx ll lrl) (Bin (1 + S.size lrr) x lrr Tip) 536 | Bin rs _ _ _ -> case l of 537 | Tip -> Bin (1 + rs) x Tip r 538 | Bin ls lx ll lr 539 | | ls > delta * rs -> case (ll, lr) of 540 | (Bin lls _ _ _, Bin lrs lrx lrl lrr) 541 | | lrs < ratio * lls -> Bin (1 + ls + rs) lx ll (Bin (1 + rs + lrs) x lr r) 542 | | otherwise -> 543 | Bin (1 + ls + rs) lrx (Bin (1 + lls + S.size lrl) lx ll lrl) (Bin (1 + rs + S.size lrr) x lrr r) 544 | (_, _) -> error "Failure in Data.Set.NonEmpty.Internal.balanceL" 545 | | otherwise -> Bin (1 + ls + rs) x l r 546 | {-# NOINLINE balanceL #-} 547 | 548 | delta, ratio :: Int 549 | delta = 3 550 | ratio = 2 551 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | -- import Test.Tasty.Hedgehog 2 | -- import Test.Tasty.Ingredients.ConsoleReporter 3 | import Test.Tasty 4 | import Tests.IntMap 5 | import Tests.IntSet 6 | import Tests.Map 7 | import Tests.Sequence 8 | import Tests.Set 9 | 10 | setOpts :: TestTree -> TestTree 11 | setOpts = id 12 | 13 | -- setOpts = localOption (HedgehogTestLimit (Just 500)) 14 | -- . localOption (HedgehogDiscardLimit (Just 500)) 15 | -- . localOption (HideSuccesses True ) 16 | 17 | main :: IO () 18 | main = 19 | defaultMain . setOpts $ 20 | testGroup 21 | "Tests" 22 | [ mapTests 23 | , setTests 24 | , intMapTests 25 | , intSetTests 26 | , sequenceTests 27 | ] 28 | -------------------------------------------------------------------------------- /test/Tests/IntMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Tests.IntMap (intMapTests) where 6 | 7 | import Control.Applicative 8 | import Control.Comonad 9 | import Data.Coerce 10 | import Data.Foldable 11 | import Data.Functor.Alt 12 | import Data.Functor.Identity 13 | import qualified Data.IntMap as M 14 | import qualified Data.IntMap.NonEmpty as NEM 15 | import Data.List.NonEmpty (NonEmpty (..)) 16 | import qualified Data.List.NonEmpty as NE 17 | import Data.Semigroup.Foldable 18 | import Data.Semigroup.Traversable 19 | import Data.Text (Text) 20 | import Hedgehog 21 | import qualified Hedgehog.Gen as Gen 22 | import qualified Hedgehog.Range as Range 23 | import Test.Tasty 24 | import Tests.Util 25 | 26 | intMapTests :: TestTree 27 | intMapTests = groupTree $$discover 28 | 29 | prop_valid :: Property 30 | prop_valid = 31 | property $ 32 | assert . NEM.valid =<< forAll neIntMapGen 33 | 34 | -- | We cannot implement these because there is no 'valid' for IntSet 35 | -- prop_valid_toMap :: Property 36 | -- prop_valid_toMap = property $ 37 | -- assert . M.valid . NEM.toMap =<< forAll neIntMapGen 38 | 39 | -- prop_valid_insertMinIntMap :: Property 40 | -- prop_valid_insertMinIntMap = property $ do 41 | -- n <- forAll $ do 42 | -- m <- intMapGen 43 | -- let k = maybe 0 (subtract 1 . fst) $ M.lookupMin m 44 | -- v <- valGen 45 | -- pure $ NEM.insertMinIntMap k v m 46 | -- assert $ M.valid n 47 | 48 | -- prop_valid_insertMaxIntMap :: Property 49 | -- prop_valid_insertMaxIntMap = property $ do 50 | -- n <- forAll $ do 51 | -- m <- intMapGen 52 | -- let k = maybe 0 ((+ 1) . fst) $ M.lookupMax m 53 | -- v <- valGen 54 | -- pure $ NEM.insertMaxIntMap k v m 55 | -- assert $ M.valid n 56 | 57 | prop_valid_insertMapMin :: Property 58 | prop_valid_insertMapMin = property $ do 59 | n <- forAll $ do 60 | m <- intMapGen 61 | let k = maybe 0 (subtract 1 . fst) $ M.lookupMin m 62 | v <- valGen 63 | pure $ NEM.insertMapMin k v m 64 | assert $ NEM.valid n 65 | 66 | prop_valid_insertMapMax :: Property 67 | prop_valid_insertMapMax = property $ do 68 | n <- forAll $ do 69 | m <- intMapGen 70 | let k = maybe 0 ((+ 1) . fst) $ M.lookupMax m 71 | v <- valGen 72 | pure $ NEM.insertMapMax k v m 73 | assert $ NEM.valid n 74 | 75 | prop_toMapIso1 :: Property 76 | prop_toMapIso1 = property $ do 77 | m0 <- forAll intMapGen 78 | tripping 79 | m0 80 | NEM.nonEmptyMap 81 | (Identity . maybe M.empty NEM.toMap) 82 | 83 | prop_toMapIso2 :: Property 84 | prop_toMapIso2 = property $ do 85 | m0 <- forAll $ Gen.maybe neIntMapGen 86 | tripping 87 | m0 88 | (maybe M.empty NEM.toMap) 89 | (Identity . NEM.nonEmptyMap) 90 | 91 | prop_read_show :: Property 92 | prop_read_show = readShow neIntMapGen 93 | 94 | prop_read1_show1 :: Property 95 | prop_read1_show1 = readShow1 neIntMapGen 96 | 97 | prop_show_show1 :: Property 98 | prop_show_show1 = showShow1 neIntMapGen 99 | 100 | prop_splitRoot :: Property 101 | prop_splitRoot = property $ do 102 | n <- forAll neIntMapGen 103 | let rs = NEM.splitRoot n 104 | allItems = foldMap1 NEM.keys rs 105 | n' = NEM.unions rs 106 | assert $ ascending allItems 107 | mapM_ (assert . (`NEM.isSubmapOf` n)) rs 108 | length allItems === length n' 109 | n === n' 110 | where 111 | ascending (x :| xs) = case NE.nonEmpty xs of 112 | Nothing -> True 113 | Just ys@(y :| _) -> x < y && ascending ys 114 | 115 | prop_extract_duplicate :: Property 116 | prop_extract_duplicate = property $ do 117 | n <- forAll neIntMapGen 118 | tripping 119 | n 120 | duplicate 121 | (Identity . extract) 122 | 123 | prop_fmap_extract_duplicate :: Property 124 | prop_fmap_extract_duplicate = property $ do 125 | n <- forAll neIntMapGen 126 | tripping 127 | n 128 | duplicate 129 | (Identity . fmap extract) 130 | 131 | prop_duplicate_duplicate :: Property 132 | prop_duplicate_duplicate = property $ do 133 | n <- forAll neIntMapGen 134 | let dd1 = duplicate . duplicate $ n 135 | dd2 = fmap duplicate . duplicate $ n 136 | assert $ NEM.valid dd1 137 | assert $ NEM.valid dd2 138 | dd1 === dd2 139 | 140 | prop_insertMapWithKey :: Property 141 | prop_insertMapWithKey = 142 | ttProp 143 | (gf3 valGen :?> GTIntKey :-> GTVal :-> GTIntMap :-> TTNEIntMap) 144 | M.insertWithKey 145 | NEM.insertMapWithKey 146 | 147 | prop_singleton :: Property 148 | prop_singleton = 149 | ttProp 150 | (GTIntKey :-> GTVal :-> TTNEIntMap) 151 | M.singleton 152 | NEM.singleton 153 | 154 | prop_fromSet :: Property 155 | prop_fromSet = 156 | ttProp 157 | (gf1 valGen :?> GTNEIntSet :-> TTNEIntMap) 158 | M.fromSet 159 | NEM.fromSet 160 | 161 | prop_fromAscList :: Property 162 | prop_fromAscList = 163 | ttProp 164 | (GTSorted STAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntMap) 165 | M.fromAscList 166 | NEM.fromAscList 167 | 168 | prop_fromAscListWithKey :: Property 169 | prop_fromAscListWithKey = 170 | ttProp 171 | (gf3 valGen :?> GTSorted STAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntMap) 172 | M.fromAscListWithKey 173 | NEM.fromAscListWithKey 174 | 175 | prop_fromDistinctAscList :: Property 176 | prop_fromDistinctAscList = 177 | ttProp 178 | (GTSorted STDistinctAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntMap) 179 | M.fromDistinctAscList 180 | NEM.fromDistinctAscList 181 | 182 | prop_fromListWithKey :: Property 183 | prop_fromListWithKey = 184 | ttProp 185 | (gf3 valGen :?> GTNEList Nothing (GTIntKey :&: GTVal) :-> TTNEIntMap) 186 | M.fromListWithKey 187 | NEM.fromListWithKey 188 | 189 | prop_insert :: Property 190 | prop_insert = 191 | ttProp 192 | (GTIntKey :-> GTVal :-> GTNEIntMap :-> TTNEIntMap) 193 | M.insert 194 | NEM.insert 195 | 196 | prop_insertWithKey :: Property 197 | prop_insertWithKey = 198 | ttProp 199 | (gf3 valGen :?> GTIntKey :-> GTVal :-> GTNEIntMap :-> TTNEIntMap) 200 | M.insertWithKey 201 | NEM.insertWithKey 202 | 203 | prop_delete :: Property 204 | prop_delete = 205 | ttProp 206 | (GTIntKey :-> GTNEIntMap :-> TTOther) 207 | M.delete 208 | NEM.delete 209 | 210 | prop_adjustWithKey :: Property 211 | prop_adjustWithKey = 212 | ttProp 213 | (gf2 valGen :?> GTIntKey :-> GTNEIntMap :-> TTNEIntMap) 214 | M.adjustWithKey 215 | NEM.adjustWithKey 216 | 217 | prop_updateWithKey :: Property 218 | prop_updateWithKey = 219 | ttProp 220 | (gf2 (Gen.maybe valGen) :?> GTIntKey :-> GTNEIntMap :-> TTOther) 221 | M.updateWithKey 222 | NEM.updateWithKey 223 | 224 | prop_updateLookupWithKey :: Property 225 | prop_updateLookupWithKey = 226 | ttProp 227 | (gf2 (Gen.maybe valGen) :?> GTIntKey :-> GTNEIntMap :-> TTMaybe TTVal :*: TTOther) 228 | M.updateLookupWithKey 229 | NEM.updateLookupWithKey 230 | 231 | prop_alter :: Property 232 | prop_alter = 233 | ttProp 234 | (gf1 (Gen.maybe valGen) :?> GTIntKey :-> GTNEIntMap :-> TTOther) 235 | M.alter 236 | NEM.alter 237 | 238 | prop_alter' :: Property 239 | prop_alter' = 240 | ttProp 241 | (gf1 valGen :?> GTIntKey :-> GTNEIntMap :-> TTNEIntMap) 242 | (M.alter . fmap Just) 243 | NEM.alter' 244 | 245 | prop_alterF :: Property 246 | prop_alterF = 247 | ttProp 248 | ( gf1 (Gen.maybe valGen) 249 | :?> GTIntKey 250 | :-> GTNEIntMap 251 | :-> TTCtx (GTMaybe GTVal :-> TTOther) (TTMaybe TTVal) 252 | ) 253 | (M.alterF . Context) 254 | (NEM.alterF . Context) 255 | 256 | prop_alterF_rules_Const :: Property 257 | prop_alterF_rules_Const = 258 | ttProp 259 | ( gf1 (Const <$> valGen) 260 | :?> GTIntKey 261 | :-> GTNEIntMap 262 | :-> TTOther 263 | ) 264 | (\f k m -> getConst (M.alterF f k m)) 265 | (\f k m -> getConst (NEM.alterF f k m)) 266 | 267 | prop_alterF_rules_Identity :: Property 268 | prop_alterF_rules_Identity = 269 | ttProp 270 | ( gf1 (Identity <$> Gen.maybe valGen) 271 | :?> GTIntKey 272 | :-> GTNEIntMap 273 | :-> TTOther 274 | ) 275 | (\f k m -> runIdentity (M.alterF f k m)) 276 | (\f k m -> runIdentity (NEM.alterF f k m)) 277 | 278 | prop_alterF' :: Property 279 | prop_alterF' = 280 | ttProp 281 | (gf1 valGen :?> GTIntKey :-> GTNEIntMap :-> TTCtx (GTVal :-> TTNEIntMap) (TTMaybe TTVal)) 282 | (M.alterF . Context . fmap Just) 283 | (NEM.alterF' . Context) 284 | 285 | prop_alterF'_rules_Const :: Property 286 | prop_alterF'_rules_Const = 287 | ttProp 288 | ( gf1 (Const <$> valGen) 289 | :?> GTIntKey 290 | :-> GTNEIntMap 291 | :-> TTOther 292 | ) 293 | (\f k m -> let f' = fmap Just . f in getConst (M.alterF f' k m)) 294 | (\f k m -> getConst (NEM.alterF' f k m)) 295 | 296 | -- -- | This fails, but isn't possible to fix without copying-and-pasting more 297 | -- -- in code from containers. 298 | -- prop_alterF'_rules_Identity :: Property 299 | -- prop_alterF'_rules_Identity = ttProp ( gf1 (Identity <$> valGen) 300 | -- :?> GTIntKey 301 | -- :-> GTNEIntMap 302 | -- :-> TTNEIntMap 303 | -- ) 304 | -- (\f k m -> let f' = fmap Just . f in runIdentity (M.alterF f' k m)) 305 | -- (\f k m -> runIdentity (NEM.alterF' f k m)) 306 | 307 | prop_lookup :: Property 308 | prop_lookup = 309 | ttProp 310 | (GTIntKey :-> GTNEIntMap :-> TTMaybe TTVal) 311 | M.lookup 312 | NEM.lookup 313 | 314 | prop_findWithDefault :: Property 315 | prop_findWithDefault = 316 | ttProp 317 | (GTVal :-> GTIntKey :-> GTNEIntMap :-> TTVal) 318 | M.findWithDefault 319 | NEM.findWithDefault 320 | 321 | prop_member :: Property 322 | prop_member = 323 | ttProp 324 | (GTIntKey :-> GTNEIntMap :-> TTOther) 325 | M.member 326 | NEM.member 327 | 328 | prop_notMember :: Property 329 | prop_notMember = 330 | ttProp 331 | (GTIntKey :-> GTNEIntMap :-> TTOther) 332 | M.notMember 333 | NEM.notMember 334 | 335 | prop_lookupLT :: Property 336 | prop_lookupLT = 337 | ttProp 338 | (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) 339 | M.lookupLT 340 | NEM.lookupLT 341 | 342 | prop_lookupGT :: Property 343 | prop_lookupGT = 344 | ttProp 345 | (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) 346 | M.lookupGT 347 | NEM.lookupGT 348 | 349 | prop_lookupLE :: Property 350 | prop_lookupLE = 351 | ttProp 352 | (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) 353 | M.lookupLE 354 | NEM.lookupLE 355 | 356 | prop_lookupGE :: Property 357 | prop_lookupGE = 358 | ttProp 359 | (GTIntKey :-> GTNEIntMap :-> TTMaybe (TTOther :*: TTVal)) 360 | M.lookupGE 361 | NEM.lookupGE 362 | 363 | prop_size :: Property 364 | prop_size = 365 | ttProp 366 | (GTNEIntMap :-> TTOther) 367 | M.size 368 | NEM.size 369 | 370 | prop_union :: Property 371 | prop_union = 372 | ttProp 373 | (GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) 374 | M.union 375 | NEM.union 376 | 377 | prop_unionWith :: Property 378 | prop_unionWith = 379 | ttProp 380 | (gf2 valGen :?> GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) 381 | M.unionWith 382 | NEM.unionWith 383 | 384 | prop_unionWithKey :: Property 385 | prop_unionWithKey = 386 | ttProp 387 | (gf3 valGen :?> GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) 388 | M.unionWithKey 389 | NEM.unionWithKey 390 | 391 | prop_unions :: Property 392 | prop_unions = 393 | ttProp 394 | (GTNEList (Just (Range.linear 2 5)) GTNEIntMap :-> TTNEIntMap) 395 | M.unions 396 | NEM.unions 397 | 398 | prop_unionsWith :: Property 399 | prop_unionsWith = 400 | ttProp 401 | (gf2 valGen :?> GTNEList (Just (Range.linear 2 5)) GTNEIntMap :-> TTNEIntMap) 402 | M.unionsWith 403 | NEM.unionsWith 404 | 405 | prop_difference :: Property 406 | prop_difference = 407 | ttProp 408 | (GTNEIntMap :-> GTNEIntMap :-> TTOther) 409 | M.difference 410 | NEM.difference 411 | 412 | prop_differenceWithKey :: Property 413 | prop_differenceWithKey = 414 | ttProp 415 | (gf3 (Gen.maybe valGen) :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) 416 | M.differenceWithKey 417 | NEM.differenceWithKey 418 | 419 | prop_intersection :: Property 420 | prop_intersection = 421 | ttProp 422 | (GTNEIntMap :-> GTNEIntMap :-> TTOther) 423 | M.intersection 424 | NEM.intersection 425 | 426 | prop_intersectionWithKey :: Property 427 | prop_intersectionWithKey = 428 | ttProp 429 | (gf3 valGen :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) 430 | M.intersectionWithKey 431 | NEM.intersectionWithKey 432 | 433 | prop_map :: Property 434 | prop_map = 435 | ttProp 436 | (gf1 valGen :?> GTNEIntMap :-> TTNEIntMap) 437 | M.map 438 | NEM.map 439 | 440 | prop_map_rules_map :: Property 441 | prop_map_rules_map = 442 | ttProp 443 | (gf1 valGen :?> gf1 valGen :?> GTNEIntMap :-> TTNEIntMap) 444 | (\f g xs -> M.map f (M.map g xs)) 445 | (\f g xs -> NEM.map f (NEM.map g xs)) 446 | 447 | prop_map_rules_coerce :: Property 448 | prop_map_rules_coerce = 449 | ttProp 450 | (GTNEIntMap :-> TTNEIntMap) 451 | (M.map @Text @Text coerce) 452 | (NEM.map @Text @Text coerce) 453 | 454 | prop_map_rules_mapWithKey :: Property 455 | prop_map_rules_mapWithKey = 456 | ttProp 457 | (gf1 valGen :?> gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) 458 | (\f g xs -> M.map f (M.mapWithKey g xs)) 459 | (\f g xs -> NEM.map f (NEM.mapWithKey g xs)) 460 | 461 | prop_mapWithKey :: Property 462 | prop_mapWithKey = 463 | ttProp 464 | (gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) 465 | M.mapWithKey 466 | NEM.mapWithKey 467 | 468 | prop_mapWithKey_rules_mapWithKey :: Property 469 | prop_mapWithKey_rules_mapWithKey = 470 | ttProp 471 | (gf2 valGen :?> gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) 472 | (\f g xs -> M.mapWithKey f (M.mapWithKey g xs)) 473 | (\f g xs -> NEM.mapWithKey f (NEM.mapWithKey g xs)) 474 | 475 | prop_mapWithKey_rules_map :: Property 476 | prop_mapWithKey_rules_map = 477 | ttProp 478 | (gf2 valGen :?> gf1 valGen :?> GTNEIntMap :-> TTNEIntMap) 479 | (\f g xs -> M.mapWithKey f (M.map g xs)) 480 | (\f g xs -> NEM.mapWithKey f (NEM.map g xs)) 481 | 482 | prop_traverseWithKey1 :: Property 483 | prop_traverseWithKey1 = 484 | ttProp 485 | (gf1 valGen :?> GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) 486 | (\f -> M.traverseWithKey (\k -> (`More` Done (f . (k,))))) 487 | (\f -> NEM.traverseWithKey1 (\k -> (`More` Done (f . (k,))))) 488 | 489 | prop_traverseWithKey :: Property 490 | prop_traverseWithKey = 491 | ttProp 492 | (gf1 valGen :?> GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) 493 | (\f -> M.traverseWithKey (\k -> (`More` Done (f . (k,))))) 494 | (\f -> NEM.traverseWithKey (\k -> (`More` Done (f . (k,))))) 495 | 496 | prop_sequence1 :: Property 497 | prop_sequence1 = 498 | ttProp 499 | (GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) 500 | (traverse (`More` Done id)) 501 | (traverse1 (`More` Done id)) 502 | 503 | prop_sequenceA :: Property 504 | prop_sequenceA = 505 | ttProp 506 | (GTNEIntMap :-> TTBazaar GTVal TTNEIntMap TTVal) 507 | (traverse (`More` Done id)) 508 | (traverse (`More` Done id)) 509 | 510 | prop_mapAccumWithKey :: Property 511 | prop_mapAccumWithKey = 512 | ttProp 513 | ( gf3 ((,) <$> valGen <*> valGen) 514 | :?> GTOther valGen 515 | :-> GTNEIntMap 516 | :-> TTOther 517 | :*: TTNEIntMap 518 | ) 519 | M.mapAccumWithKey 520 | NEM.mapAccumWithKey 521 | 522 | prop_mapAccumRWithKey :: Property 523 | prop_mapAccumRWithKey = 524 | ttProp 525 | ( gf3 ((,) <$> valGen <*> valGen) 526 | :?> GTOther valGen 527 | :-> GTNEIntMap 528 | :-> TTOther 529 | :*: TTNEIntMap 530 | ) 531 | M.mapAccumRWithKey 532 | NEM.mapAccumRWithKey 533 | 534 | prop_mapKeys :: Property 535 | prop_mapKeys = 536 | ttProp 537 | (gf1 intKeyGen :?> GTNEIntMap :-> TTNEIntMap) 538 | M.mapKeys 539 | NEM.mapKeys 540 | 541 | prop_mapKeysWith :: Property 542 | prop_mapKeysWith = 543 | ttProp 544 | ( gf2 valGen 545 | :?> gf1 intKeyGen 546 | :?> GTNEIntMap 547 | :-> TTNEIntMap 548 | ) 549 | M.mapKeysWith 550 | NEM.mapKeysWith 551 | 552 | prop_mapKeysMonotonic :: Property 553 | prop_mapKeysMonotonic = 554 | ttProp 555 | (GTNEIntMap :-> TTNEIntMap) 556 | (M.mapKeysMonotonic (* 2)) 557 | (NEM.mapKeysMonotonic (* 2)) 558 | 559 | prop_foldr :: Property 560 | prop_foldr = 561 | ttProp 562 | ( gf2 valGen 563 | :?> GTOther valGen 564 | :-> GTNEIntMap 565 | :-> TTOther 566 | ) 567 | M.foldr 568 | NEM.foldr 569 | 570 | prop_foldl :: Property 571 | prop_foldl = 572 | ttProp 573 | ( gf2 valGen 574 | :?> GTOther valGen 575 | :-> GTNEIntMap 576 | :-> TTOther 577 | ) 578 | M.foldl 579 | NEM.foldl 580 | 581 | prop_foldr1 :: Property 582 | prop_foldr1 = 583 | ttProp 584 | ( gf2 valGen 585 | :?> GTNEIntMap 586 | :-> TTOther 587 | ) 588 | foldr1 589 | NEM.foldr1 590 | 591 | prop_foldl1 :: Property 592 | prop_foldl1 = 593 | ttProp 594 | ( gf2 valGen 595 | :?> GTNEIntMap 596 | :-> TTOther 597 | ) 598 | foldl1 599 | NEM.foldl1 600 | 601 | prop_foldrWithKey :: Property 602 | prop_foldrWithKey = 603 | ttProp 604 | ( gf3 valGen 605 | :?> GTOther valGen 606 | :-> GTNEIntMap 607 | :-> TTOther 608 | ) 609 | M.foldrWithKey 610 | NEM.foldrWithKey 611 | 612 | prop_foldlWithKey :: Property 613 | prop_foldlWithKey = 614 | ttProp 615 | ( gf3 valGen 616 | :?> GTOther valGen 617 | :-> GTNEIntMap 618 | :-> TTOther 619 | ) 620 | M.foldlWithKey 621 | NEM.foldlWithKey 622 | 623 | prop_foldMapWithKey :: Property 624 | prop_foldMapWithKey = 625 | ttProp 626 | (gf2 valGen :?> GTNEIntMap :-> TTOther) 627 | (\f -> foldMap (uncurry f) . M.toList) 628 | NEM.foldMapWithKey 629 | 630 | prop_foldr' :: Property 631 | prop_foldr' = 632 | ttProp 633 | ( gf2 valGen 634 | :?> GTOther valGen 635 | :-> GTNEIntMap 636 | :-> TTOther 637 | ) 638 | M.foldr' 639 | NEM.foldr' 640 | 641 | prop_foldl' :: Property 642 | prop_foldl' = 643 | ttProp 644 | ( gf2 valGen 645 | :?> GTOther valGen 646 | :-> GTNEIntMap 647 | :-> TTOther 648 | ) 649 | M.foldl' 650 | NEM.foldl' 651 | 652 | prop_foldr1' :: Property 653 | prop_foldr1' = 654 | ttProp 655 | ( gf2 valGen 656 | :?> GTNEIntMap 657 | :-> TTOther 658 | ) 659 | foldr1 660 | NEM.foldr1' 661 | 662 | prop_foldl1' :: Property 663 | prop_foldl1' = 664 | ttProp 665 | ( gf2 valGen 666 | :?> GTNEIntMap 667 | :-> TTOther 668 | ) 669 | foldl1 670 | NEM.foldl1' 671 | 672 | prop_foldrWithKey' :: Property 673 | prop_foldrWithKey' = 674 | ttProp 675 | ( gf3 valGen 676 | :?> GTOther valGen 677 | :-> GTNEIntMap 678 | :-> TTOther 679 | ) 680 | M.foldrWithKey' 681 | NEM.foldrWithKey' 682 | 683 | prop_foldlWithKey' :: Property 684 | prop_foldlWithKey' = 685 | ttProp 686 | ( gf3 valGen 687 | :?> GTOther valGen 688 | :-> GTNEIntMap 689 | :-> TTOther 690 | ) 691 | M.foldlWithKey' 692 | NEM.foldlWithKey' 693 | 694 | prop_elems :: Property 695 | prop_elems = 696 | ttProp 697 | (GTNEIntMap :-> TTNEList TTVal) 698 | M.elems 699 | NEM.elems 700 | 701 | prop_keys :: Property 702 | prop_keys = 703 | ttProp 704 | (GTNEIntMap :-> TTNEList TTOther) 705 | M.keys 706 | NEM.keys 707 | 708 | prop_assocs :: Property 709 | prop_assocs = 710 | ttProp 711 | (GTNEIntMap :-> TTNEList (TTOther :*: TTVal)) 712 | M.assocs 713 | NEM.assocs 714 | 715 | prop_keysSet :: Property 716 | prop_keysSet = 717 | ttProp 718 | (GTNEIntMap :-> TTNEIntSet) 719 | M.keysSet 720 | NEM.keysSet 721 | 722 | prop_toList :: Property 723 | prop_toList = 724 | ttProp 725 | (GTNEIntMap :-> TTNEList (TTOther :*: TTVal)) 726 | M.toList 727 | NEM.toList 728 | 729 | prop_toDescList :: Property 730 | prop_toDescList = 731 | ttProp 732 | (GTNEIntMap :-> TTNEList (TTOther :*: TTVal)) 733 | M.toDescList 734 | NEM.toDescList 735 | 736 | prop_filter :: Property 737 | prop_filter = 738 | ttProp 739 | (gf1 Gen.bool :?> GTNEIntMap :-> TTOther) 740 | M.filter 741 | NEM.filter 742 | 743 | prop_filterWithKey :: Property 744 | prop_filterWithKey = 745 | ttProp 746 | (gf2 Gen.bool :?> GTNEIntMap :-> TTOther) 747 | M.filterWithKey 748 | NEM.filterWithKey 749 | 750 | prop_restrictKeys :: Property 751 | prop_restrictKeys = 752 | ttProp 753 | (GTNEIntMap :-> GTIntSet :-> TTOther) 754 | M.restrictKeys 755 | NEM.restrictKeys 756 | 757 | prop_withoutKeys :: Property 758 | prop_withoutKeys = 759 | ttProp 760 | (GTNEIntMap :-> GTIntSet :-> TTOther) 761 | M.withoutKeys 762 | NEM.withoutKeys 763 | 764 | prop_partitionWithKey :: Property 765 | prop_partitionWithKey = 766 | ttProp 767 | (gf2 Gen.bool :?> GTNEIntMap :-> TTThese TTNEIntMap TTNEIntMap) 768 | M.partitionWithKey 769 | NEM.partitionWithKey 770 | 771 | prop_mapMaybeWithKey :: Property 772 | prop_mapMaybeWithKey = 773 | ttProp 774 | (gf2 (Gen.maybe valGen) :?> GTNEIntMap :-> TTOther) 775 | M.mapMaybeWithKey 776 | NEM.mapMaybeWithKey 777 | 778 | prop_mapEitherWithKey :: Property 779 | prop_mapEitherWithKey = 780 | ttProp 781 | ( gf2 (Gen.choice [Left <$> valGen, Right <$> valGen]) 782 | :?> GTNEIntMap 783 | :-> TTThese TTNEIntMap TTNEIntMap 784 | ) 785 | M.mapEitherWithKey 786 | NEM.mapEitherWithKey 787 | 788 | prop_split :: Property 789 | prop_split = 790 | ttProp 791 | (GTIntKey :-> GTNEIntMap :-> TTMThese TTNEIntMap TTNEIntMap) 792 | M.split 793 | NEM.split 794 | 795 | prop_splitLookup :: Property 796 | prop_splitLookup = 797 | ttProp 798 | (GTIntKey :-> GTNEIntMap :-> TTTThese TTVal TTNEIntMap TTNEIntMap) 799 | (\k -> (\(x, y, z) -> (y, x, z)) . M.splitLookup k) 800 | NEM.splitLookup 801 | 802 | prop_isSubmapOfBy :: Property 803 | prop_isSubmapOfBy = 804 | ttProp 805 | (gf2 Gen.bool :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) 806 | M.isSubmapOfBy 807 | NEM.isSubmapOfBy 808 | 809 | prop_isProperSubmapOfBy :: Property 810 | prop_isProperSubmapOfBy = 811 | ttProp 812 | (gf2 Gen.bool :?> GTNEIntMap :-> GTNEIntMap :-> TTOther) 813 | M.isProperSubmapOfBy 814 | NEM.isProperSubmapOfBy 815 | 816 | prop_findMin :: Property 817 | prop_findMin = 818 | ttProp 819 | (GTNEIntMap :-> TTOther :*: TTVal) 820 | M.findMin 821 | NEM.findMin 822 | 823 | prop_findMax :: Property 824 | prop_findMax = 825 | ttProp 826 | (GTNEIntMap :-> TTOther :*: TTVal) 827 | M.findMax 828 | NEM.findMax 829 | 830 | prop_deleteMin :: Property 831 | prop_deleteMin = 832 | ttProp 833 | (GTNEIntMap :-> TTOther) 834 | M.deleteMin 835 | NEM.deleteMin 836 | 837 | prop_deleteMax :: Property 838 | prop_deleteMax = 839 | ttProp 840 | (GTNEIntMap :-> TTOther) 841 | M.deleteMax 842 | NEM.deleteMax 843 | 844 | prop_deleteFindMin :: Property 845 | prop_deleteFindMin = 846 | ttProp 847 | (GTNEIntMap :-> (TTOther :*: TTVal) :*: TTOther) 848 | M.deleteFindMin 849 | NEM.deleteFindMin 850 | 851 | prop_deleteFindMax :: Property 852 | prop_deleteFindMax = 853 | ttProp 854 | (GTNEIntMap :-> (TTOther :*: TTVal) :*: TTOther) 855 | M.deleteFindMax 856 | NEM.deleteFindMax 857 | 858 | prop_updateMinWithKey :: Property 859 | prop_updateMinWithKey = 860 | ttProp 861 | (gf2 (Gen.maybe valGen) :?> GTNEIntMap :-> TTOther) 862 | M.updateMinWithKey 863 | NEM.updateMinWithKey 864 | 865 | prop_updateMaxWithKey :: Property 866 | prop_updateMaxWithKey = 867 | ttProp 868 | (gf2 (Gen.maybe valGen) :?> GTNEIntMap :-> TTOther) 869 | M.updateMaxWithKey 870 | NEM.updateMaxWithKey 871 | 872 | prop_adjustMinWithKey :: Property 873 | prop_adjustMinWithKey = 874 | ttProp 875 | (gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) 876 | (M.updateMinWithKey . (fmap . fmap) Just) 877 | NEM.adjustMinWithKey 878 | 879 | prop_adjustMaxWithKey :: Property 880 | prop_adjustMaxWithKey = 881 | ttProp 882 | (gf2 valGen :?> GTNEIntMap :-> TTNEIntMap) 883 | (M.updateMaxWithKey . (fmap . fmap) Just) 884 | NEM.adjustMaxWithKey 885 | 886 | prop_minView :: Property 887 | prop_minView = 888 | ttProp 889 | (GTNEIntMap :-> TTMaybe (TTVal :*: TTOther)) 890 | M.minView 891 | (Just . NEM.minView) 892 | 893 | prop_maxView :: Property 894 | prop_maxView = 895 | ttProp 896 | (GTNEIntMap :-> TTMaybe (TTVal :*: TTOther)) 897 | M.maxView 898 | (Just . NEM.maxView) 899 | 900 | prop_elem :: Property 901 | prop_elem = 902 | ttProp 903 | (GTVal :-> GTNEIntMap :-> TTOther) 904 | elem 905 | elem 906 | 907 | prop_fold1 :: Property 908 | prop_fold1 = 909 | ttProp 910 | (GTNEIntMap :-> TTVal) 911 | fold 912 | fold1 913 | 914 | prop_fold :: Property 915 | prop_fold = 916 | ttProp 917 | (GTNEIntMap :-> TTVal) 918 | fold 919 | fold 920 | 921 | prop_foldMap1 :: Property 922 | prop_foldMap1 = 923 | ttProp 924 | (gf1 valGen :?> GTNEIntMap :-> TTOther) 925 | (\f -> foldMap ((: []) . f)) 926 | (\f -> foldMap1 ((: []) . f)) 927 | 928 | prop_foldMap :: Property 929 | prop_foldMap = 930 | ttProp 931 | (gf1 valGen :?> GTNEIntMap :-> TTOther) 932 | (\f -> foldMap ((: []) . f)) 933 | (\f -> foldMap ((: []) . f)) 934 | 935 | prop_alt :: Property 936 | prop_alt = 937 | ttProp 938 | (GTNEIntMap :-> GTNEIntMap :-> TTNEIntMap) 939 | () 940 | () 941 | -------------------------------------------------------------------------------- /test/Tests/IntSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Tests.IntSet (intSetTests) where 4 | 5 | import Data.Functor.Identity 6 | import qualified Data.IntSet as S 7 | import qualified Data.IntSet.NonEmpty as NES 8 | import Data.List.NonEmpty (NonEmpty (..)) 9 | import qualified Data.List.NonEmpty as NE 10 | import Data.Semigroup.Foldable 11 | import Hedgehog 12 | import qualified Hedgehog.Gen as Gen 13 | import qualified Hedgehog.Range as Range 14 | import Test.Tasty 15 | import Tests.Util 16 | 17 | intSetTests :: TestTree 18 | intSetTests = groupTree $$discover 19 | 20 | prop_valid :: Property 21 | prop_valid = 22 | property $ 23 | assert . NES.valid =<< forAll neIntSetGen 24 | 25 | -- | We cannot implement these because there is no 'valid' for IntSet 26 | -- prop_valid_toSet :: Property 27 | -- prop_valid_toSet = property $ do 28 | -- assert . S.valid . NES.toSet =<< forAll neIntSetGen 29 | 30 | -- prop_valid_insertMinIntSet :: Property 31 | -- prop_valid_insertMinIntSet = property $ do 32 | -- n <- forAll $ do 33 | -- m <- setGen 34 | -- let k = maybe dummyKey (subtract 1 . fst) $ S.maxView m 35 | -- pure $ NES.insertMinIntSet k m 36 | -- assert $ S.valid n 37 | 38 | -- prop_valid_insertMaxIntSet :: Property 39 | -- prop_valid_insertMaxIntSet = property $ do 40 | -- n <- forAll $ do 41 | -- m <- setGen 42 | -- let k = maybe dummyKey ((+ 1) . fst) $ S.maxView m 43 | -- pure $ NES.insertMaxIntSet k m 44 | -- assert $ S.valid n 45 | 46 | prop_valid_insertSetMin :: Property 47 | prop_valid_insertSetMin = property $ do 48 | n <- forAll $ do 49 | m <- intSetGen 50 | let k = maybe 0 (subtract 1 . fst) $ S.minView m 51 | pure $ NES.insertSetMin k m 52 | assert $ NES.valid n 53 | 54 | prop_valid_insertSetMax :: Property 55 | prop_valid_insertSetMax = property $ do 56 | n <- forAll $ do 57 | m <- intSetGen 58 | let k = maybe 0 ((+ 1) . fst) $ S.maxView m 59 | pure $ NES.insertSetMax k m 60 | assert $ NES.valid n 61 | 62 | prop_toSetIso1 :: Property 63 | prop_toSetIso1 = property $ do 64 | m0 <- forAll intSetGen 65 | tripping 66 | m0 67 | NES.nonEmptySet 68 | (Identity . maybe S.empty NES.toSet) 69 | 70 | prop_toSetIso2 :: Property 71 | prop_toSetIso2 = property $ do 72 | m0 <- forAll $ Gen.maybe neIntSetGen 73 | tripping 74 | m0 75 | (maybe S.empty NES.toSet) 76 | (Identity . NES.nonEmptySet) 77 | 78 | prop_read_show :: Property 79 | prop_read_show = readShow neIntSetGen 80 | 81 | prop_splitRoot :: Property 82 | prop_splitRoot = property $ do 83 | n <- forAll neIntSetGen 84 | let rs = NES.splitRoot n 85 | allItems = foldMap1 NES.toList rs 86 | n' = NES.unions rs 87 | assert $ ascending allItems 88 | mapM_ (assert . (`NES.isSubsetOf` n)) rs 89 | length allItems === NES.size n' 90 | n === n' 91 | where 92 | ascending (x :| xs) = case NE.nonEmpty xs of 93 | Nothing -> True 94 | Just ys@(y :| _) -> x < y && ascending ys 95 | 96 | prop_insertSet :: Property 97 | prop_insertSet = 98 | ttProp 99 | (GTIntKey :-> GTIntSet :-> TTNEIntSet) 100 | S.insert 101 | NES.insertSet 102 | 103 | prop_singleton :: Property 104 | prop_singleton = 105 | ttProp 106 | (GTIntKey :-> TTNEIntSet) 107 | S.singleton 108 | NES.singleton 109 | 110 | prop_fromAscList :: Property 111 | prop_fromAscList = 112 | ttProp 113 | (GTSorted STAsc (GTNEList Nothing (GTIntKey :&: GTVal)) :-> TTNEIntSet) 114 | (S.fromAscList . fmap fst) 115 | (NES.fromAscList . fmap fst) 116 | 117 | prop_fromDistinctAscList :: Property 118 | prop_fromDistinctAscList = 119 | ttProp 120 | (GTSorted STAsc (GTNEList Nothing GTIntKey) :-> TTNEIntSet) 121 | S.fromDistinctAscList 122 | NES.fromDistinctAscList 123 | 124 | prop_fromList :: Property 125 | prop_fromList = 126 | ttProp 127 | (GTNEList Nothing GTIntKey :-> TTNEIntSet) 128 | S.fromList 129 | NES.fromList 130 | 131 | prop_insert :: Property 132 | prop_insert = 133 | ttProp 134 | (GTIntKey :-> GTNEIntSet :-> TTNEIntSet) 135 | S.insert 136 | NES.insert 137 | 138 | prop_delete :: Property 139 | prop_delete = 140 | ttProp 141 | (GTIntKey :-> GTNEIntSet :-> TTOther) 142 | S.delete 143 | NES.delete 144 | 145 | prop_member :: Property 146 | prop_member = 147 | ttProp 148 | (GTIntKey :-> GTNEIntSet :-> TTOther) 149 | S.member 150 | NES.member 151 | 152 | prop_notMember :: Property 153 | prop_notMember = 154 | ttProp 155 | (GTIntKey :-> GTNEIntSet :-> TTOther) 156 | S.notMember 157 | NES.notMember 158 | 159 | prop_lookupLT :: Property 160 | prop_lookupLT = 161 | ttProp 162 | (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) 163 | S.lookupLT 164 | NES.lookupLT 165 | 166 | prop_lookupGT :: Property 167 | prop_lookupGT = 168 | ttProp 169 | (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) 170 | S.lookupGT 171 | NES.lookupGT 172 | 173 | prop_lookupLE :: Property 174 | prop_lookupLE = 175 | ttProp 176 | (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) 177 | S.lookupLE 178 | NES.lookupLE 179 | 180 | prop_lookupGE :: Property 181 | prop_lookupGE = 182 | ttProp 183 | (GTIntKey :-> GTNEIntSet :-> TTMaybe TTOther) 184 | S.lookupGE 185 | NES.lookupGE 186 | 187 | prop_size :: Property 188 | prop_size = 189 | ttProp 190 | (GTNEIntSet :-> TTOther) 191 | S.size 192 | NES.size 193 | 194 | prop_isSubsetOf :: Property 195 | prop_isSubsetOf = 196 | ttProp 197 | (GTNEIntSet :-> GTNEIntSet :-> TTOther) 198 | S.isSubsetOf 199 | NES.isSubsetOf 200 | 201 | prop_isProperSubsetOf :: Property 202 | prop_isProperSubsetOf = 203 | ttProp 204 | (GTNEIntSet :-> GTNEIntSet :-> TTOther) 205 | S.isProperSubsetOf 206 | NES.isProperSubsetOf 207 | 208 | prop_disjoint :: Property 209 | prop_disjoint = 210 | ttProp 211 | (GTNEIntSet :-> GTNEIntSet :-> TTOther) 212 | S.disjoint 213 | NES.disjoint 214 | 215 | prop_union :: Property 216 | prop_union = 217 | ttProp 218 | (GTNEIntSet :-> GTNEIntSet :-> TTNEIntSet) 219 | S.union 220 | NES.union 221 | 222 | prop_unions :: Property 223 | prop_unions = 224 | ttProp 225 | (GTNEList (Just (Range.linear 2 5)) GTNEIntSet :-> TTNEIntSet) 226 | S.unions 227 | NES.unions 228 | 229 | prop_difference :: Property 230 | prop_difference = 231 | ttProp 232 | (GTNEIntSet :-> GTNEIntSet :-> TTOther) 233 | S.difference 234 | NES.difference 235 | 236 | prop_intersection :: Property 237 | prop_intersection = 238 | ttProp 239 | (GTNEIntSet :-> GTNEIntSet :-> TTOther) 240 | S.intersection 241 | NES.intersection 242 | 243 | prop_filter :: Property 244 | prop_filter = 245 | ttProp 246 | (gf1 Gen.bool :?> GTNEIntSet :-> TTOther) 247 | S.filter 248 | NES.filter 249 | 250 | prop_partition :: Property 251 | prop_partition = 252 | ttProp 253 | (gf1 Gen.bool :?> GTNEIntSet :-> TTThese TTNEIntSet TTNEIntSet) 254 | S.partition 255 | NES.partition 256 | 257 | prop_split :: Property 258 | prop_split = 259 | ttProp 260 | (GTIntKey :-> GTNEIntSet :-> TTMThese TTNEIntSet TTNEIntSet) 261 | S.split 262 | NES.split 263 | 264 | prop_splitMember :: Property 265 | prop_splitMember = 266 | ttProp 267 | (GTIntKey :-> GTNEIntSet :-> TTOther :*: TTMThese TTNEIntSet TTNEIntSet) 268 | (\k -> (\(x, y, z) -> (y, (x, z))) . S.splitMember k) 269 | NES.splitMember 270 | 271 | prop_map :: Property 272 | prop_map = 273 | ttProp 274 | (gf1 intKeyGen :?> GTNEIntSet :-> TTNEIntSet) 275 | S.map 276 | NES.map 277 | 278 | prop_foldr :: Property 279 | prop_foldr = 280 | ttProp 281 | ( gf2 valGen 282 | :?> GTOther valGen 283 | :-> GTNEIntSet 284 | :-> TTOther 285 | ) 286 | S.foldr 287 | NES.foldr 288 | 289 | prop_foldl :: Property 290 | prop_foldl = 291 | ttProp 292 | ( gf2 valGen 293 | :?> GTOther valGen 294 | :-> GTNEIntSet 295 | :-> TTOther 296 | ) 297 | S.foldl 298 | NES.foldl 299 | 300 | prop_foldr1 :: Property 301 | prop_foldr1 = 302 | ttProp 303 | ( gf2 intKeyGen 304 | :?> GTNEIntSet 305 | :-> TTOther 306 | ) 307 | (\f -> foldr1 f . S.toList) 308 | NES.foldr1 309 | 310 | prop_foldl1 :: Property 311 | prop_foldl1 = 312 | ttProp 313 | ( gf2 intKeyGen 314 | :?> GTNEIntSet 315 | :-> TTOther 316 | ) 317 | (\f -> foldl1 f . S.toList) 318 | NES.foldl1 319 | 320 | prop_foldr' :: Property 321 | prop_foldr' = 322 | ttProp 323 | ( gf2 intKeyGen 324 | :?> GTOther intKeyGen 325 | :-> GTNEIntSet 326 | :-> TTOther 327 | ) 328 | S.foldr' 329 | NES.foldr' 330 | 331 | prop_foldl' :: Property 332 | prop_foldl' = 333 | ttProp 334 | ( gf2 intKeyGen 335 | :?> GTOther intKeyGen 336 | :-> GTNEIntSet 337 | :-> TTOther 338 | ) 339 | S.foldl' 340 | NES.foldl' 341 | 342 | prop_foldr1' :: Property 343 | prop_foldr1' = 344 | ttProp 345 | ( gf2 intKeyGen 346 | :?> GTNEIntSet 347 | :-> TTOther 348 | ) 349 | (\f -> foldr1 f . S.toList) 350 | NES.foldr1' 351 | 352 | prop_foldl1' :: Property 353 | prop_foldl1' = 354 | ttProp 355 | ( gf2 intKeyGen 356 | :?> GTNEIntSet 357 | :-> TTOther 358 | ) 359 | (\f -> foldl1 f . S.toList) 360 | NES.foldl1' 361 | 362 | prop_findMin :: Property 363 | prop_findMin = 364 | ttProp 365 | (GTNEIntSet :-> TTOther) 366 | S.findMin 367 | NES.findMin 368 | 369 | prop_findMax :: Property 370 | prop_findMax = 371 | ttProp 372 | (GTNEIntSet :-> TTOther) 373 | S.findMax 374 | NES.findMax 375 | 376 | prop_deleteMin :: Property 377 | prop_deleteMin = 378 | ttProp 379 | (GTNEIntSet :-> TTOther) 380 | S.deleteMin 381 | NES.deleteMin 382 | 383 | prop_deleteMax :: Property 384 | prop_deleteMax = 385 | ttProp 386 | (GTNEIntSet :-> TTOther) 387 | S.deleteMax 388 | NES.deleteMax 389 | 390 | prop_deleteFindMin :: Property 391 | prop_deleteFindMin = 392 | ttProp 393 | (GTNEIntSet :-> TTOther :*: TTOther) 394 | S.deleteFindMin 395 | NES.deleteFindMin 396 | 397 | prop_deleteFindMax :: Property 398 | prop_deleteFindMax = 399 | ttProp 400 | (GTNEIntSet :-> TTOther :*: TTOther) 401 | S.deleteFindMax 402 | NES.deleteFindMax 403 | 404 | prop_toList :: Property 405 | prop_toList = 406 | ttProp 407 | (GTNEIntSet :-> TTNEList TTOther) 408 | S.toList 409 | NES.toList 410 | 411 | prop_toDescList :: Property 412 | prop_toDescList = 413 | ttProp 414 | (GTNEIntSet :-> TTNEList TTOther) 415 | S.toDescList 416 | NES.toDescList 417 | -------------------------------------------------------------------------------- /test/Tests/Sequence.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | module Tests.Sequence (sequenceTests) where 6 | 7 | import Control.Applicative 8 | import Control.Comonad 9 | import Control.Monad 10 | import Data.Bifunctor 11 | import qualified Data.Foldable as F 12 | import Data.Functor.Identity 13 | import qualified Data.List.NonEmpty as NE 14 | import Data.Ord 15 | import qualified Data.Semigroup.Foldable as F1 16 | import qualified Data.Semigroup.Traversable as T1 17 | import Data.Sequence (Seq (..)) 18 | import qualified Data.Sequence as Seq 19 | import Data.Sequence.NonEmpty (NESeq (..)) 20 | import qualified Data.Sequence.NonEmpty as NESeq 21 | import Data.Tuple 22 | import Hedgehog 23 | import qualified Hedgehog.Gen as Gen 24 | import Test.Tasty 25 | import Tests.Util 26 | 27 | sequenceTests :: TestTree 28 | sequenceTests = groupTree $$discover 29 | 30 | prop_toSeqIso1 :: Property 31 | prop_toSeqIso1 = property $ do 32 | m0 <- forAll seqGen 33 | tripping 34 | m0 35 | NESeq.nonEmptySeq 36 | (Identity . maybe Seq.empty NESeq.toSeq) 37 | 38 | prop_toSeqIso2 :: Property 39 | prop_toSeqIso2 = property $ do 40 | m0 <- forAll $ Gen.maybe neSeqGen 41 | tripping 42 | m0 43 | (maybe Seq.empty NESeq.toSeq) 44 | (Identity . NESeq.nonEmptySeq) 45 | 46 | prop_read_show :: Property 47 | prop_read_show = readShow neSeqGen 48 | 49 | prop_read1_show1 :: Property 50 | prop_read1_show1 = readShow1 neSeqGen 51 | 52 | prop_show_show1 :: Property 53 | prop_show_show1 = showShow1 neSeqGen 54 | 55 | prop_cons :: Property 56 | prop_cons = 57 | ttProp 58 | (GTVal :-> GTSeq :-> TTNESeq) 59 | (:<|) 60 | (:<||) 61 | 62 | prop_snoc :: Property 63 | prop_snoc = 64 | ttProp 65 | (GTSeq :-> GTVal :-> TTNESeq) 66 | (:|>) 67 | (:||>) 68 | 69 | prop_insertSeqAt :: Property 70 | prop_insertSeqAt = 71 | ttProp 72 | (GTIntKey :-> GTVal :-> GTSeq :-> TTNESeq) 73 | Seq.insertAt 74 | NESeq.insertSeqAt 75 | 76 | prop_singleton :: Property 77 | prop_singleton = 78 | ttProp 79 | (GTVal :-> TTNESeq) 80 | Seq.singleton 81 | NESeq.singleton 82 | 83 | prop_consNE :: Property 84 | prop_consNE = 85 | ttProp 86 | (GTVal :-> GTNESeq :-> TTNESeq) 87 | (Seq.<|) 88 | (NESeq.<|) 89 | 90 | prop_snocNE :: Property 91 | prop_snocNE = 92 | ttProp 93 | (GTNESeq :-> GTVal :-> TTNESeq) 94 | (Seq.|>) 95 | (NESeq.|>) 96 | 97 | prop_append :: Property 98 | prop_append = 99 | ttProp 100 | (GTNESeq :-> GTNESeq :-> TTNESeq) 101 | (Seq.><) 102 | (NESeq.><) 103 | 104 | prop_appendL :: Property 105 | prop_appendL = 106 | ttProp 107 | (GTNESeq :-> GTSeq :-> TTNESeq) 108 | (Seq.><) 109 | (NESeq.|><) 110 | 111 | prop_appendR :: Property 112 | prop_appendR = 113 | ttProp 114 | (GTSeq :-> GTNESeq :-> TTNESeq) 115 | (Seq.><) 116 | (NESeq.><|) 117 | 118 | prop_fromList :: Property 119 | prop_fromList = 120 | ttProp 121 | (GTNEList Nothing GTVal :-> TTNESeq) 122 | Seq.fromList 123 | NESeq.fromList 124 | 125 | prop_fromFunction :: Property 126 | prop_fromFunction = 127 | ttProp 128 | (GTSize :-> gf1 valGen :?> TTNESeq) 129 | (Seq.fromFunction . (+ 1)) 130 | (NESeq.fromFunction . (+ 1)) 131 | 132 | prop_replicate :: Property 133 | prop_replicate = 134 | ttProp 135 | (GTSize :-> GTVal :-> TTNESeq) 136 | (Seq.replicate . (+ 1)) 137 | (NESeq.replicate . (+ 1)) 138 | 139 | prop_replicateA :: Property 140 | prop_replicateA = 141 | ttProp 142 | (GTSize :-> GTVal :-> TTBazaar GTVal TTNESeq TTVal) 143 | (\i x -> Seq.replicateA (i + 1) (x `More` Done id)) 144 | (\i x -> NESeq.replicateA (i + 1) (x `More` Done id)) 145 | 146 | prop_replicateA1 :: Property 147 | prop_replicateA1 = 148 | ttProp 149 | (GTSize :-> GTVal :-> TTBazaar GTVal TTNESeq TTVal) 150 | (\i x -> Seq.replicateA (i + 1) (x `More` Done id)) 151 | (\i x -> NESeq.replicateA1 (i + 1) (x `More` Done id)) 152 | 153 | prop_cycleTaking :: Property 154 | prop_cycleTaking = 155 | ttProp 156 | (GTSize :-> GTNESeq :-> TTNESeq) 157 | (Seq.cycleTaking . (* 5) . (+ 1)) 158 | (NESeq.cycleTaking . (* 5) . (+ 1)) 159 | 160 | prop_iterateN :: Property 161 | prop_iterateN = 162 | ttProp 163 | (GTSize :-> gf1 valGen :?> GTVal :-> TTNESeq) 164 | (Seq.iterateN . (+ 1)) 165 | (NESeq.iterateN . (+ 1)) 166 | 167 | prop_unfoldr :: Property 168 | prop_unfoldr = 169 | ttProp 170 | ( GTSize 171 | :-> gf1 ((,) <$> valGen <*> Gen.maybe intKeyGen) 172 | :?> GTIntKey 173 | :-> TTNESeqList 174 | ) 175 | (\i f -> NE.unfoldr (limiter f) . (i,)) 176 | (\i f -> NESeq.unfoldr (limiter f) . (i,)) 177 | 178 | prop_unfoldl :: Property 179 | prop_unfoldl = 180 | ttProp 181 | ( GTSize 182 | :-> gf1 ((,) <$> valGen <*> Gen.maybe intKeyGen) 183 | :?> GTIntKey 184 | :-> TTNESeqList 185 | ) 186 | (\i f -> NE.reverse . NE.unfoldr (limiter f) . (i,)) 187 | (\i f -> NESeq.unfoldl (swap . limiter f) . (i,)) 188 | 189 | limiter :: 190 | (a -> (b, Maybe a)) -> 191 | (Int, a) -> 192 | (b, Maybe (Int, a)) 193 | limiter f (n, x) = second (go =<<) $ f x 194 | where 195 | go y 196 | | n <= 0 = Nothing 197 | | otherwise = Just (n - 1, y) 198 | 199 | prop_head :: Property 200 | prop_head = 201 | ttProp 202 | (GTNESeq :-> TTMaybe TTVal) 203 | (\case x :<| _ -> Just x; Empty -> Nothing) 204 | (Just . NESeq.head) 205 | 206 | prop_tail :: Property 207 | prop_tail = 208 | ttProp 209 | (GTNESeq :-> TTMaybe TTOther) 210 | (\case _ :<| xs -> Just xs; Empty -> Nothing) 211 | (Just . NESeq.tail) 212 | 213 | prop_last :: Property 214 | prop_last = 215 | ttProp 216 | (GTNESeq :-> TTMaybe TTVal) 217 | (\case _ :|> x -> Just x; Empty -> Nothing) 218 | (Just . NESeq.last) 219 | 220 | prop_init :: Property 221 | prop_init = 222 | ttProp 223 | (GTNESeq :-> TTMaybe TTOther) 224 | (\case xs :|> _ -> Just xs; Empty -> Nothing) 225 | (Just . NESeq.init) 226 | 227 | prop_length :: Property 228 | prop_length = 229 | ttProp 230 | (GTNESeq :-> TTOther) 231 | Seq.length 232 | NESeq.length 233 | 234 | prop_scanl :: Property 235 | prop_scanl = 236 | ttProp 237 | (gf2 valGen :?> GTVal :-> GTNESeq :-> TTNESeq) 238 | Seq.scanl 239 | NESeq.scanl 240 | 241 | prop_scanl1 :: Property 242 | prop_scanl1 = 243 | ttProp 244 | (gf2 valGen :?> GTNESeq :-> TTNESeq) 245 | Seq.scanl1 246 | NESeq.scanl1 247 | 248 | prop_scanr :: Property 249 | prop_scanr = 250 | ttProp 251 | (gf2 valGen :?> GTVal :-> GTNESeq :-> TTNESeq) 252 | Seq.scanr 253 | NESeq.scanr 254 | 255 | prop_scanr1 :: Property 256 | prop_scanr1 = 257 | ttProp 258 | (gf2 valGen :?> GTNESeq :-> TTNESeq) 259 | Seq.scanl1 260 | NESeq.scanl1 261 | 262 | prop_tails :: Property 263 | prop_tails = 264 | ttProp 265 | (GTNESeq :-> TTNESeq) 266 | (Seq.filter (not . null) . Seq.tails) 267 | (fmap NESeq.toSeq . NESeq.tails) 268 | 269 | prop_inits :: Property 270 | prop_inits = 271 | ttProp 272 | (GTNESeq :-> TTNESeq) 273 | (Seq.filter (not . null) . Seq.inits) 274 | (fmap NESeq.toSeq . NESeq.inits) 275 | 276 | prop_chunksOf :: Property 277 | prop_chunksOf = 278 | ttProp 279 | (GTSize :-> GTNESeq :-> TTNESeq) 280 | (\i -> Seq.filter (not . null) . Seq.chunksOf (i + 1)) 281 | (\i -> fmap NESeq.toSeq . NESeq.chunksOf (i + 1)) 282 | 283 | prop_takeWhileL :: Property 284 | prop_takeWhileL = 285 | ttProp 286 | (gf1 Gen.bool :?> GTNESeq :-> TTOther) 287 | Seq.takeWhileL 288 | NESeq.takeWhileL 289 | 290 | prop_takeWhileR :: Property 291 | prop_takeWhileR = 292 | ttProp 293 | (gf1 Gen.bool :?> GTNESeq :-> TTOther) 294 | Seq.takeWhileR 295 | NESeq.takeWhileR 296 | 297 | prop_dropWhileL :: Property 298 | prop_dropWhileL = 299 | ttProp 300 | (gf1 Gen.bool :?> GTNESeq :-> TTOther) 301 | Seq.dropWhileL 302 | NESeq.dropWhileL 303 | 304 | prop_dropWhileR :: Property 305 | prop_dropWhileR = 306 | ttProp 307 | (gf1 Gen.bool :?> GTNESeq :-> TTOther) 308 | Seq.dropWhileR 309 | NESeq.dropWhileR 310 | 311 | prop_spanl :: Property 312 | prop_spanl = 313 | ttProp 314 | (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) 315 | Seq.spanl 316 | NESeq.spanl 317 | 318 | prop_spanr :: Property 319 | prop_spanr = 320 | ttProp 321 | (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) 322 | Seq.spanr 323 | NESeq.spanr 324 | 325 | prop_breakl :: Property 326 | prop_breakl = 327 | ttProp 328 | (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) 329 | Seq.breakl 330 | NESeq.breakl 331 | 332 | prop_breakr :: Property 333 | prop_breakr = 334 | ttProp 335 | (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) 336 | Seq.breakr 337 | NESeq.breakr 338 | 339 | prop_partition :: Property 340 | prop_partition = 341 | ttProp 342 | (gf1 Gen.bool :?> GTNESeq :-> TTThese TTNESeq TTNESeq) 343 | Seq.partition 344 | NESeq.partition 345 | 346 | prop_filter :: Property 347 | prop_filter = 348 | ttProp 349 | (gf1 Gen.bool :?> GTNESeq :-> TTOther) 350 | Seq.filter 351 | NESeq.filter 352 | 353 | prop_sort :: Property 354 | prop_sort = 355 | ttProp 356 | (GTNESeq :-> TTNESeq) 357 | Seq.sort 358 | NESeq.sort 359 | 360 | prop_sortBy :: Property 361 | prop_sortBy = 362 | ttProp 363 | (gf1 valGen :?> GTNESeq :-> TTNESeq) 364 | (Seq.sortBy . comparing) 365 | (NESeq.sortBy . comparing) 366 | 367 | prop_sortOn :: Property 368 | prop_sortOn = 369 | ttProp 370 | (gf1 valGen :?> GTNESeq :-> TTNESeq) 371 | Seq.sortOn 372 | NESeq.sortOn 373 | 374 | prop_unstableSort :: Property 375 | prop_unstableSort = 376 | ttProp 377 | (GTNESeq :-> TTNESeq) 378 | Seq.unstableSort 379 | NESeq.unstableSort 380 | 381 | prop_unstableSortBy :: Property 382 | prop_unstableSortBy = 383 | ttProp 384 | (gf1 valGen :?> GTNESeq :-> TTNESeq) 385 | (Seq.unstableSortBy . comparing) 386 | (NESeq.unstableSortBy . comparing) 387 | 388 | prop_unstableSortOn :: Property 389 | prop_unstableSortOn = 390 | ttProp 391 | (gf1 valGen :?> GTNESeq :-> TTNESeq) 392 | Seq.unstableSortOn 393 | NESeq.unstableSortOn 394 | 395 | prop_lookup :: Property 396 | prop_lookup = 397 | ttProp 398 | (GTIntKey :-> GTNESeq :-> TTMaybe TTVal) 399 | Seq.lookup 400 | NESeq.lookup 401 | 402 | prop_index :: Property 403 | prop_index = 404 | ttProp 405 | (GTNESeq :-> GTIntKey :-> TTVal) 406 | (\xs i -> xs `Seq.index` (i `mod` Seq.length xs)) 407 | (\xs i -> xs `NESeq.index` (i `mod` NESeq.length xs)) 408 | 409 | prop_adjust :: Property 410 | prop_adjust = 411 | ttProp 412 | (gf1 valGen :?> GTIntKey :-> GTNESeq :-> TTNESeq) 413 | Seq.adjust 414 | NESeq.adjust 415 | 416 | prop_adjust' :: Property 417 | prop_adjust' = 418 | ttProp 419 | (gf1 valGen :?> GTIntKey :-> GTNESeq :-> TTNESeq) 420 | Seq.adjust' 421 | NESeq.adjust' 422 | 423 | prop_update :: Property 424 | prop_update = 425 | ttProp 426 | (GTIntKey :-> GTVal :-> GTNESeq :-> TTNESeq) 427 | Seq.update 428 | NESeq.update 429 | 430 | prop_take :: Property 431 | prop_take = 432 | ttProp 433 | (GTIntKey :-> GTNESeq :-> TTOther) 434 | Seq.take 435 | NESeq.take 436 | 437 | prop_drop :: Property 438 | prop_drop = 439 | ttProp 440 | (GTIntKey :-> GTNESeq :-> TTOther) 441 | Seq.drop 442 | NESeq.drop 443 | 444 | prop_insertAt :: Property 445 | prop_insertAt = 446 | ttProp 447 | (GTIntKey :-> GTVal :-> GTNESeq :-> TTNESeq) 448 | Seq.insertAt 449 | NESeq.insertAt 450 | 451 | prop_deleteAt :: Property 452 | prop_deleteAt = 453 | ttProp 454 | (GTIntKey :-> GTNESeq :-> TTOther) 455 | Seq.deleteAt 456 | NESeq.deleteAt 457 | 458 | prop_splitAt :: Property 459 | prop_splitAt = 460 | ttProp 461 | (GTIntKey :-> GTNESeq :-> TTThese TTNESeq TTNESeq) 462 | Seq.splitAt 463 | NESeq.splitAt 464 | 465 | prop_elemIndexL :: Property 466 | prop_elemIndexL = 467 | ttProp 468 | (GTVal :-> GTNESeq :-> TTOther) 469 | Seq.elemIndexL 470 | NESeq.elemIndexL 471 | 472 | prop_elemIndicesL :: Property 473 | prop_elemIndicesL = 474 | ttProp 475 | (GTVal :-> GTNESeq :-> TTOther) 476 | Seq.elemIndicesL 477 | NESeq.elemIndicesL 478 | 479 | prop_elemIndexR :: Property 480 | prop_elemIndexR = 481 | ttProp 482 | (GTVal :-> GTNESeq :-> TTOther) 483 | Seq.elemIndexR 484 | NESeq.elemIndexR 485 | 486 | prop_elemIndicesR :: Property 487 | prop_elemIndicesR = 488 | ttProp 489 | (GTVal :-> GTNESeq :-> TTOther) 490 | Seq.elemIndicesR 491 | NESeq.elemIndicesR 492 | 493 | prop_findIndexL :: Property 494 | prop_findIndexL = 495 | ttProp 496 | (gf1 Gen.bool :?> GTNESeq :-> TTOther) 497 | Seq.findIndexL 498 | NESeq.findIndexL 499 | 500 | prop_findIndicesL :: Property 501 | prop_findIndicesL = 502 | ttProp 503 | (gf1 Gen.bool :?> GTNESeq :-> TTOther) 504 | Seq.findIndicesL 505 | NESeq.findIndicesL 506 | 507 | prop_findIndexR :: Property 508 | prop_findIndexR = 509 | ttProp 510 | (gf1 Gen.bool :?> GTNESeq :-> TTOther) 511 | Seq.findIndexR 512 | NESeq.findIndexR 513 | 514 | prop_findIndicesR :: Property 515 | prop_findIndicesR = 516 | ttProp 517 | (gf1 Gen.bool :?> GTNESeq :-> TTOther) 518 | Seq.findIndicesR 519 | NESeq.findIndicesR 520 | 521 | prop_foldMapWithIndex :: Property 522 | prop_foldMapWithIndex = 523 | ttProp 524 | (gf2 valGen :?> GTNESeq :-> TTOther) 525 | (\f -> Seq.foldMapWithIndex (\i -> (: []) . f i)) 526 | (\f -> NESeq.foldMapWithIndex (\i -> (: []) . f i)) 527 | 528 | prop_foldlWithIndex :: Property 529 | prop_foldlWithIndex = 530 | ttProp 531 | (gf3 valGen :?> GTVal :-> GTNESeq :-> TTVal) 532 | Seq.foldlWithIndex 533 | NESeq.foldlWithIndex 534 | 535 | prop_foldrWithIndex :: Property 536 | prop_foldrWithIndex = 537 | ttProp 538 | (gf3 valGen :?> GTVal :-> GTNESeq :-> TTVal) 539 | Seq.foldrWithIndex 540 | NESeq.foldrWithIndex 541 | 542 | prop_mapWithIndex :: Property 543 | prop_mapWithIndex = 544 | ttProp 545 | (gf2 valGen :?> GTNESeq :-> TTNESeq) 546 | Seq.mapWithIndex 547 | NESeq.mapWithIndex 548 | 549 | prop_traverseWithIndex :: Property 550 | prop_traverseWithIndex = 551 | ttProp 552 | (gf2 valGen :?> GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) 553 | (\f -> Seq.traverseWithIndex (\k -> (`More` Done (f k)))) 554 | (\f -> NESeq.traverseWithIndex (\k -> (`More` Done (f k)))) 555 | 556 | prop_traverseWithIndex1 :: Property 557 | prop_traverseWithIndex1 = 558 | ttProp 559 | (gf2 valGen :?> GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) 560 | (\f -> Seq.traverseWithIndex (\k -> (`More` Done (f k)))) 561 | (\f -> NESeq.traverseWithIndex1 (\k -> (`More` Done (f k)))) 562 | 563 | prop_reverse :: Property 564 | prop_reverse = 565 | ttProp 566 | (GTNESeq :-> TTNESeq) 567 | Seq.reverse 568 | NESeq.reverse 569 | 570 | prop_intersperse :: Property 571 | prop_intersperse = 572 | ttProp 573 | (GTVal :-> GTNESeq :-> TTNESeq) 574 | Seq.intersperse 575 | NESeq.intersperse 576 | 577 | prop_zip :: Property 578 | prop_zip = 579 | ttProp 580 | (GTNESeq :-> GTNESeq :-> TTNESeq) 581 | Seq.zip 582 | NESeq.zip 583 | 584 | prop_zipWith :: Property 585 | prop_zipWith = 586 | ttProp 587 | (gf2 valGen :?> GTNESeq :-> GTNESeq :-> TTNESeq) 588 | Seq.zipWith 589 | NESeq.zipWith 590 | 591 | prop_zip3 :: Property 592 | prop_zip3 = 593 | ttProp 594 | (GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) 595 | Seq.zip3 596 | NESeq.zip3 597 | 598 | prop_zipWith3 :: Property 599 | prop_zipWith3 = 600 | ttProp 601 | (gf3 valGen :?> GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) 602 | Seq.zipWith3 603 | NESeq.zipWith3 604 | 605 | prop_zip4 :: Property 606 | prop_zip4 = 607 | ttProp 608 | (GTNESeq :-> GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) 609 | Seq.zip4 610 | NESeq.zip4 611 | 612 | prop_zipWith4 :: Property 613 | prop_zipWith4 = 614 | ttProp 615 | (gf4 valGen :?> GTNESeq :-> GTNESeq :-> GTNESeq :-> GTNESeq :-> TTNESeq) 616 | Seq.zipWith4 617 | NESeq.zipWith4 618 | 619 | prop_unzip :: Property 620 | prop_unzip = 621 | ttProp 622 | (GTNESeq :-> GTNESeq :-> TTNESeq :*: TTNESeq) 623 | (\xs -> Seq.unzip . Seq.zip xs) 624 | (\xs -> NESeq.unzip . NESeq.zip xs) 625 | 626 | prop_unzipWith :: Property 627 | prop_unzipWith = 628 | ttProp 629 | ( gf1 ((,) <$> valGen <*> valGen) 630 | :?> GTNESeq 631 | :-> TTNESeq 632 | :*: TTNESeq 633 | ) 634 | Seq.unzipWith 635 | NESeq.unzipWith 636 | 637 | prop_liftA2 :: Property 638 | prop_liftA2 = 639 | ttProp 640 | (gf2 valGen :?> GTNESeq :-> GTNESeq :-> TTNESeq) 641 | liftA2 642 | liftA2 643 | 644 | prop_liftM2 :: Property 645 | prop_liftM2 = 646 | ttProp 647 | (gf2 valGen :?> GTNESeq :-> GTNESeq :-> TTNESeq) 648 | liftM2 649 | liftM2 650 | 651 | prop_duplicate :: Property 652 | prop_duplicate = 653 | ttProp 654 | (GTNESeqList :-> TTNESeqList) 655 | duplicate 656 | (fmap F1.toNonEmpty . duplicate) 657 | 658 | prop_foldMap :: Property 659 | prop_foldMap = 660 | ttProp 661 | (gf1 valGen :?> GTNESeq :-> TTOther) 662 | (foldMap . fmap (: [])) 663 | (foldMap . fmap (: [])) 664 | 665 | prop_foldl :: Property 666 | prop_foldl = 667 | ttProp 668 | (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) 669 | foldl 670 | foldl 671 | 672 | prop_foldr :: Property 673 | prop_foldr = 674 | ttProp 675 | (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) 676 | foldr 677 | foldr 678 | 679 | prop_foldl' :: Property 680 | prop_foldl' = 681 | ttProp 682 | (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) 683 | F.foldl' 684 | F.foldl' 685 | 686 | prop_foldr' :: Property 687 | prop_foldr' = 688 | ttProp 689 | (gf2 valGen :?> GTVal :-> GTNESeq :-> TTVal) 690 | F.foldr' 691 | F.foldr' 692 | 693 | prop_foldl1 :: Property 694 | prop_foldl1 = 695 | ttProp 696 | (gf2 valGen :?> GTNESeq :-> TTVal) 697 | foldl1 698 | foldl1 699 | 700 | prop_foldr1 :: Property 701 | prop_foldr1 = 702 | ttProp 703 | (gf2 valGen :?> GTNESeq :-> TTVal) 704 | foldr1 705 | foldr1 706 | 707 | prop_fold :: Property 708 | prop_fold = 709 | ttProp 710 | (GTNESeq :-> TTVal) 711 | F.fold 712 | F.fold 713 | 714 | prop_fold1 :: Property 715 | prop_fold1 = 716 | ttProp 717 | (GTNESeq :-> TTVal) 718 | F.fold 719 | F1.fold1 720 | 721 | prop_toList :: Property 722 | prop_toList = 723 | ttProp 724 | (GTNESeq :-> TTOther) 725 | F.toList 726 | F.toList 727 | 728 | prop_toNonEmpty :: Property 729 | prop_toNonEmpty = 730 | ttProp 731 | (GTNESeq :-> TTNEList TTVal) 732 | F.toList 733 | F1.toNonEmpty 734 | 735 | prop_sequenceA :: Property 736 | prop_sequenceA = 737 | ttProp 738 | (GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) 739 | (sequenceA . fmap (`More` Done id)) 740 | (sequenceA . fmap (`More` Done id)) 741 | {-# ANN prop_sequenceA "HLint: ignore Use traverse" #-} 742 | 743 | prop_sequence1 :: Property 744 | prop_sequence1 = 745 | ttProp 746 | (GTNESeq :-> TTBazaar GTVal TTNESeq TTVal) 747 | (sequenceA . fmap (`More` Done id)) 748 | (T1.sequence1 . fmap (`More` Done id)) 749 | {-# ANN prop_sequence1 "HLint: ignore Use traverse" #-} 750 | -------------------------------------------------------------------------------- /test/Tests/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Tests.Set (setTests) where 4 | 5 | import Data.Foldable 6 | import Data.Functor.Identity 7 | import Data.Semigroup.Foldable 8 | import qualified Data.Set as S 9 | import qualified Data.Set.NonEmpty as NES 10 | import qualified Data.Set.NonEmpty.Internal as NES 11 | import Hedgehog 12 | import qualified Hedgehog.Gen as Gen 13 | import qualified Hedgehog.Range as Range 14 | import Test.Tasty 15 | import Tests.Util 16 | 17 | setTests :: TestTree 18 | setTests = groupTree $$discover 19 | 20 | prop_valid :: Property 21 | prop_valid = 22 | property $ 23 | assert . NES.valid =<< forAll neSetGen 24 | 25 | prop_valid_toSet :: Property 26 | prop_valid_toSet = property $ do 27 | assert . S.valid . NES.toSet =<< forAll neSetGen 28 | 29 | prop_valid_insertMinSet :: Property 30 | prop_valid_insertMinSet = property $ do 31 | n <- forAll $ do 32 | m <- setGen 33 | let k = maybe dummyKey (subtract 1) $ S.lookupMin m 34 | pure $ NES.insertMinSet k m 35 | assert $ S.valid n 36 | 37 | prop_valid_insertMaxSet :: Property 38 | prop_valid_insertMaxSet = property $ do 39 | n <- forAll $ do 40 | m <- setGen 41 | let k = maybe dummyKey (+ 1) $ S.lookupMax m 42 | pure $ NES.insertMaxSet k m 43 | assert $ S.valid n 44 | 45 | prop_valid_insertSetMin :: Property 46 | prop_valid_insertSetMin = property $ do 47 | n <- forAll $ do 48 | m <- setGen 49 | let k = maybe dummyKey (subtract 1) $ S.lookupMin m 50 | pure $ NES.insertSetMin k m 51 | assert $ NES.valid n 52 | 53 | prop_valid_insertSetMax :: Property 54 | prop_valid_insertSetMax = property $ do 55 | n <- forAll $ do 56 | m <- setGen 57 | let k = maybe dummyKey (+ 1) $ S.lookupMax m 58 | pure $ NES.insertSetMax k m 59 | assert $ NES.valid n 60 | 61 | prop_toSetIso1 :: Property 62 | prop_toSetIso1 = property $ do 63 | m0 <- forAll setGen 64 | tripping 65 | m0 66 | NES.nonEmptySet 67 | (Identity . maybe S.empty NES.toSet) 68 | 69 | prop_toSetIso2 :: Property 70 | prop_toSetIso2 = property $ do 71 | m0 <- forAll $ Gen.maybe neSetGen 72 | tripping 73 | m0 74 | (maybe S.empty NES.toSet) 75 | (Identity . NES.nonEmptySet) 76 | 77 | prop_read_show :: Property 78 | prop_read_show = readShow neSetGen 79 | 80 | prop_show_show1 :: Property 81 | prop_show_show1 = showShow1 neSetGen 82 | 83 | prop_splitRoot :: Property 84 | prop_splitRoot = property $ do 85 | n <- forAll neSetGen 86 | let rs = NES.splitRoot n 87 | n' = foldl1 NES.merge rs 88 | assert $ NES.valid n' 89 | mapM_ (assert . (`NES.isSubsetOf` n)) rs 90 | n === n' 91 | 92 | prop_insertSet :: Property 93 | prop_insertSet = 94 | ttProp 95 | (GTKey :-> GTSet :-> TTNESet) 96 | S.insert 97 | NES.insertSet 98 | 99 | prop_singleton :: Property 100 | prop_singleton = 101 | ttProp 102 | (GTKey :-> TTNESet) 103 | S.singleton 104 | NES.singleton 105 | 106 | prop_fromAscList :: Property 107 | prop_fromAscList = 108 | ttProp 109 | (GTSorted STAsc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNESet) 110 | (S.fromAscList . fmap fst) 111 | (NES.fromAscList . fmap fst) 112 | 113 | prop_fromDescList :: Property 114 | prop_fromDescList = 115 | ttProp 116 | (GTSorted STDesc (GTNEList Nothing (GTKey :&: GTVal)) :-> TTNESet) 117 | (S.fromDescList . fmap fst) 118 | (NES.fromDescList . fmap fst) 119 | 120 | prop_fromDistinctAscList :: Property 121 | prop_fromDistinctAscList = 122 | ttProp 123 | (GTSorted STAsc (GTNEList Nothing GTKey) :-> TTNESet) 124 | S.fromDistinctAscList 125 | NES.fromDistinctAscList 126 | 127 | prop_fromDistinctDescList :: Property 128 | prop_fromDistinctDescList = 129 | ttProp 130 | (GTSorted STDesc (GTNEList Nothing GTKey) :-> TTNESet) 131 | S.fromDistinctDescList 132 | NES.fromDistinctDescList 133 | 134 | prop_fromList :: Property 135 | prop_fromList = 136 | ttProp 137 | (GTNEList Nothing GTKey :-> TTNESet) 138 | S.fromList 139 | NES.fromList 140 | 141 | prop_powerSet :: Property 142 | prop_powerSet = 143 | ttProp 144 | (GTNESet :-> TTNEList TTNESet) 145 | (S.toList . S.drop 1 . S.powerSet) 146 | (NES.toList . NES.powerSet) 147 | 148 | prop_insert :: Property 149 | prop_insert = 150 | ttProp 151 | (GTKey :-> GTNESet :-> TTNESet) 152 | S.insert 153 | NES.insert 154 | 155 | prop_delete :: Property 156 | prop_delete = 157 | ttProp 158 | (GTKey :-> GTNESet :-> TTSet) 159 | S.delete 160 | NES.delete 161 | 162 | prop_member :: Property 163 | prop_member = 164 | ttProp 165 | (GTKey :-> GTNESet :-> TTOther) 166 | S.member 167 | NES.member 168 | 169 | prop_notMember :: Property 170 | prop_notMember = 171 | ttProp 172 | (GTKey :-> GTNESet :-> TTOther) 173 | S.notMember 174 | NES.notMember 175 | 176 | prop_lookupLT :: Property 177 | prop_lookupLT = 178 | ttProp 179 | (GTKey :-> GTNESet :-> TTMaybe TTKey) 180 | S.lookupLT 181 | NES.lookupLT 182 | 183 | prop_lookupGT :: Property 184 | prop_lookupGT = 185 | ttProp 186 | (GTKey :-> GTNESet :-> TTMaybe TTKey) 187 | S.lookupGT 188 | NES.lookupGT 189 | 190 | prop_lookupLE :: Property 191 | prop_lookupLE = 192 | ttProp 193 | (GTKey :-> GTNESet :-> TTMaybe TTKey) 194 | S.lookupLE 195 | NES.lookupLE 196 | 197 | prop_lookupGE :: Property 198 | prop_lookupGE = 199 | ttProp 200 | (GTKey :-> GTNESet :-> TTMaybe TTKey) 201 | S.lookupGE 202 | NES.lookupGE 203 | 204 | prop_size :: Property 205 | prop_size = 206 | ttProp 207 | (GTNESet :-> TTOther) 208 | S.size 209 | NES.size 210 | 211 | prop_isSubsetOf :: Property 212 | prop_isSubsetOf = 213 | ttProp 214 | (GTNESet :-> GTNESet :-> TTOther) 215 | S.isSubsetOf 216 | NES.isSubsetOf 217 | 218 | prop_isProperSubsetOf :: Property 219 | prop_isProperSubsetOf = 220 | ttProp 221 | (GTNESet :-> GTNESet :-> TTOther) 222 | S.isProperSubsetOf 223 | NES.isProperSubsetOf 224 | 225 | prop_disjoint :: Property 226 | prop_disjoint = 227 | ttProp 228 | (GTNESet :-> GTNESet :-> TTOther) 229 | S.disjoint 230 | NES.disjoint 231 | 232 | prop_union :: Property 233 | prop_union = 234 | ttProp 235 | (GTNESet :-> GTNESet :-> TTNESet) 236 | S.union 237 | NES.union 238 | 239 | prop_unions :: Property 240 | prop_unions = 241 | ttProp 242 | (GTNEList (Just (Range.linear 2 5)) GTNESet :-> TTNESet) 243 | S.unions 244 | NES.unions 245 | 246 | prop_difference :: Property 247 | prop_difference = 248 | ttProp 249 | (GTNESet :-> GTNESet :-> TTSet) 250 | S.difference 251 | NES.difference 252 | 253 | prop_intersection :: Property 254 | prop_intersection = 255 | ttProp 256 | (GTNESet :-> GTNESet :-> TTSet) 257 | S.intersection 258 | NES.intersection 259 | 260 | prop_cartesianProduct :: Property 261 | prop_cartesianProduct = 262 | ttProp 263 | (GTNESet :-> GTNESet :-> TTNEList (TTKey :*: TTKey)) 264 | (\xs -> S.toList . S.cartesianProduct xs) 265 | (\xs -> NES.toList . NES.cartesianProduct xs) 266 | 267 | prop_disjointUnion :: Property 268 | prop_disjointUnion = 269 | ttProp 270 | (GTNESet :-> GTNESet :-> TTNEList (TTEither TTKey TTKey)) 271 | (\xs -> S.toList . S.disjointUnion xs) 272 | (\xs -> NES.toList . NES.disjointUnion xs) 273 | 274 | prop_filter :: Property 275 | prop_filter = 276 | ttProp 277 | (gf1 Gen.bool :?> GTNESet :-> TTSet) 278 | S.filter 279 | NES.filter 280 | 281 | prop_takeWhileAntitone :: Property 282 | prop_takeWhileAntitone = 283 | ttProp 284 | (GTNESet :-> TTSet) 285 | (S.takeWhileAntitone ((< 0) . getKX)) 286 | (NES.takeWhileAntitone ((< 0) . getKX)) 287 | 288 | prop_dropWhileAntitone :: Property 289 | prop_dropWhileAntitone = 290 | ttProp 291 | (GTNESet :-> TTSet) 292 | (S.dropWhileAntitone ((< 0) . getKX)) 293 | (NES.dropWhileAntitone ((< 0) . getKX)) 294 | 295 | prop_spanAntitone :: Property 296 | prop_spanAntitone = 297 | ttProp 298 | (GTNESet :-> TTThese TTNESet TTNESet) 299 | (S.spanAntitone ((< 0) . getKX)) 300 | (NES.spanAntitone ((< 0) . getKX)) 301 | 302 | prop_partition :: Property 303 | prop_partition = 304 | ttProp 305 | (gf1 Gen.bool :?> GTNESet :-> TTThese TTNESet TTNESet) 306 | S.partition 307 | NES.partition 308 | 309 | prop_split :: Property 310 | prop_split = 311 | ttProp 312 | (GTKey :-> GTNESet :-> TTMThese TTNESet TTNESet) 313 | S.split 314 | NES.split 315 | 316 | prop_splitMember :: Property 317 | prop_splitMember = 318 | ttProp 319 | (GTKey :-> GTNESet :-> TTOther :*: TTMThese TTNESet TTNESet) 320 | (\k -> (\(x, y, z) -> (y, (x, z))) . S.splitMember k) 321 | NES.splitMember 322 | 323 | prop_lookupIndex :: Property 324 | prop_lookupIndex = 325 | ttProp 326 | (GTKey :-> GTNESet :-> TTMaybe TTOther) 327 | S.lookupIndex 328 | NES.lookupIndex 329 | 330 | prop_elemAt :: Property 331 | prop_elemAt = 332 | ttProp 333 | (GTSize :-> GTNESet :-> TTKey) 334 | (\i m -> S.elemAt (i `mod` S.size m) m) 335 | (\i m -> NES.elemAt (i `mod` NES.size m) m) 336 | 337 | prop_deleteAt :: Property 338 | prop_deleteAt = 339 | ttProp 340 | (GTSize :-> GTNESet :-> TTSet) 341 | (\i m -> S.deleteAt (i `mod` S.size m) m) 342 | (\i m -> NES.deleteAt (i `mod` NES.size m) m) 343 | 344 | prop_take :: Property 345 | prop_take = 346 | ttProp 347 | (GTSize :-> GTNESet :-> TTSet) 348 | S.take 349 | NES.take 350 | 351 | prop_drop :: Property 352 | prop_drop = 353 | ttProp 354 | (GTSize :-> GTNESet :-> TTSet) 355 | S.drop 356 | NES.drop 357 | 358 | prop_splitAt :: Property 359 | prop_splitAt = 360 | ttProp 361 | (GTSize :-> GTNESet :-> TTThese TTNESet TTNESet) 362 | S.splitAt 363 | NES.splitAt 364 | 365 | prop_map :: Property 366 | prop_map = 367 | ttProp 368 | (gf1 keyGen :?> GTNESet :-> TTNESet) 369 | S.map 370 | NES.map 371 | 372 | prop_mapMonotonic :: Property 373 | prop_mapMonotonic = 374 | ttProp 375 | (GF valGen go :?> GTNESet :-> TTNESet) 376 | S.mapMonotonic 377 | NES.mapMonotonic 378 | where 379 | go f (K i t) = K (i * 2) (f t) 380 | 381 | prop_foldr :: Property 382 | prop_foldr = 383 | ttProp 384 | ( gf2 valGen 385 | :?> GTOther valGen 386 | :-> GTNESet 387 | :-> TTOther 388 | ) 389 | S.foldr 390 | NES.foldr 391 | 392 | prop_foldl :: Property 393 | prop_foldl = 394 | ttProp 395 | ( gf2 valGen 396 | :?> GTOther valGen 397 | :-> GTNESet 398 | :-> TTOther 399 | ) 400 | S.foldl 401 | NES.foldl 402 | 403 | prop_foldr1 :: Property 404 | prop_foldr1 = 405 | ttProp 406 | ( gf2 keyGen 407 | :?> GTNESet 408 | :-> TTOther 409 | ) 410 | foldr1 411 | NES.foldr1 412 | 413 | prop_foldl1 :: Property 414 | prop_foldl1 = 415 | ttProp 416 | ( gf2 keyGen 417 | :?> GTNESet 418 | :-> TTOther 419 | ) 420 | foldl1 421 | NES.foldl1 422 | 423 | prop_foldr' :: Property 424 | prop_foldr' = 425 | ttProp 426 | ( gf2 keyGen 427 | :?> GTOther keyGen 428 | :-> GTNESet 429 | :-> TTOther 430 | ) 431 | S.foldr' 432 | NES.foldr' 433 | 434 | prop_foldl' :: Property 435 | prop_foldl' = 436 | ttProp 437 | ( gf2 keyGen 438 | :?> GTOther keyGen 439 | :-> GTNESet 440 | :-> TTOther 441 | ) 442 | S.foldl' 443 | NES.foldl' 444 | 445 | prop_foldr1' :: Property 446 | prop_foldr1' = 447 | ttProp 448 | ( gf2 keyGen 449 | :?> GTNESet 450 | :-> TTOther 451 | ) 452 | foldr1 453 | NES.foldr1' 454 | 455 | prop_foldl1' :: Property 456 | prop_foldl1' = 457 | ttProp 458 | ( gf2 keyGen 459 | :?> GTNESet 460 | :-> TTOther 461 | ) 462 | foldl1 463 | NES.foldl1' 464 | 465 | prop_findMin :: Property 466 | prop_findMin = 467 | ttProp 468 | (GTNESet :-> TTKey) 469 | S.findMin 470 | NES.findMin 471 | 472 | prop_findMax :: Property 473 | prop_findMax = 474 | ttProp 475 | (GTNESet :-> TTKey) 476 | S.findMax 477 | NES.findMax 478 | 479 | prop_deleteMin :: Property 480 | prop_deleteMin = 481 | ttProp 482 | (GTNESet :-> TTSet) 483 | S.deleteMin 484 | NES.deleteMin 485 | 486 | prop_deleteMax :: Property 487 | prop_deleteMax = 488 | ttProp 489 | (GTNESet :-> TTSet) 490 | S.deleteMax 491 | NES.deleteMax 492 | 493 | prop_deleteFindMin :: Property 494 | prop_deleteFindMin = 495 | ttProp 496 | (GTNESet :-> TTKey :*: TTSet) 497 | S.deleteFindMin 498 | NES.deleteFindMin 499 | 500 | prop_deleteFindMax :: Property 501 | prop_deleteFindMax = 502 | ttProp 503 | (GTNESet :-> TTKey :*: TTSet) 504 | S.deleteFindMax 505 | NES.deleteFindMax 506 | 507 | prop_toList :: Property 508 | prop_toList = 509 | ttProp 510 | (GTNESet :-> TTNEList TTKey) 511 | S.toList 512 | NES.toList 513 | 514 | prop_toDescList :: Property 515 | prop_toDescList = 516 | ttProp 517 | (GTNESet :-> TTNEList TTKey) 518 | S.toDescList 519 | NES.toDescList 520 | 521 | prop_elem :: Property 522 | prop_elem = 523 | ttProp 524 | (GTKey :-> GTNESet :-> TTOther) 525 | elem 526 | elem 527 | 528 | prop_fold1 :: Property 529 | prop_fold1 = 530 | ttProp 531 | (GTNESet :-> TTKey) 532 | fold 533 | fold1 534 | 535 | prop_fold :: Property 536 | prop_fold = 537 | ttProp 538 | (GTNESet :-> TTKey) 539 | fold 540 | fold 541 | 542 | prop_foldMap1 :: Property 543 | prop_foldMap1 = 544 | ttProp 545 | (gf1 keyGen :?> GTNESet :-> TTOther) 546 | (\f -> foldMap ((: []) . f)) 547 | (\f -> foldMap1 ((: []) . f)) 548 | 549 | prop_foldMap :: Property 550 | prop_foldMap = 551 | ttProp 552 | (gf1 keyGen :?> GTNESet :-> TTOther) 553 | (\f -> foldMap ((: []) . f)) 554 | (\f -> foldMap ((: []) . f)) 555 | -------------------------------------------------------------------------------- /test/Tests/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# OPTIONS_GHC -Wno-orphans #-} 14 | 15 | module Tests.Util ( 16 | K (..), 17 | KeyType, 18 | overKX, 19 | dummyKey, 20 | SortType (..), 21 | GenFunc (..), 22 | gf1, 23 | gf2, 24 | gf3, 25 | gf4, 26 | GenType (..), 27 | TestType (..), 28 | ttProp, 29 | groupTree, 30 | readShow, 31 | readShow1, 32 | showShow1, 33 | showShow2, 34 | Context (..), 35 | Bazaar (..), 36 | keyGen, 37 | valGen, 38 | mapSize, 39 | mapGen, 40 | neMapGen, 41 | setGen, 42 | neSetGen, 43 | intKeyGen, 44 | intMapGen, 45 | neIntMapGen, 46 | intSetGen, 47 | neIntSetGen, 48 | seqGen, 49 | neSeqGen, 50 | ) where 51 | 52 | import Control.Applicative 53 | import Control.Monad 54 | import Data.Bifunctor 55 | import Data.Char 56 | import Data.Foldable 57 | import Data.Function 58 | import Data.Functor.Apply 59 | import Data.Functor.Classes 60 | import Data.Functor.Identity 61 | import Data.IntMap (IntMap) 62 | import qualified Data.IntMap as IM 63 | import Data.IntMap.NonEmpty (NEIntMap) 64 | import qualified Data.IntMap.NonEmpty as NEIM 65 | import Data.IntSet (IntSet, Key) 66 | import qualified Data.IntSet as IS 67 | import Data.IntSet.NonEmpty (NEIntSet) 68 | import qualified Data.IntSet.NonEmpty as NEIS 69 | import Data.Kind 70 | import Data.List.NonEmpty (NonEmpty (..)) 71 | import qualified Data.List.NonEmpty as NE 72 | import Data.Map (Map) 73 | import qualified Data.Map as M 74 | import Data.Map.NonEmpty (NEMap) 75 | import qualified Data.Map.NonEmpty as NEM 76 | import Data.Maybe 77 | import Data.Semigroup.Foldable 78 | import Data.Sequence (Seq (..)) 79 | import Data.Sequence.NonEmpty (NESeq (..)) 80 | import qualified Data.Sequence.NonEmpty as NESeq 81 | import Data.Set (Set) 82 | import qualified Data.Set as S 83 | import Data.Set.NonEmpty (NESet) 84 | import qualified Data.Set.NonEmpty as NES 85 | import Data.Text (Text) 86 | import qualified Data.Text as T 87 | import Data.These 88 | import Hedgehog 89 | import Hedgehog.Function hiding ((:*:)) 90 | import qualified Hedgehog.Gen as Gen 91 | import Hedgehog.Internal.Property 92 | import qualified Hedgehog.Range as Range 93 | import Test.Tasty 94 | import Test.Tasty.Hedgehog 95 | import Text.Read 96 | 97 | #if !MIN_VERSION_base(4,11,0) 98 | import Data.Semigroup (Semigroup(..)) 99 | #endif 100 | 101 | {-# ANN module ("HLint: ignore Avoid NonEmpty.unzip" :: String) #-} 102 | 103 | groupTree :: Group -> TestTree 104 | groupTree Group{..} = 105 | testGroup 106 | (unGroupName groupName) 107 | (map (uncurry go) groupProperties) 108 | where 109 | go :: PropertyName -> Property -> TestTree 110 | go n = testProperty (mkName (unPropertyName n)) 111 | mkName = map deUnderscore . drop (length @[] @Char "prop_") 112 | deUnderscore '_' = ' ' 113 | deUnderscore c = c 114 | 115 | -- | test for stability 116 | data K a b = K {getKX :: !a, getKY :: !b} 117 | deriving (Show, Read, Generic) 118 | 119 | withK :: (a -> b -> c) -> K a b -> c 120 | withK f (K x y) = f x y 121 | 122 | overKX :: (a -> c) -> K a b -> K c b 123 | overKX f (K x y) = K (f x) y 124 | 125 | instance Eq a => Eq (K a b) where 126 | (==) = (==) `on` getKX 127 | 128 | instance Ord a => Ord (K a b) where 129 | compare = compare `on` getKX 130 | 131 | instance (Vary a, Vary b) => Vary (K a b) 132 | instance (Arg a, Arg b) => Arg (K a b) 133 | 134 | type KeyType = K Int Text 135 | 136 | instance Semigroup KeyType where 137 | K x1 y1 <> K x2 y2 = K (x1 + x2) (y1 <> y2) 138 | 139 | instance Monoid KeyType where 140 | mempty = K 0 "" 141 | mappend = (<>) 142 | 143 | dummyKey :: KeyType 144 | dummyKey = K 0 "hello" 145 | 146 | #if MIN_VERSION_base(4,11,0) 147 | instance (Num a, Monoid b) => Num (K a b) where 148 | K x1 y1 + K x2 y2 = K (x1 + x2) (y1 <> y2) 149 | K x1 y1 - K x2 y2 = K (x1 - x2) (y1 <> y2) 150 | K x1 y1 * K x2 y2 = K (x1 * x2) (y1 <> y2) 151 | negate (K x y) = K (negate x) y 152 | abs (K x y) = K (abs x) y 153 | signum (K x y) = K (signum x) y 154 | fromInteger n = K (fromInteger n) mempty 155 | #else 156 | instance (Num a, Semigroup b, Monoid b) => Num (K a b) where 157 | K x1 y1 + K x2 y2 = K (x1 + x2) (y1 <> y2) 158 | K x1 y1 - K x2 y2 = K (x1 - x2) (y1 <> y2) 159 | K x1 y1 * K x2 y2 = K (x1 * x2) (y1 <> y2) 160 | negate (K x y) = K (negate x) y 161 | abs (K x y) = K (abs x) y 162 | signum (K x y) = K (signum x) y 163 | fromInteger n = K (fromInteger n) mempty 164 | #endif 165 | 166 | data Context a b t = Context (b -> t) a 167 | deriving (Functor) 168 | 169 | data Bazaar a b t 170 | = Done t 171 | | More a (Bazaar a b (b -> t)) 172 | deriving (Functor) 173 | 174 | #if MIN_VERSION_semigroupoids(5,2,2) 175 | instance Apply (Bazaar a b) where 176 | liftF2 f = \case 177 | Done x -> fmap (f x) 178 | More x b -> More x . liftA2 (\g r y -> f (g y) r) b 179 | #else 180 | instance Apply (Bazaar a b) where 181 | (<.>) = \case 182 | Done x -> fmap x 183 | More x b -> More x . liftA2 (\g r y -> g y r) b 184 | #endif 185 | 186 | instance Applicative (Bazaar a b) where 187 | pure = Done 188 | liftA2 = liftF2 189 | 190 | data SortType :: Type -> Type where 191 | STAsc :: Ord a => SortType a 192 | STDesc :: Ord a => SortType a 193 | STDistinctAsc :: Ord a => SortType (a, b) 194 | STDistinctDesc :: Ord a => SortType (a, b) 195 | 196 | data GenType :: Type -> Type -> Type where 197 | GTNEMap :: GenType (Map KeyType Text) (NEMap KeyType Text) 198 | GTMap :: GenType (Map KeyType Text) (Map KeyType Text) 199 | GTNESet :: GenType (Set KeyType) (NESet KeyType) 200 | GTNEIntMap :: GenType (IntMap Text) (NEIntMap Text) 201 | GTNEIntSet :: GenType IntSet NEIntSet 202 | GTIntMap :: GenType (IntMap Text) (IntMap Text) 203 | GTNESeq :: GenType (Seq Text) (NESeq Text) 204 | GTNESeqList :: GenType (NonEmpty Text) (NESeq Text) 205 | GTSeq :: GenType (Seq Text) (Seq Text) 206 | GTKey :: GenType KeyType KeyType 207 | GTIntKey :: GenType Int Int 208 | GTVal :: GenType Text Text 209 | GTSize :: GenType Int Int 210 | GTOther :: 211 | Gen a -> 212 | GenType a a 213 | GTMaybe :: 214 | GenType a b -> 215 | GenType (Maybe a) (Maybe b) 216 | (:&:) :: 217 | GenType a b -> 218 | GenType c d -> 219 | GenType (a, c) (b, d) 220 | GTNEList :: 221 | Maybe (Range Int) -> 222 | GenType a b -> 223 | GenType [a] (NonEmpty b) 224 | GTSet :: GenType (Set KeyType) (Set KeyType) 225 | GTIntSet :: GenType IntSet IntSet 226 | GTSorted :: 227 | SortType a -> 228 | GenType [a] (NonEmpty a) -> 229 | GenType [a] (NonEmpty a) 230 | 231 | data GenFunc :: Type -> Type -> Type -> Type where 232 | GF :: 233 | (Show a, Arg a, Vary a, Show b) => 234 | Gen b -> 235 | ((a -> b) -> f) -> 236 | GenFunc f c d 237 | 238 | gf1 :: 239 | (Show a, Arg a, Vary a, Show b) => 240 | Gen b -> 241 | GenFunc (a -> b) c d 242 | gf1 = (`GF` id) 243 | 244 | gf2 :: 245 | (Show a, Show b, Arg a, Vary a, Arg b, Vary b, Show c) => 246 | Gen c -> 247 | GenFunc (a -> b -> c) d e 248 | gf2 = (`GF` curry) 249 | 250 | gf3 :: 251 | (Show a, Show b, Show c, Arg a, Vary a, Arg b, Vary b, Arg c, Vary c, Show d) => 252 | Gen d -> 253 | GenFunc (a -> b -> c -> d) e f 254 | gf3 = (`GF` (curry . curry)) 255 | 256 | gf4 :: 257 | (Show a, Show b, Show c, Arg a, Vary a, Arg b, Vary b, Arg c, Vary c, Show d, Show e, Arg d, Vary d) => 258 | Gen e -> 259 | GenFunc (a -> b -> c -> d -> e) f g 260 | gf4 = (`GF` (curry . curry . curry)) 261 | 262 | data TestType :: Type -> Type -> Type where 263 | TTNEMap :: 264 | (Eq a, Show a) => 265 | TestType (Map KeyType a) (NEMap KeyType a) 266 | TTNEIntMap :: 267 | (Eq a, Show a) => 268 | TestType (IntMap a) (NEIntMap a) 269 | TTNESet :: TestType (Set KeyType) (NESet KeyType) 270 | TTNEIntSet :: TestType IntSet NEIntSet 271 | TTMap :: 272 | (Eq a, Show a) => 273 | TestType (Map KeyType a) (Map KeyType a) 274 | TTSet :: TestType (Set KeyType) (Set KeyType) 275 | TTNESeq :: 276 | (Eq a, Show a) => 277 | TestType (Seq a) (NESeq a) 278 | TTNESeqList :: 279 | (Eq a, Show a) => 280 | TestType (NonEmpty a) (NESeq a) 281 | TTKey :: TestType KeyType KeyType 282 | TTVal :: TestType Text Text 283 | TTOther :: 284 | (Eq a, Show a) => 285 | TestType a a 286 | TTThese :: 287 | (Eq a, Show a, Monoid a, Eq c, Show c, Monoid c) => 288 | TestType a b -> 289 | TestType c d -> 290 | TestType (a, c) (These b d) 291 | TTMThese :: 292 | (Eq a, Show a, Monoid a, Eq c, Show c, Monoid c) => 293 | TestType a b -> 294 | TestType c d -> 295 | TestType (a, c) (Maybe (These b d)) 296 | TTTThese :: 297 | (Eq a, Show a, Monoid a, Eq c, Show c, Monoid c, Eq e, Show e, Monoid e) => 298 | TestType a b -> 299 | TestType c d -> 300 | TestType e f -> 301 | TestType (Maybe a, c, e) (These b (These d f)) 302 | TTMaybe :: 303 | TestType a b -> 304 | TestType (Maybe a) (Maybe b) 305 | TTEither :: 306 | TestType a b -> 307 | TestType c d -> 308 | TestType (Either a c) (Either b d) 309 | TTNEList :: 310 | TestType a b -> 311 | TestType [a] (NonEmpty b) 312 | TTCtx :: 313 | TestType (c -> t) (d -> u) -> 314 | TestType a b -> 315 | TestType (Context a c t) (Context b d u) 316 | TTBazaar :: 317 | (Show a, Show b, Show c, Show d) => 318 | GenType c d -> 319 | TestType t u -> 320 | TestType a b -> 321 | TestType (Bazaar a c t) (Bazaar b d u) 322 | (:*:) :: 323 | (Eq a, Eq b, Eq c, Eq d, Show a, Show b, Show c, Show d) => 324 | TestType a b -> 325 | TestType c d -> 326 | TestType (a, c) (b, d) 327 | (:?>) :: 328 | GenFunc f c d -> 329 | TestType c d -> 330 | TestType (f -> c) (f -> d) 331 | (:->) :: 332 | (Show a, Show b) => 333 | GenType a b -> 334 | TestType c d -> 335 | TestType (a -> c) (b -> d) 336 | 337 | infixr 2 :&: 338 | infixr 1 :-> 339 | infixr 1 :?> 340 | infixr 2 :*: 341 | 342 | runSorter :: 343 | SortType a -> 344 | [a] -> 345 | [a] 346 | runSorter = \case 347 | STAsc -> S.toAscList . S.fromList 348 | STDesc -> S.toDescList . S.fromList 349 | STDistinctAsc -> M.toAscList . M.fromList 350 | STDistinctDesc -> M.toDescList . M.fromList 351 | 352 | runGT :: GenType a b -> Gen (a, b) 353 | runGT = \case 354 | GTNEMap -> (\n -> (NEM.IsNonEmpty n, n)) <$> neMapGen 355 | GTMap -> join (,) <$> mapGen 356 | GTNESet -> (\n -> (NES.IsNonEmpty n, n)) <$> neSetGen 357 | GTNEIntMap -> (\n -> (NEIM.IsNonEmpty n, n)) <$> neIntMapGen 358 | GTNEIntSet -> (\n -> (NEIS.IsNonEmpty n, n)) <$> neIntSetGen 359 | GTIntMap -> join (,) <$> intMapGen 360 | GTSet -> join (,) <$> setGen 361 | GTIntSet -> join (,) <$> intSetGen 362 | GTNESeq -> (\n -> (NESeq.IsNonEmpty n, n)) <$> neSeqGen 363 | GTNESeqList -> (\n -> (toNonEmpty n, n)) <$> neSeqGen 364 | GTSeq -> join (,) <$> seqGen 365 | GTKey -> join (,) <$> keyGen 366 | GTIntKey -> join (,) <$> intKeyGen 367 | GTVal -> join (,) <$> valGen 368 | GTSize -> join (,) <$> Gen.int mapSize 369 | GTOther g -> join (,) <$> g 370 | GTMaybe g -> 371 | maybe (Nothing, Nothing) (bimap Just Just) 372 | <$> Gen.maybe (runGT g) 373 | g1 :&: g2 -> do 374 | (x1, y1) <- runGT g1 375 | (x2, y2) <- runGT g2 376 | pure ((x1, x2), (y1, y2)) 377 | GTNEList r g -> 378 | first toList . NE.unzip 379 | <$> Gen.nonEmpty (fromMaybe mapSize r) (runGT g) 380 | GTSorted s g -> 381 | bimap (runSorter s) (fromJust . NE.nonEmpty . runSorter s . toList) 382 | <$> runGT g 383 | 384 | runTT :: Monad m => TestType a b -> a -> b -> PropertyT m () 385 | runTT = \case 386 | TTNEMap -> \x y -> do 387 | assert $ NEM.valid y 388 | unKMap x === unKMap (NEM.IsNonEmpty y) 389 | TTNEIntMap -> \x y -> do 390 | assert $ NEIM.valid y 391 | x === NEIM.IsNonEmpty y 392 | TTNESet -> \x y -> do 393 | assert $ NES.valid y 394 | unKSet x === unKSet (NES.IsNonEmpty y) 395 | TTNEIntSet -> \x y -> do 396 | assert $ NEIS.valid y 397 | x === NEIS.IsNonEmpty y 398 | TTMap -> \x y -> 399 | unKMap x === unKMap y 400 | TTSet -> \x y -> 401 | unKSet x === unKSet y 402 | TTNESeq -> \x y -> 403 | x === NESeq.IsNonEmpty y 404 | TTNESeqList -> \x y -> 405 | x === toNonEmpty y 406 | TTKey -> \(K x1 y1) (K x2 y2) -> do 407 | x1 === x2 408 | y1 === y2 409 | TTVal -> (===) 410 | TTOther -> (===) 411 | TTThese t1 t2 -> \(x1, x2) -> \case 412 | This y1 -> do 413 | runTT t1 x1 y1 414 | x2 === mempty 415 | That y2 -> do 416 | x1 === mempty 417 | runTT t2 x2 y2 418 | These y1 y2 -> do 419 | runTT t1 x1 y1 420 | runTT t2 x2 y2 421 | TTMThese t1 t2 -> \(x1, x2) -> \case 422 | Nothing -> do 423 | x1 === mempty 424 | x2 === mempty 425 | Just (This y1) -> do 426 | runTT t1 x1 y1 427 | x2 === mempty 428 | Just (That y2) -> do 429 | x1 === mempty 430 | runTT t2 x2 y2 431 | Just (These y1 y2) -> do 432 | runTT t1 x1 y1 433 | runTT t2 x2 y2 434 | TTTThese t1 t2 t3 -> \(x1, x2, x3) -> \case 435 | This y1 -> do 436 | mapM_ (flip (runTT t1) y1) x1 437 | x2 === mempty 438 | x3 === mempty 439 | That y23 -> do 440 | x1 === mempty 441 | runTT (TTThese t2 t3) (x2, x3) y23 442 | These y1 y23 -> do 443 | mapM_ (flip (runTT t1) y1) x1 444 | runTT (TTThese t2 t3) (x2, x3) y23 445 | TTMaybe tt -> \x y -> do 446 | isJust y === isJust y 447 | traverse_ (uncurry (runTT tt)) $ liftA2 (,) x y 448 | TTEither tl tr -> \case 449 | Left x -> \case 450 | Left y -> runTT tl x y 451 | Right _ -> annotate "Left -> Right" *> failure 452 | Right x -> \case 453 | Left _ -> annotate "Right -> Left" *> failure 454 | Right y -> runTT tr x y 455 | TTNEList tt -> \xs ys -> do 456 | length xs === length ys 457 | zipWithM_ (runTT tt) xs (toList ys) 458 | TTCtx tSet tView -> \(Context xS xV) (Context yS yV) -> do 459 | runTT tSet xS yS 460 | runTT tView xV yV 461 | TTBazaar gNew tRes tView -> testBazaar gNew tRes tView 462 | t1 :*: t2 -> \(x1, x2) (y1, y2) -> do 463 | runTT t1 x1 y1 464 | runTT t2 x2 y2 465 | GF gt c :?> tt -> \gx gy -> do 466 | f <- c <$> forAllFn (fn gt) 467 | runTT tt (gx f) (gy f) 468 | gt :-> tt -> \f g -> do 469 | (x, y) <- forAll $ runGT gt 470 | runTT tt (f x) (g y) 471 | where 472 | unKMap :: (Ord k, Ord j) => Map (K k j) c -> Map (k, j) c 473 | unKMap = M.mapKeys (withK (,)) 474 | unKSet :: (Ord k, Ord j) => Set (K k j) -> Set (k, j) 475 | unKSet = S.map (withK (,)) 476 | 477 | testBazaar :: 478 | forall a b c d t u m. 479 | (Show a, Show b, Show c, Show d, Monad m) => 480 | GenType c d -> 481 | TestType t u -> 482 | TestType a b -> 483 | Bazaar a c t -> 484 | Bazaar b d u -> 485 | PropertyT m () 486 | testBazaar gNew tRes0 tView = go [] [] tRes0 487 | where 488 | go :: [a] -> [b] -> TestType t' u' -> Bazaar a c t' -> Bazaar b d u' -> PropertyT m () 489 | go xs ys tRes = \case 490 | Done xRes -> \case 491 | Done yRes -> do 492 | annotate "The final result matches" 493 | runTT tRes xRes yRes 494 | More yView _ -> do 495 | annotate "ys had more elements than xs" 496 | annotate $ show xs 497 | annotate $ show ys 498 | annotate $ show yView 499 | failure 500 | More xView xNext -> \case 501 | Done _ -> do 502 | annotate "xs had more elements than ys" 503 | annotate $ show xs 504 | annotate $ show ys 505 | annotate $ show xView 506 | failure 507 | More yView yNext -> do 508 | annotate "Each individual piece matches pair-wise" 509 | runTT tView xView yView 510 | annotate "The remainders also match" 511 | go (xView : xs) (yView : ys) (gNew :-> tRes) xNext yNext 512 | 513 | -- --------------------- 514 | -- Properties 515 | -- --------------------- 516 | 517 | ttProp :: TestType a b -> a -> b -> Property 518 | ttProp tt x = property . runTT tt x 519 | 520 | readShow :: 521 | (Show a, Read a, Eq a) => 522 | Gen a -> 523 | Property 524 | readShow g = property $ do 525 | m0 <- forAll g 526 | tripping m0 show readMaybe 527 | 528 | readShow1 :: 529 | (Eq (f a), Show1 f, Show a, Show (f a), Read1 f, Read a) => 530 | Gen (f a) -> 531 | Property 532 | readShow1 g = property $ do 533 | m0 <- forAll g 534 | tripping m0 (flip (showsPrec1 0) "") (fmap fst . listToMaybe . readsPrec1 0) 535 | 536 | showShow1 :: 537 | (Show1 f, Show a, Show (f a)) => 538 | Gen (f a) -> 539 | Property 540 | showShow1 g = property $ do 541 | m0 <- forAll g 542 | let s0 = show m0 543 | s1 = showsPrec1 0 m0 "" 544 | s0 === s1 545 | 546 | showShow2 :: 547 | (Show2 f, Show a, Show b, Show (f a b)) => 548 | Gen (f a b) -> 549 | Property 550 | showShow2 g = property $ do 551 | m0 <- forAll g 552 | let s0 = show m0 553 | s2 = showsPrec2 0 m0 "" 554 | s0 === s2 555 | 556 | -- readShow2 557 | -- :: (Eq (f a b), Show2 f, Show a, Show b, Show (f a b), Read2 f, Read a, Read b) 558 | -- => Gen (f a b) 559 | -- -> Property 560 | -- readShow2 g = property $ do 561 | -- m0 <- forAll g 562 | -- tripping m0 (($ "") . showsPrec2 0) (fmap fst . listToMaybe . readsPrec2 0) 563 | 564 | -- --------------------- 565 | -- Generators 566 | -- --------------------- 567 | 568 | keyGen :: MonadGen m => m KeyType 569 | keyGen = 570 | K 571 | <$> intKeyGen 572 | <*> Gen.text (Range.linear 0 5) Gen.alphaNum 573 | 574 | valGen :: MonadGen m => m Text 575 | valGen = Gen.text (Range.linear 0 5) Gen.alphaNum 576 | 577 | mapSize :: Range Int 578 | mapSize = Range.exponential 1 8 579 | 580 | mapGen :: MonadGen m => m (Map KeyType Text) 581 | mapGen = Gen.map mapSize $ (,) <$> keyGen <*> valGen 582 | 583 | neMapGen :: (MonadGen m, GenBase m ~ Identity) => m (NEMap KeyType Text) 584 | neMapGen = Gen.just $ NEM.nonEmptyMap <$> mapGen 585 | 586 | setGen :: MonadGen m => m (Set KeyType) 587 | setGen = Gen.set mapSize keyGen 588 | 589 | neSetGen :: (MonadGen m, GenBase m ~ Identity) => m (NESet KeyType) 590 | neSetGen = Gen.just $ NES.nonEmptySet <$> setGen 591 | 592 | intKeyGen :: MonadGen m => m Key 593 | intKeyGen = Gen.int (Range.linear (-100) 100) 594 | 595 | intMapGen :: MonadGen m => m (IntMap Text) 596 | intMapGen = IM.fromDistinctAscList . M.toList <$> Gen.map mapSize ((,) <$> intKeyGen <*> valGen) 597 | 598 | neIntMapGen :: (MonadGen m, GenBase m ~ Identity) => m (NEIntMap Text) 599 | neIntMapGen = Gen.just $ NEIM.nonEmptyMap <$> intMapGen 600 | 601 | intSetGen :: MonadGen m => m IntSet 602 | intSetGen = IS.fromDistinctAscList . S.toList <$> Gen.set mapSize intKeyGen 603 | 604 | neIntSetGen :: (MonadGen m, GenBase m ~ Identity) => m NEIntSet 605 | neIntSetGen = Gen.just $ NEIS.nonEmptySet <$> intSetGen 606 | 607 | seqGen :: MonadGen m => m (Seq Text) 608 | seqGen = Gen.seq mapSize valGen 609 | 610 | neSeqGen :: (MonadGen m, GenBase m ~ Identity) => m (NESeq Text) 611 | neSeqGen = Gen.just $ NESeq.nonEmptySeq <$> seqGen 612 | 613 | -- --------------------- 614 | -- Orphans 615 | -- --------------------- 616 | 617 | instance Arg Char where 618 | build = via ord chr 619 | 620 | instance Arg Text where 621 | build = via T.unpack T.pack 622 | 623 | instance Vary Char where 624 | vary = contramap ord vary 625 | 626 | instance Vary Text where 627 | vary = contramap T.unpack vary 628 | --------------------------------------------------------------------------------